1 % $Id: mp.w 1313 2008-06-15 14:32:34Z taco $
2 % MetaPost, by John Hobby. Public domain.
4 % Much of this program was copied with permission from MF.web Version 1.9
5 % It interprets a language very similar to D.E. Knuth's METAFONT, but with
6 % changes designed to make it more suitable for PostScript output.
8 % TeX is a trademark of the American Mathematical Society.
9 % METAFONT is a trademark of Addison-Wesley Publishing Company.
10 % PostScript is a trademark of Adobe Systems Incorporated.
12 % Here is TeX material that gets inserted after \input webmac
13 \def\hang{\hangindent 3em\noindent\ignorespaces}
14 \def\textindent#1{\hangindent2.5em\noindent\hbox to2.5em{\hss#1 }\ignorespaces}
16 \def\psqrt#1{\sqrt{\mathstrut#1}}
18 \def\pct!{{\char`\%}} % percent sign in ordinary text
19 \font\tenlogo=logo10 % font used for the METAFONT logo
21 \def\MF{{\tenlogo META}\-{\tenlogo FONT}}
22 \def\MP{{\tenlogo META}\-{\tenlogo POST}}
23 \def\[#1]{\ignorespaces} % left over from pascal web
24 \def\<#1>{$\langle#1\rangle$}
25 \def\section{\mathhexbox278}
26 \let\swap=\leftrightarrow
27 \def\round{\mathop{\rm round}\nolimits}
28 \mathchardef\vb="026A % synonym for `\|'
30 \def\(#1){} % this is used to make section names sort themselves better
31 \def\9#1{} % this is used for sort keys in the index via @@:sort key}{entry@@>
38 This is \MP, a graphics-language processor based on D. E. Knuth's \MF.
40 The main purpose of the following program is to explain the algorithms of \MP\
41 as clearly as possible. However, the program has been written so that it
42 can be tuned to run efficiently in a wide variety of operating environments
43 by making comparatively few changes. Such flexibility is possible because
44 the documentation that follows is written in the \.{WEB} language, which is
45 at a higher level than C.
47 A large piece of software like \MP\ has inherent complexity that cannot
48 be reduced below a certain level of difficulty, although each individual
49 part is fairly simple by itself. The \.{WEB} language is intended to make
50 the algorithms as readable as possible, by reflecting the way the
51 individual program pieces fit together and by providing the
52 cross-references that connect different parts. Detailed comments about
53 what is going on, and about why things were done in certain ways, have
54 been liberally sprinkled throughout the program. These comments explain
55 features of the implementation, but they rarely attempt to explain the
56 \MP\ language itself, since the reader is supposed to be familiar with
57 {\sl The {\logos METAFONT\/}book} as well as the manual
59 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
60 {\sl A User's Manual for MetaPost}, Computing Science Technical Report 162,
61 AT\AM T Bell Laboratories.
63 @ The present implementation is a preliminary version, but the possibilities
64 for new features are limited by the desire to remain as nearly compatible
65 with \MF\ as possible.
67 On the other hand, the \.{WEB} description can be extended without changing
68 the core of the program, and it has been designed so that such
69 extensions are not extremely difficult to make.
70 The |banner| string defined here should be changed whenever \MP\
71 undergoes any modifications, so that it will be clear which version of
72 \MP\ might be the guilty party when a problem arises.
74 @^system dependencies@>
76 @d banner "This is MetaPost, Version 1.070 (Cweb version)" /* printed when \MP\ starts */
77 @d metapost_version "1.070"
82 @ The external library header for \MP\ is |mplib.h|. It contains a
83 few typedefs and the header defintions for the externally used
86 The most important of the typedefs is the definition of the structure
87 |MP_options|, that acts as a small, configurable front-end to the fairly
88 large |MP_instance| structure.
91 typedef struct MP_instance * MP;
93 typedef struct MP_options {
96 @<Exported function headers@>
98 @ The internal header file is much longer: it not only lists the complete
99 |MP_instance|, but also a lot of functions that have to be available to
100 the \ps\ backend, that is defined in a separate \.{WEB} file.
102 The variables from |MP_options| are included inside the |MP_instance|
107 typedef struct psout_data_struct * psout_data;
115 @<Types in the outer block@>
116 @<Constants in the outer block@>
117 # ifndef LIBAVL_ALLOCATOR
118 # define LIBAVL_ALLOCATOR
119 struct libavl_allocator {
120 void *(*libavl_malloc) (struct libavl_allocator *, size_t libavl_size);
121 void (*libavl_free) (struct libavl_allocator *, void *libavl_block);
124 typedef struct MP_instance {
128 @<Internal library declarations@>
137 #include <unistd.h> /* for access() */
138 #include <time.h> /* for struct tm \& co */
140 #include "psout.h" /* external header */
141 #include "mpmp.h" /* internal header */
142 #include "mppsout.h" /* internal header */
145 @<Basic printing procedures@>
146 @<Error handling procedures@>
148 @ Here are the functions that set up the \MP\ instance.
151 @<Declare |mp_reallocate| functions@>
152 struct MP_options *mp_options (void);
153 MP mp_initialize (struct MP_options *opt);
156 struct MP_options *mp_options (void) {
157 struct MP_options *opt;
158 opt = malloc(sizeof(MP_options));
160 memset (opt,0,sizeof(MP_options));
162 opt->ini_version = true;
166 @ The |__attribute__| pragma is gcc-only.
168 @<Internal library ... @>=
169 #if !defined(__GNUC__) || (__GNUC__ < 2)
170 # define __attribute__(x)
171 #endif /* !defined(__GNUC__) || (__GNUC__ < 2) */
174 MP __attribute__ ((noinline))
175 mp_do_new (struct MP_options *opt, jmp_buf *buf) {
176 MP mp = malloc(sizeof(MP_instance));
180 @<Set |ini_version|@>;
181 @<Allocate or initialize variables@>
182 if (opt->main_memory>mp->mem_max)
183 mp_reallocate_memory(mp,opt->main_memory);
184 mp_reallocate_paths(mp,1000);
185 mp_reallocate_fonts(mp,8);
190 static void mp_free (MP mp) {
191 int k; /* loop variable */
192 @<Dealloc variables@>
193 if (mp->noninteractive) {
194 @<Finish non-interactive use@>;
200 void __attribute__((noinline))
201 mp_do_initialize ( MP mp) {
202 @<Local variables for initialization@>
203 @<Set initial values of key variables@>
206 @ This procedure gets things started properly.
208 MP __attribute__ ((noinline))
209 mp_initialize (struct MP_options *opt) {
212 mp = mp_do_new(opt, &buf);
215 mp->history=mp_fatal_error_stop; /* in case we quit during initialization */
216 @<Setup the non-local jump buffer in |mp_new|@>;
217 if (mp->noninteractive) {
218 @<Prepare for non-interactive use@>;
220 t_open_out; /* open the terminal for output */
222 @<Check the ``constant'' values...@>;
225 mp_snprintf(ss,256,"Ouch---my internal constants have been clobbered!\n"
226 "---case %i",(int)mp->bad);
227 do_fprintf(mp->err_out,(char *)ss);
231 mp_do_initialize(mp); /* erase preloaded mem */
232 if (mp->ini_version) {
233 @<Run inimpost commands@>;
235 if (!mp->noninteractive) {
236 @<Initialize the output routines@>;
237 @<Get the first line of input and prepare to start@>;
238 @<Initializations after first line is read@>;
240 mp->history=mp_spotless;
245 @ @<Initializations after first line is read@>=
247 mp_init_map_file(mp, mp->troff_mode);
248 mp->history=mp_spotless; /* ready to go! */
249 if (mp->troff_mode) {
250 mp->internal[mp_gtroffmode]=unity;
251 mp->internal[mp_prologues]=unity;
253 if (!mp->noninteractive) {
254 if ( mp->start_sym>0 ) { /* insert the `\&{everyjob}' symbol */
255 mp->cur_sym=mp->start_sym; mp_back_input(mp);
259 @ @<Exported function headers@>=
260 extern struct MP_options *mp_options (void);
261 extern MP mp_initialize (struct MP_options *opt) ;
262 extern int mp_status(MP mp);
263 extern void *mp_userdata(MP mp);
266 int mp_status(MP mp) { return mp->history; }
269 void *mp_userdata(MP mp) { return mp->userdata; }
271 @ The overall \MP\ program begins with the heading just shown, after which
272 comes a bunch of procedure declarations and function declarations.
273 Finally we will get to the main program, which begins with the
274 comment `|start_here|'. If you want to skip down to the
275 main program now, you can look up `|start_here|' in the index.
276 But the author suggests that the best way to understand this program
277 is to follow pretty much the order of \MP's components as they appear in the
278 \.{WEB} description you are now reading, since the present ordering is
279 intended to combine the advantages of the ``bottom up'' and ``top down''
280 approaches to the problem of understanding a somewhat complicated system.
282 @ Some of the code below is intended to be used only when diagnosing the
283 strange behavior that sometimes occurs when \MP\ is being installed or
284 when system wizards are fooling around with \MP\ without quite knowing
285 what they are doing. Such code will not normally be compiled; it is
286 delimited by the preprocessor test `|#ifdef DEBUG .. #endif|'.
288 @ This program has two important variations: (1) There is a long and slow
289 version called \.{INIMP}, which does the extra calculations needed to
291 initialize \MP's internal tables; and (2)~there is a shorter and faster
292 production version, which cuts the initialization to a bare minimum.
294 Which is which is decided at runtime.
296 @ The following parameters can be changed at compile time to extend or
297 reduce \MP's capacity. They may have different values in \.{INIMP} and
298 in production versions of \MP.
300 @^system dependencies@>
303 #define file_name_size 255 /* file names shouldn't be longer than this */
304 #define bistack_size 1500 /* size of stack for bisection algorithms;
305 should probably be left at this value */
307 @ Like the preceding parameters, the following quantities can be changed
308 to extend or reduce \MP's capacity. But if they are changed,
309 it is necessary to rerun the initialization program \.{INIMP}
311 to generate new tables for the production \MP\ program.
312 One can't simply make helter-skelter changes to the following constants,
313 since certain rather complex initialization
314 numbers are computed from them.
317 int max_strings; /* maximum number of strings; must not exceed |max_halfword| */
318 int pool_size; /* maximum number of characters in strings, including all
319 error messages and help texts, and the names of all identifiers */
320 int mem_max; /* greatest index in \MP's internal |mem| array;
321 must be strictly less than |max_halfword|;
322 must be equal to |mem_top| in \.{INIMP}, otherwise |>=mem_top| */
323 int mem_top; /* largest index in the |mem| array dumped by \.{INIMP};
324 must not be greater than |mem_max| */
325 int hash_prime; /* a prime number equal to about 85\pct! of |hash_size| */
327 @ @<Option variables@>=
328 int error_line; /* width of context lines on terminal error messages */
329 int half_error_line; /* width of first lines of contexts in terminal
330 error messages; should be between 30 and |error_line-15| */
331 int max_print_line; /* width of longest text lines output; should be at least 60 */
332 int hash_size; /* maximum number of symbolic tokens,
333 must be less than |max_halfword-3*param_size| */
334 int param_size; /* maximum number of simultaneous macro parameters */
335 int max_in_open; /* maximum number of input files and error insertions that
336 can be going on simultaneously */
337 int main_memory; /* only for options, to set up |mem_max| and |mem_top| */
338 void *userdata; /* this allows the calling application to setup local */
341 @ The code below make the final chosen hash size the next larger
342 multiple of 2 from the requested size, and this array is a list of
343 suitable prime numbers to go with such values.
345 The top limit is chosen such that it is definately lower than
346 |max_halfword-3*param_size|, because |param_size| cannot be larger
347 than |max_halfword/sizeof(pointer)|.
350 static int mp_prime_choices[] =
351 { 12289, 24593, 49157, 98317,
352 196613, 393241, 786433, 1572869,
353 3145739, 6291469, 12582917, 25165843,
354 50331653, 100663319 };
358 @d set_value(a,b,c) do { a=c; if (b>c) a=b; } while (0)
363 set_value(mp->error_line,opt->error_line,79);
364 set_value(mp->half_error_line,opt->half_error_line,50);
365 if (mp->half_error_line>mp->error_line-15 )
366 mp->half_error_line = mp->error_line-15;
367 set_value(mp->max_print_line,opt->max_print_line,100);
368 mp->main_memory=5000;
371 if (opt->hash_size>0x8000000) opt->hash_size=0x8000000;
372 set_value(mp->hash_size,(2*opt->hash_size-1),16384);
375 mp->hash_size = mp->hash_size>>i;
376 while (mp->hash_size>=2) {
380 mp->hash_size = mp->hash_size << i;
381 if (mp->hash_size>0x8000000) mp->hash_size=0x8000000;
382 mp->hash_prime=mp_prime_choices[(i-14)];
384 set_value(mp->param_size,opt->param_size,150);
385 set_value(mp->max_in_open,opt->max_in_open,10);
386 mp->userdata=opt->userdata;
388 @ In case somebody has inadvertently made bad settings of the ``constants,''
389 \MP\ checks them using a global variable called |bad|.
391 This is the second of many sections of \MP\ where global variables are
395 integer bad; /* is some ``constant'' wrong? */
397 @ Later on we will say `\ignorespaces|if (mem_max>=max_halfword) bad=10;|',
398 or something similar. (We can't do that until |max_halfword| has been defined.)
400 In case you are wondering about the non-consequtive values of |bad|: some
401 of the things that used to be WEB constants are now runtime variables
402 with checking at assignment time.
404 @<Check the ``constant'' values for consistency@>=
406 if ( mp->mem_top<=1100 ) mp->bad=4;
408 @ Some |goto| labels are used by the following definitions. The label
409 `|restart|' is occasionally used at the very beginning of a procedure; and
410 the label `|reswitch|' is occasionally used just prior to a |case|
411 statement in which some cases change the conditions and we wish to branch
412 to the newly applicable case. Loops that are set up with the |loop|
413 construction defined below are commonly exited by going to `|done|' or to
414 `|found|' or to `|not_found|', and they are sometimes repeated by going to
415 `|continue|'. If two or more parts of a subroutine start differently but
416 end up the same, the shared code may be gathered together at
419 @ Here are some macros for common programming idioms.
421 @d incr(A) (A)=(A)+1 /* increase a variable by unity */
422 @d decr(A) (A)=(A)-1 /* decrease a variable by unity */
423 @d negate(A) (A)=-(A) /* change the sign of a variable */
424 @d double(A) (A)=(A)+(A)
427 @d do_nothing /* empty statement */
428 @d Return goto exit /* terminate a procedure call */
429 @f return nil /* \.{WEB} will henceforth say |return| instead of \\{return} */
431 @* \[2] The character set.
432 In order to make \MP\ readily portable to a wide variety of
433 computers, all of its input text is converted to an internal eight-bit
434 code that includes standard ASCII, the ``American Standard Code for
435 Information Interchange.'' This conversion is done immediately when each
436 character is read in. Conversely, characters are converted from ASCII to
437 the user's external representation just before they are output to a
441 Such an internal code is relevant to users of \MP\ only with respect to
442 the \&{char} and \&{ASCII} operations, and the comparison of strings.
444 @ Characters of text that have been converted to \MP's internal form
445 are said to be of type |ASCII_code|, which is a subrange of the integers.
448 typedef unsigned char ASCII_code; /* eight-bit numbers */
450 @ The present specification of \MP\ has been written under the assumption
451 that the character set contains at least the letters and symbols associated
452 with ASCII codes 040 through 0176; all of these characters are now
453 available on most computer terminals.
455 We shall use the name |text_char| to stand for the data type of the characters
456 that are converted to and from |ASCII_code| when they are input and output.
457 We shall also assume that |text_char| consists of the elements
458 |chr(first_text_char)| through |chr(last_text_char)|, inclusive.
459 The following definitions should be adjusted if necessary.
460 @^system dependencies@>
462 @d first_text_char 0 /* ordinal number of the smallest element of |text_char| */
463 @d last_text_char 255 /* ordinal number of the largest element of |text_char| */
466 typedef unsigned char text_char; /* the data type of characters in text files */
468 @ @<Local variables for init...@>=
471 @ The \MP\ processor converts between ASCII code and
472 the user's external character set by means of arrays |xord| and |xchr|
473 that are analogous to Pascal's |ord| and |chr| functions.
475 @d xchr(A) mp->xchr[(A)]
476 @d 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)=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=first_text_char;i<=last_text_char;i++) {
509 for (i=0200;i<=0377;i++) { xord(xchr(i))=i;}
510 for (i=0;i<=0176;i++) { xord(xchr(i))=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 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 strdup(fname);
597 @ This has to be done very early on, so it is best to put it in with
598 the |mp_new| allocations
600 @d set_callback_option(A) do { mp->A = mp_##A;
601 if (opt->A!=NULL) mp->A = opt->A;
604 @<Allocate or initialize ...@>=
605 set_callback_option(find_file);
606 set_callback_option(open_file);
607 set_callback_option(read_ascii_file);
608 set_callback_option(read_binary_file);
609 set_callback_option(close_file);
610 set_callback_option(eof_file);
611 set_callback_option(flush_file);
612 set_callback_option(write_ascii_file);
613 set_callback_option(write_binary_file);
615 @ Because |mp_find_file| is used so early, it has to be in the helpers
619 char *mp_find_file (MP mp, const char *fname, const char *fmode, int ftype) ;
620 void *mp_open_file (MP mp , const char *fname, const char *fmode, int ftype) ;
621 char *mp_read_ascii_file (MP mp, void *f, size_t *size) ;
622 void mp_read_binary_file (MP mp, void *f, void **d, size_t *size) ;
623 void mp_close_file (MP mp, void *f) ;
624 int mp_eof_file (MP mp, void *f) ;
625 void mp_flush_file (MP mp, void *f) ;
626 void mp_write_ascii_file (MP mp, void *f, const char *s) ;
627 void mp_write_binary_file (MP mp, void *f, void *s, size_t t) ;
629 @ The function to open files can now be very short.
632 void *mp_open_file(MP mp, const char *fname, const char *fmode, int ftype) {
635 realmode[0] = *fmode;
638 if (ftype==mp_filetype_terminal) {
639 return (fmode[0] == 'r' ? stdin : stdout);
640 } else if (ftype==mp_filetype_error) {
642 } else if (fname != NULL && (fmode[0] != 'r' || (! access (fname,R_OK)))) {
643 return (void *)fopen(fname, realmode);
648 @ This is a legacy interface: (almost) all file names pass through |name_of_file|.
651 char name_of_file[file_name_size+1]; /* the name of a system file */
652 int name_length;/* this many characters are actually
653 relevant in |name_of_file| (the rest are blank) */
655 @ @<Option variables@>=
656 int print_found_names; /* configuration parameter */
658 @ If this parameter is true, the terminal and log will report the found
659 file names for input files instead of the requested ones.
660 It is off by default because it creates an extra filename lookup.
662 @<Allocate or initialize ...@>=
663 mp->print_found_names = (opt->print_found_names>0 ? true : false);
665 @ \MP's file-opening procedures return |false| if no file identified by
666 |name_of_file| could be opened.
668 The |OPEN_FILE| macro takes care of the |print_found_names| parameter.
669 It is not used for opening a mem file for read, because that file name
673 if (mp->print_found_names) {
674 char *s = (mp->find_file)(mp,mp->name_of_file,A,ftype);
676 *f = (mp->open_file)(mp,mp->name_of_file,A, ftype);
677 strncpy(mp->name_of_file,s,file_name_size);
683 *f = (mp->open_file)(mp,mp->name_of_file,A, ftype);
686 return (*f ? true : false)
689 boolean mp_a_open_in (MP mp, void **f, int ftype) {
690 /* open a text file for input */
694 boolean mp_w_open_in (MP mp, void **f) {
695 /* open a word file for input */
696 *f = (mp->open_file)(mp,mp->name_of_file,"r",mp_filetype_memfile);
697 return (*f ? true : false);
700 boolean mp_a_open_out (MP mp, void **f, int ftype) {
701 /* open a text file for output */
705 boolean mp_b_open_out (MP mp, void **f, int ftype) {
706 /* open a binary file for output */
710 boolean mp_w_open_out (MP mp, void **f) {
711 /* open a word file for output */
712 int ftype = mp_filetype_memfile;
717 char *mp_read_ascii_file (MP mp, void *ff, size_t *size) {
719 size_t len = 0, lim = 128;
721 FILE *f = (FILE *)ff;
723 (void) mp; /* for -Wunused */
730 if (s==NULL) return NULL;
731 while (c!=EOF && c!='\n' && c!='\r') {
733 s =realloc(s, (lim+(lim>>2)));
734 if (s==NULL) return NULL;
742 if (c!=EOF && c!='\n')
751 void mp_write_ascii_file (MP mp, void *f, const char *s) {
759 void mp_read_binary_file (MP mp, void *f, void **data, size_t *size) {
763 len = fread(*data,1,*size,(FILE *)f);
768 void mp_write_binary_file (MP mp, void *f, void *s, size_t size) {
771 fwrite(s,size,1,(FILE *)f);
776 void mp_close_file (MP mp, void *f) {
783 int mp_eof_file (MP mp, void *f) {
786 return feof((FILE *)f);
792 void mp_flush_file (MP mp, void *f) {
798 @ Input from text files is read one line at a time, using a routine called
799 |input_ln|. This function is defined in terms of global variables called
800 |buffer|, |first|, and |last| that will be described in detail later; for
801 now, it suffices for us to know that |buffer| is an array of |ASCII_code|
802 values, and that |first| and |last| are indices into this array
803 representing the beginning and ending of a line of text.
806 size_t buf_size; /* maximum number of characters simultaneously present in
807 current lines of open files */
808 ASCII_code *buffer; /* lines of characters being read */
809 size_t first; /* the first unused position in |buffer| */
810 size_t last; /* end of the line just input to |buffer| */
811 size_t max_buf_stack; /* largest index used in |buffer| */
813 @ @<Allocate or initialize ...@>=
815 mp->buffer = xmalloc((mp->buf_size+1),sizeof(ASCII_code));
817 @ @<Dealloc variables@>=
821 void mp_reallocate_buffer(MP mp, size_t l) {
823 if (l>max_halfword) {
824 mp_confusion(mp,"buffer size"); /* can't happen (I hope) */
826 buffer = xmalloc((l+1),sizeof(ASCII_code));
827 memcpy(buffer,mp->buffer,(mp->buf_size+1));
829 mp->buffer = buffer ;
833 @ The |input_ln| function brings the next line of input from the specified
834 field into available positions of the buffer array and returns the value
835 |true|, unless the file has already been entirely read, in which case it
836 returns |false| and sets |last:=first|. In general, the |ASCII_code|
837 numbers that represent the next line of the file are input into
838 |buffer[first]|, |buffer[first+1]|, \dots, |buffer[last-1]|; and the
839 global variable |last| is set equal to |first| plus the length of the
840 line. Trailing blanks are removed from the line; thus, either |last=first|
841 (in which case the line was entirely blank) or |buffer[last-1]<>" "|.
844 The variable |max_buf_stack|, which is used to keep track of how large
845 the |buf_size| parameter must be to accommodate the present job, is
846 also kept up to date by |input_ln|.
849 boolean mp_input_ln (MP mp, void *f ) {
850 /* inputs the next line or returns |false| */
853 mp->last=mp->first; /* cf.\ Matthew 19\thinspace:\thinspace30 */
854 s = (mp->read_ascii_file)(mp,f, &size);
858 mp->last = mp->first+size;
859 if ( mp->last>=mp->max_buf_stack ) {
860 mp->max_buf_stack=mp->last+1;
861 while ( mp->max_buf_stack>=mp->buf_size ) {
862 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
865 memcpy((mp->buffer+mp->first),s,size);
866 /* while ( mp->buffer[mp->last]==' ' ) mp->last--; */
872 @ The user's terminal acts essentially like other files of text, except
873 that it is used both for input and for output. When the terminal is
874 considered an input file, the file variable is called |term_in|, and when it
875 is considered an output file the file variable is |term_out|.
876 @^system dependencies@>
879 void * term_in; /* the terminal as an input file */
880 void * term_out; /* the terminal as an output file */
881 void * err_out; /* the terminal as an output file */
883 @ Here is how to open the terminal files. In the default configuration,
884 nothing happens except that the command line (if there is one) is copied
885 to the input buffer. The variable |command_line| will be filled by the
886 |main| procedure. The copying can not be done earlier in the program
887 logic because in the |INI| version, the |buffer| is also used for primitive
890 @^system dependencies@>
892 @d t_open_out do {/* open the terminal for text output */
893 mp->term_out = (mp->open_file)(mp,"terminal", "w", mp_filetype_terminal);
894 mp->err_out = (mp->open_file)(mp,"error", "w", mp_filetype_error);
896 @d t_open_in do { /* open the terminal for text input */
897 mp->term_in = (mp->open_file)(mp,"terminal", "r", mp_filetype_terminal);
898 if (mp->command_line!=NULL) {
899 mp->last = strlen(mp->command_line);
900 strncpy((char *)mp->buffer,mp->command_line,mp->last);
901 xfree(mp->command_line);
907 @<Option variables@>=
910 @ @<Allocate or initialize ...@>=
911 mp->command_line = xstrdup(opt->command_line);
913 @ Sometimes it is necessary to synchronize the input/output mixture that
914 happens on the user's terminal, and three system-dependent
915 procedures are used for this
916 purpose. The first of these, |update_terminal|, is called when we want
917 to make sure that everything we have output to the terminal so far has
918 actually left the computer's internal buffers and been sent.
919 The second, |clear_terminal|, is called when we wish to cancel any
920 input that the user may have typed ahead (since we are about to
921 issue an unexpected error message). The third, |wake_up_terminal|,
922 is supposed to revive the terminal if the user has disabled it by
923 some instruction to the operating system. The following macros show how
924 these operations can be specified:
925 @^system dependencies@>
927 @d update_terminal (mp->flush_file)(mp,mp->term_out) /* empty the terminal output buffer */
928 @d clear_terminal do_nothing /* clear the terminal input buffer */
929 @d wake_up_terminal (mp->flush_file)(mp,mp->term_out)
930 /* cancel the user's cancellation of output */
932 @ We need a special routine to read the first line of \MP\ input from
933 the user's terminal. This line is different because it is read before we
934 have opened the transcript file; there is sort of a ``chicken and
935 egg'' problem here. If the user types `\.{input cmr10}' on the first
936 line, or if some macro invoked by that line does such an \.{input},
937 the transcript file will be named `\.{cmr10.log}'; but if no \.{input}
938 commands are performed during the first line of terminal input, the transcript
939 file will acquire its default name `\.{mpout.log}'. (The transcript file
940 will not contain error messages generated by the first line before the
941 first \.{input} command.)
943 The first line is even more special. It's nice to let the user start
944 running a \MP\ job by typing a command line like `\.{MP cmr10}'; in
945 such a case, \MP\ will operate as if the first line of input were
946 `\.{cmr10}', i.e., the first line will consist of the remainder of the
947 command line, after the part that invoked \MP.
949 @ Different systems have different ways to get started. But regardless of
950 what conventions are adopted, the routine that initializes the terminal
951 should satisfy the following specifications:
953 \yskip\textindent{1)}It should open file |term_in| for input from the
954 terminal. (The file |term_out| will already be open for output to the
957 \textindent{2)}If the user has given a command line, this line should be
958 considered the first line of terminal input. Otherwise the
959 user should be prompted with `\.{**}', and the first line of input
960 should be whatever is typed in response.
962 \textindent{3)}The first line of input, which might or might not be a
963 command line, should appear in locations |first| to |last-1| of the
966 \textindent{4)}The global variable |loc| should be set so that the
967 character to be read next by \MP\ is in |buffer[loc]|. This
968 character should not be blank, and we should have |loc<last|.
970 \yskip\noindent(It may be necessary to prompt the user several times
971 before a non-blank line comes in. The prompt is `\.{**}' instead of the
972 later `\.*' because the meaning is slightly different: `\.{input}' need
973 not be typed immediately after~`\.{**}'.)
975 @d loc mp->cur_input.loc_field /* location of first unread character in |buffer| */
978 boolean mp_init_terminal (MP mp) { /* gets the terminal input started */
985 if (!mp->noninteractive) {
986 wake_up_terminal; do_fprintf(mp->term_out,"**"); update_terminal;
989 if ( ! mp_input_ln(mp, mp->term_in ) ) { /* this shouldn't happen */
990 do_fprintf(mp->term_out,"\n! End of file on the terminal... why?");
991 @.End of file on the terminal@>
995 while ( (loc<(int)mp->last)&&(mp->buffer[loc]==' ') )
997 if ( loc<(int)mp->last ) {
998 return true; /* return unless the line was all blank */
1000 if (!mp->noninteractive) {
1001 do_fprintf(mp->term_out,"Please type the name of your input file.\n");
1007 boolean mp_init_terminal (MP mp) ;
1010 @* \[4] String handling.
1011 Symbolic token names and diagnostic messages are variable-length strings
1012 of eight-bit characters. Many strings \MP\ uses are simply literals
1013 in the compiled source, like the error messages and the names of the
1014 internal parameters. Other strings are used or defined from the \MP\ input
1015 language, and these have to be interned.
1017 \MP\ uses strings more extensively than \MF\ does, but the necessary
1018 operations can still be handled with a fairly simple data structure.
1019 The array |str_pool| contains all of the (eight-bit) ASCII codes in all
1020 of the strings, and the array |str_start| contains indices of the starting
1021 points of each string. Strings are referred to by integer numbers, so that
1022 string number |s| comprises the characters |str_pool[j]| for
1023 |str_start[s]<=j<str_start[ss]| where |ss=next_str[s]|. The string pool
1024 is allocated sequentially and |str_pool[pool_ptr]| is the next unused
1025 location. The first string number not currently in use is |str_ptr|
1026 and |next_str[str_ptr]| begins a list of free string numbers. String
1027 pool entries |str_start[str_ptr]| up to |pool_ptr| are reserved for a
1028 string currently being constructed.
1030 String numbers 0 to 255 are reserved for strings that correspond to single
1031 ASCII characters. This is in accordance with the conventions of \.{WEB},
1033 which converts single-character strings into the ASCII code number of the
1034 single character involved, while it converts other strings into integers
1035 and builds a string pool file. Thus, when the string constant \.{"."} appears
1036 in the program below, \.{WEB} converts it into the integer 46, which is the
1037 ASCII code for a period, while \.{WEB} will convert a string like \.{"hello"}
1038 into some integer greater than~255. String number 46 will presumably be the
1039 single character `\..'\thinspace; but some ASCII codes have no standard visible
1040 representation, and \MP\ may need to be able to print an arbitrary
1041 ASCII character, so the first 256 strings are used to specify exactly what
1042 should be printed for each of the 256 possibilities.
1045 typedef int pool_pointer; /* for variables that point into |str_pool| */
1046 typedef int str_number; /* for variables that point into |str_start| */
1049 ASCII_code *str_pool; /* the characters */
1050 pool_pointer *str_start; /* the starting pointers */
1051 str_number *next_str; /* for linking strings in order */
1052 pool_pointer pool_ptr; /* first unused position in |str_pool| */
1053 str_number str_ptr; /* number of the current string being created */
1054 pool_pointer init_pool_ptr; /* the starting value of |pool_ptr| */
1055 str_number init_str_use; /* the initial number of strings in use */
1056 pool_pointer max_pool_ptr; /* the maximum so far of |pool_ptr| */
1057 str_number max_str_ptr; /* the maximum so far of |str_ptr| */
1059 @ @<Allocate or initialize ...@>=
1060 mp->str_pool = xmalloc ((mp->pool_size +1),sizeof(ASCII_code));
1061 mp->str_start = xmalloc ((mp->max_strings+1),sizeof(pool_pointer));
1062 mp->next_str = xmalloc ((mp->max_strings+1),sizeof(str_number));
1064 @ @<Dealloc variables@>=
1065 xfree(mp->str_pool);
1066 xfree(mp->str_start);
1067 xfree(mp->next_str);
1069 @ Most printing is done from |char *|s, but sometimes not. Here are
1070 functions that convert an internal string into a |char *| for use
1071 by the printing routines, and vice versa.
1073 @d str(A) mp_str(mp,A)
1074 @d rts(A) mp_rts(mp,A)
1077 int mp_xstrcmp (const char *a, const char *b);
1078 char * mp_str (MP mp, str_number s);
1081 str_number mp_rts (MP mp, const char *s);
1082 str_number mp_make_string (MP mp);
1084 @ The attempt to catch interrupted strings that is in |mp_rts|, is not
1085 very good: it does not handle nesting over more than one level.
1088 int mp_xstrcmp (const char *a, const char *b) {
1089 if (a==NULL && b==NULL)
1099 char * mp_str (MP mp, str_number ss) {
1102 if (ss==mp->str_ptr) {
1106 s = xmalloc(len+1,sizeof(char));
1107 strncpy(s,(char *)(mp->str_pool+(mp->str_start[ss])),len);
1112 str_number mp_rts (MP mp, const char *s) {
1113 int r; /* the new string */
1114 int old; /* a possible string in progress */
1118 } else if (strlen(s)==1) {
1122 str_room((integer)strlen(s));
1123 if (mp->str_start[mp->str_ptr]<mp->pool_ptr)
1124 old = mp_make_string(mp);
1129 r = mp_make_string(mp);
1131 str_room(length(old));
1132 while (i<length(old)) {
1133 append_char((mp->str_start[old]+i));
1135 mp_flush_string(mp,old);
1141 @ Except for |strs_used_up|, the following string statistics are only
1142 maintained when code between |stat| $\ldots$ |tats| delimiters is not
1146 integer strs_used_up; /* strings in use or unused but not reclaimed */
1147 integer pool_in_use; /* total number of cells of |str_pool| actually in use */
1148 integer strs_in_use; /* total number of strings actually in use */
1149 integer max_pl_used; /* maximum |pool_in_use| so far */
1150 integer max_strs_used; /* maximum |strs_in_use| so far */
1152 @ Several of the elementary string operations are performed using \.{WEB}
1153 macros instead of functions, because many of the
1154 operations are done quite frequently and we want to avoid the
1155 overhead of procedure calls. For example, here is
1156 a simple macro that computes the length of a string.
1159 @d str_stop(A) mp->str_start[mp->next_str[(A)]] /* one cell past the end of string
1161 @d length(A) (str_stop((A))-mp->str_start[(A)]) /* the number of characters in string \# */
1163 @ The length of the current string is called |cur_length|. If we decide that
1164 the current string is not needed, |flush_cur_string| resets |pool_ptr| so that
1165 |cur_length| becomes zero.
1167 @d cur_length (mp->pool_ptr - mp->str_start[mp->str_ptr])
1168 @d flush_cur_string mp->pool_ptr=mp->str_start[mp->str_ptr]
1170 @ Strings are created by appending character codes to |str_pool|.
1171 The |append_char| macro, defined here, does not check to see if the
1172 value of |pool_ptr| has gotten too high; this test is supposed to be
1173 made before |append_char| is used.
1175 To test if there is room to append |l| more characters to |str_pool|,
1176 we shall write |str_room(l)|, which tries to make sure there is enough room
1177 by compacting the string pool if necessary. If this does not work,
1178 |do_compaction| aborts \MP\ and gives an apologetic error message.
1180 @d append_char(A) /* put |ASCII_code| \# at the end of |str_pool| */
1181 { mp->str_pool[mp->pool_ptr]=(A); incr(mp->pool_ptr);
1183 @d str_room(A) /* make sure that the pool hasn't overflowed */
1184 { if ( mp->pool_ptr+(A) > mp->max_pool_ptr ) {
1185 if ( mp->pool_ptr+(A) > mp->pool_size ) mp_do_compaction(mp, (A));
1186 else mp->max_pool_ptr=mp->pool_ptr+(A); }
1189 @ The following routine is similar to |str_room(1)| but it uses the
1190 argument |mp->pool_size| to prevent |do_compaction| from aborting when
1191 string space is exhausted.
1193 @<Declare the procedure called |unit_str_room|@>=
1194 void mp_unit_str_room (MP mp);
1197 void mp_unit_str_room (MP mp) {
1198 if ( mp->pool_ptr>=mp->pool_size ) mp_do_compaction(mp, mp->pool_size);
1199 if ( mp->pool_ptr>=mp->max_pool_ptr ) mp->max_pool_ptr=mp->pool_ptr+1;
1202 @ \MP's string expressions are implemented in a brute-force way: Every
1203 new string or substring that is needed is simply copied into the string pool.
1204 Space is eventually reclaimed by a procedure called |do_compaction| with
1205 the aid of a simple system system of reference counts.
1206 @^reference counts@>
1208 The number of references to string number |s| will be |str_ref[s]|. The
1209 special value |str_ref[s]=max_str_ref=127| is used to denote an unknown
1210 positive number of references; such strings will never be recycled. If
1211 a string is ever referred to more than 126 times, simultaneously, we
1212 put it in this category. Hence a single byte suffices to store each |str_ref|.
1214 @d max_str_ref 127 /* ``infinite'' number of references */
1215 @d add_str_ref(A) { if ( mp->str_ref[(A)]<max_str_ref ) incr(mp->str_ref[(A)]);
1221 @ @<Allocate or initialize ...@>=
1222 mp->str_ref = xmalloc ((mp->max_strings+1),sizeof(int));
1224 @ @<Dealloc variables@>=
1227 @ Here's what we do when a string reference disappears:
1229 @d delete_str_ref(A) {
1230 if ( mp->str_ref[(A)]<max_str_ref ) {
1231 if ( mp->str_ref[(A)]>1 ) decr(mp->str_ref[(A)]);
1232 else mp_flush_string(mp, (A));
1236 @<Declare the procedure called |flush_string|@>=
1237 void mp_flush_string (MP mp,str_number s) ;
1240 @ We can't flush the first set of static strings at all, so there
1241 is no point in trying
1244 void mp_flush_string (MP mp,str_number s) {
1246 mp->pool_in_use=mp->pool_in_use-length(s);
1247 decr(mp->strs_in_use);
1248 if ( mp->next_str[s]!=mp->str_ptr ) {
1252 decr(mp->strs_used_up);
1254 mp->pool_ptr=mp->str_start[mp->str_ptr];
1258 @ C literals cannot be simply added, they need to be set so they can't
1261 @d intern(A) mp_intern(mp,(A))
1264 str_number mp_intern (MP mp, const char *s) {
1267 mp->str_ref[r] = max_str_ref;
1272 str_number mp_intern (MP mp, const char *s);
1275 @ Once a sequence of characters has been appended to |str_pool|, it
1276 officially becomes a string when the function |make_string| is called.
1277 This function returns the identification number of the new string as its
1280 When getting the next unused string number from the linked list, we pretend
1282 $$ \hbox{|max_str_ptr+1|, |max_str_ptr+2|, $\ldots$, |mp->max_strings|} $$
1283 are linked sequentially even though the |next_str| entries have not been
1284 initialized yet. We never allow |str_ptr| to reach |mp->max_strings|;
1285 |do_compaction| is responsible for making sure of this.
1288 @<Declare the procedure called |do_compaction|@>
1289 @<Declare the procedure called |unit_str_room|@>
1290 str_number mp_make_string (MP mp);
1293 str_number mp_make_string (MP mp) { /* current string enters the pool */
1294 str_number s; /* the new string */
1297 mp->str_ptr=mp->next_str[s];
1298 if ( mp->str_ptr>mp->max_str_ptr ) {
1299 if ( mp->str_ptr==mp->max_strings ) {
1301 mp_do_compaction(mp, 0);
1305 if ( mp->strs_used_up!=mp->max_str_ptr ) mp_confusion(mp, "s");
1306 @:this can't happen s}{\quad \.s@>
1308 mp->max_str_ptr=mp->str_ptr;
1309 mp->next_str[mp->str_ptr]=mp->max_str_ptr+1;
1313 mp->str_start[mp->str_ptr]=mp->pool_ptr;
1314 incr(mp->strs_used_up);
1315 incr(mp->strs_in_use);
1316 mp->pool_in_use=mp->pool_in_use+length(s);
1317 if ( mp->pool_in_use>mp->max_pl_used )
1318 mp->max_pl_used=mp->pool_in_use;
1319 if ( mp->strs_in_use>mp->max_strs_used )
1320 mp->max_strs_used=mp->strs_in_use;
1324 @ The most interesting string operation is string pool compaction. The idea
1325 is to recover unused space in the |str_pool| array by recopying the strings
1326 to close the gaps created when some strings become unused. All string
1327 numbers~$k$ where |str_ref[k]=0| are to be linked into the list of free string
1328 numbers after |str_ptr|. If this fails to free enough pool space we issue an
1329 |overflow| error unless |needed=mp->pool_size|. Calling |do_compaction|
1330 with |needed=mp->pool_size| supresses all overflow tests.
1332 The compaction process starts with |last_fixed_str| because all lower numbered
1333 strings are permanently allocated with |max_str_ref| in their |str_ref| entries.
1336 str_number last_fixed_str; /* last permanently allocated string */
1337 str_number fixed_str_use; /* number of permanently allocated strings */
1339 @ @<Declare the procedure called |do_compaction|@>=
1340 void mp_do_compaction (MP mp, pool_pointer needed) ;
1343 void mp_do_compaction (MP mp, pool_pointer needed) {
1344 str_number str_use; /* a count of strings in use */
1345 str_number r,s,t; /* strings being manipulated */
1346 pool_pointer p,q; /* destination and source for copying string characters */
1347 @<Advance |last_fixed_str| as far as possible and set |str_use|@>;
1348 r=mp->last_fixed_str;
1351 while ( s!=mp->str_ptr ) {
1352 while ( mp->str_ref[s]==0 ) {
1353 @<Advance |s| and add the old |s| to the list of free string numbers;
1354 then |break| if |s=str_ptr|@>;
1356 r=s; s=mp->next_str[s];
1358 @<Move string |r| back so that |str_start[r]=p|; make |p| the location
1359 after the end of the string@>;
1362 @<Move the current string back so that it starts at |p|@>;
1363 if ( needed<mp->pool_size ) {
1364 @<Make sure that there is room for another string with |needed| characters@>;
1366 @<Account for the compaction and make sure the statistics agree with the
1368 mp->strs_used_up=str_use;
1371 @ @<Advance |last_fixed_str| as far as possible and set |str_use|@>=
1372 t=mp->next_str[mp->last_fixed_str];
1373 while (t!=mp->str_ptr && mp->str_ref[t]==max_str_ref) {
1374 incr(mp->fixed_str_use);
1375 mp->last_fixed_str=t;
1378 str_use=mp->fixed_str_use
1380 @ Because of the way |flush_string| has been written, it should never be
1381 necessary to |break| here. The extra line of code seems worthwhile to
1382 preserve the generality of |do_compaction|.
1384 @<Advance |s| and add the old |s| to the list of free string numbers;...@>=
1389 mp->next_str[t]=mp->next_str[mp->str_ptr];
1390 mp->next_str[mp->str_ptr]=t;
1391 if ( s==mp->str_ptr ) goto DONE;
1394 @ The string currently starts at |str_start[r]| and ends just before
1395 |str_start[s]|. We don't change |str_start[s]| because it might be needed
1396 to locate the next string.
1398 @<Move string |r| back so that |str_start[r]=p|; make |p| the location...@>=
1401 while ( q<mp->str_start[s] ) {
1402 mp->str_pool[p]=mp->str_pool[q];
1406 @ Pointers |str_start[str_ptr]| and |pool_ptr| have not been updated. When
1407 we do this, anything between them should be moved.
1409 @ @<Move the current string back so that it starts at |p|@>=
1410 q=mp->str_start[mp->str_ptr];
1411 mp->str_start[mp->str_ptr]=p;
1412 while ( q<mp->pool_ptr ) {
1413 mp->str_pool[p]=mp->str_pool[q];
1418 @ We must remember that |str_ptr| is not allowed to reach |mp->max_strings|.
1420 @<Make sure that there is room for another string with |needed| char...@>=
1421 if ( str_use>=mp->max_strings-1 )
1422 mp_reallocate_strings (mp,str_use);
1423 if ( mp->pool_ptr+needed>mp->max_pool_ptr ) {
1424 mp_reallocate_pool(mp, mp->pool_ptr+needed);
1425 mp->max_pool_ptr=mp->pool_ptr+needed;
1429 void mp_reallocate_strings (MP mp, str_number str_use) ;
1430 void mp_reallocate_pool(MP mp, pool_pointer needed) ;
1433 void mp_reallocate_strings (MP mp, str_number str_use) {
1434 while ( str_use>=mp->max_strings-1 ) {
1435 int l = mp->max_strings + (mp->max_strings>>2);
1436 XREALLOC (mp->str_ref, l, int);
1437 XREALLOC (mp->str_start, l, pool_pointer);
1438 XREALLOC (mp->next_str, l, str_number);
1439 mp->max_strings = l;
1442 void mp_reallocate_pool(MP mp, pool_pointer needed) {
1443 while ( needed>mp->pool_size ) {
1444 int l = mp->pool_size + (mp->pool_size>>2);
1445 XREALLOC (mp->str_pool, l, ASCII_code);
1450 @ @<Account for the compaction and make sure the statistics agree with...@>=
1451 if ( (mp->str_start[mp->str_ptr]!=mp->pool_in_use)||(str_use!=mp->strs_in_use) )
1452 mp_confusion(mp, "string");
1453 @:this can't happen string}{\quad string@>
1454 incr(mp->pact_count);
1455 mp->pact_chars=mp->pact_chars+mp->pool_ptr-str_stop(mp->last_fixed_str);
1456 mp->pact_strs=mp->pact_strs+str_use-mp->fixed_str_use;
1458 s=mp->str_ptr; t=str_use;
1459 while ( s<=mp->max_str_ptr ){
1460 if ( t>mp->max_str_ptr ) mp_confusion(mp, "\"");
1461 incr(t); s=mp->next_str[s];
1463 if ( t<=mp->max_str_ptr ) mp_confusion(mp, "\"");
1466 @ A few more global variables are needed to keep track of statistics when
1467 |stat| $\ldots$ |tats| blocks are not commented out.
1470 integer pact_count; /* number of string pool compactions so far */
1471 integer pact_chars; /* total number of characters moved during compactions */
1472 integer pact_strs; /* total number of strings moved during compactions */
1474 @ @<Initialize compaction statistics@>=
1479 @ The following subroutine compares string |s| with another string of the
1480 same length that appears in |buffer| starting at position |k|;
1481 the result is |true| if and only if the strings are equal.
1484 boolean mp_str_eq_buf (MP mp,str_number s, integer k) {
1485 /* test equality of strings */
1486 pool_pointer j; /* running index */
1488 while ( j<str_stop(s) ) {
1489 if ( mp->str_pool[j++]!=mp->buffer[k++] )
1495 @ Here is a similar routine, but it compares two strings in the string pool,
1496 and it does not assume that they have the same length. If the first string
1497 is lexicographically greater than, less than, or equal to the second,
1498 the result is respectively positive, negative, or zero.
1501 integer mp_str_vs_str (MP mp, str_number s, str_number t) {
1502 /* test equality of strings */
1503 pool_pointer j,k; /* running indices */
1504 integer ls,lt; /* lengths */
1505 integer l; /* length remaining to test */
1506 ls=length(s); lt=length(t);
1507 if ( ls<=lt ) l=ls; else l=lt;
1508 j=mp->str_start[s]; k=mp->str_start[t];
1510 if ( mp->str_pool[j]!=mp->str_pool[k] ) {
1511 return (mp->str_pool[j]-mp->str_pool[k]);
1518 @ The initial values of |str_pool|, |str_start|, |pool_ptr|,
1519 and |str_ptr| are computed by the \.{INIMP} program, based in part
1520 on the information that \.{WEB} has output while processing \MP.
1525 void mp_get_strings_started (MP mp) {
1526 /* initializes the string pool,
1527 but returns |false| if something goes wrong */
1528 int k; /* small indices or counters */
1529 str_number g; /* a new string */
1530 mp->pool_ptr=0; mp->str_ptr=0; mp->max_pool_ptr=0; mp->max_str_ptr=0;
1533 mp->pool_in_use=0; mp->strs_in_use=0;
1534 mp->max_pl_used=0; mp->max_strs_used=0;
1535 @<Initialize compaction statistics@>;
1537 @<Make the first 256 strings@>;
1538 g=mp_make_string(mp); /* string 256 == "" */
1539 mp->str_ref[g]=max_str_ref;
1540 mp->last_fixed_str=mp->str_ptr-1;
1541 mp->fixed_str_use=mp->str_ptr;
1546 void mp_get_strings_started (MP mp);
1548 @ The first 256 strings will consist of a single character only.
1550 @<Make the first 256...@>=
1551 for (k=0;k<=255;k++) {
1553 g=mp_make_string(mp);
1554 mp->str_ref[g]=max_str_ref;
1557 @ The first 128 strings will contain 95 standard ASCII characters, and the
1558 other 33 characters will be printed in three-symbol form like `\.{\^\^A}'
1559 unless a system-dependent change is made here. Installations that have
1560 an extended character set, where for example |xchr[032]=@t\.{'^^Z'}@>|,
1561 would like string 032 to be printed as the single character 032 instead
1562 of the three characters 0136, 0136, 0132 (\.{\^\^Z}). On the other hand,
1563 even people with an extended character set will want to represent string
1564 015 by \.{\^\^M}, since 015 is ASCII's ``carriage return'' code; the idea is
1565 to produce visible strings instead of tabs or line-feeds or carriage-returns
1566 or bell-rings or characters that are treated anomalously in text files.
1568 Unprintable characters of codes 128--255 are, similarly, rendered
1569 \.{\^\^80}--\.{\^\^ff}.
1571 The boolean expression defined here should be |true| unless \MP\ internal
1572 code number~|k| corresponds to a non-troublesome visible symbol in the
1573 local character set.
1574 If character |k| cannot be printed, and |k<0200|, then character |k+0100| or
1575 |k-0100| must be printable; moreover, ASCII codes |[060..071, 0141..0146]|
1577 @^character set dependencies@>
1578 @^system dependencies@>
1580 @<Character |k| cannot be printed@>=
1583 @* \[5] On-line and off-line printing.
1584 Messages that are sent to a user's terminal and to the transcript-log file
1585 are produced by several `|print|' procedures. These procedures will
1586 direct their output to a variety of places, based on the setting of
1587 the global variable |selector|, which has the following possible
1591 \hang |term_and_log|, the normal setting, prints on the terminal and on the
1594 \hang |log_only|, prints only on the transcript file.
1596 \hang |term_only|, prints only on the terminal.
1598 \hang |no_print|, doesn't print at all. This is used only in rare cases
1599 before the transcript file is open.
1601 \hang |pseudo|, puts output into a cyclic buffer that is used
1602 by the |show_context| routine; when we get to that routine we shall discuss
1603 the reasoning behind this curious mode.
1605 \hang |new_string|, appends the output to the current string in the
1608 \hang |>=write_file| prints on one of the files used for the \&{write}
1609 @:write_}{\&{write} primitive@>
1613 \noindent The symbolic names `|term_and_log|', etc., have been assigned
1614 numeric codes that satisfy the convenient relations |no_print+1=term_only|,
1615 |no_print+2=log_only|, |term_only+2=log_only+1=term_and_log|. These
1616 relations are not used when |selector| could be |pseudo|, or |new_string|.
1617 We need not check for unprintable characters when |selector<pseudo|.
1619 Three additional global variables, |tally|, |term_offset| and |file_offset|
1620 record the number of characters that have been printed
1621 since they were most recently cleared to zero. We use |tally| to record
1622 the length of (possibly very long) stretches of printing; |term_offset|,
1623 and |file_offset|, on the other hand, keep track of how many
1624 characters have appeared so far on the current line that has been output
1625 to the terminal, the transcript file, or the \ps\ output file, respectively.
1627 @d new_string 0 /* printing is deflected to the string pool */
1628 @d pseudo 2 /* special |selector| setting for |show_context| */
1629 @d no_print 3 /* |selector| setting that makes data disappear */
1630 @d term_only 4 /* printing is destined for the terminal only */
1631 @d log_only 5 /* printing is destined for the transcript file only */
1632 @d term_and_log 6 /* normal |selector| setting */
1633 @d write_file 7 /* first write file selector */
1636 void * log_file; /* transcript of \MP\ session */
1637 void * ps_file; /* the generic font output goes here */
1638 unsigned int selector; /* where to print a message */
1639 unsigned char dig[23]; /* digits in a number being output */
1640 integer tally; /* the number of characters recently printed */
1641 unsigned int term_offset;
1642 /* the number of characters on the current terminal line */
1643 unsigned int file_offset;
1644 /* the number of characters on the current file line */
1645 ASCII_code *trick_buf; /* circular buffer for pseudoprinting */
1646 integer trick_count; /* threshold for pseudoprinting, explained later */
1647 integer first_count; /* another variable for pseudoprinting */
1649 @ @<Allocate or initialize ...@>=
1650 memset(mp->dig,0,23);
1651 mp->trick_buf = xmalloc((mp->error_line+1),sizeof(ASCII_code));
1653 @ @<Dealloc variables@>=
1654 xfree(mp->trick_buf);
1656 @ @<Initialize the output routines@>=
1657 mp->selector=term_only; mp->tally=0; mp->term_offset=0; mp->file_offset=0;
1659 @ Macro abbreviations for output to the terminal and to the log file are
1660 defined here for convenience. Some systems need special conventions
1661 for terminal output, and it is possible to adhere to those conventions
1662 by changing |wterm|, |wterm_ln|, and |wterm_cr| here.
1663 @^system dependencies@>
1665 @d do_fprintf(f,b) (mp->write_ascii_file)(mp,f,b)
1666 @d wterm(A) do_fprintf(mp->term_out,(A))
1667 @d wterm_chr(A) { unsigned char ss[2]; ss[0]=(A); ss[1]=0; do_fprintf(mp->term_out,(char *)ss); }
1668 @d wterm_cr do_fprintf(mp->term_out,"\n")
1669 @d wterm_ln(A) { wterm_cr; do_fprintf(mp->term_out,(A)); }
1670 @d wlog(A) do_fprintf(mp->log_file,(A))
1671 @d wlog_chr(A) { unsigned char ss[2]; ss[0]=(A); ss[1]=0; do_fprintf(mp->log_file,(char *)ss); }
1672 @d wlog_cr do_fprintf(mp->log_file, "\n")
1673 @d wlog_ln(A) { wlog_cr; do_fprintf(mp->log_file,(A)); }
1676 @ To end a line of text output, we call |print_ln|. Cases |0..max_write_files|
1677 use an array |wr_file| that will be declared later.
1679 @d mp_print_text(A) mp_print_str(mp,text((A)))
1682 void mp_print_ln (MP mp);
1683 void mp_print_visible_char (MP mp, ASCII_code s);
1684 void mp_print_char (MP mp, ASCII_code k);
1685 void mp_print (MP mp, const char *s);
1686 void mp_print_str (MP mp, str_number s);
1687 void mp_print_nl (MP mp, const char *s);
1688 void mp_print_two (MP mp,scaled x, scaled y) ;
1689 void mp_print_scaled (MP mp,scaled s);
1691 @ @<Basic print...@>=
1692 void mp_print_ln (MP mp) { /* prints an end-of-line */
1693 switch (mp->selector) {
1696 mp->term_offset=0; mp->file_offset=0;
1699 wlog_cr; mp->file_offset=0;
1702 wterm_cr; mp->term_offset=0;
1709 do_fprintf(mp->wr_file[(mp->selector-write_file)],"\n");
1711 } /* note that |tally| is not affected */
1713 @ The |print_visible_char| procedure sends one character to the desired
1714 destination, using the |xchr| array to map it into an external character
1715 compatible with |input_ln|. (It assumes that it is always called with
1716 a visible ASCII character.) All printing comes through |print_ln| or
1717 |print_char|, which ultimately calls |print_visible_char|, hence these
1718 routines are the ones that limit lines to at most |max_print_line| characters.
1719 But we must make an exception for the \ps\ output file since it is not safe
1720 to cut up lines arbitrarily in \ps.
1722 Procedure |unit_str_room| needs to be declared |forward| here because it calls
1723 |do_compaction| and |do_compaction| can call the error routines. Actually,
1724 |unit_str_room| avoids |overflow| errors but it can call |confusion|.
1726 @<Basic printing...@>=
1727 void mp_print_visible_char (MP mp, ASCII_code s) { /* prints a single character */
1728 switch (mp->selector) {
1730 wterm_chr(xchr(s)); wlog_chr(xchr(s));
1731 incr(mp->term_offset); incr(mp->file_offset);
1732 if ( mp->term_offset==(unsigned)mp->max_print_line ) {
1733 wterm_cr; mp->term_offset=0;
1735 if ( mp->file_offset==(unsigned)mp->max_print_line ) {
1736 wlog_cr; mp->file_offset=0;
1740 wlog_chr(xchr(s)); incr(mp->file_offset);
1741 if ( mp->file_offset==(unsigned)mp->max_print_line ) mp_print_ln(mp);
1744 wterm_chr(xchr(s)); incr(mp->term_offset);
1745 if ( mp->term_offset==(unsigned)mp->max_print_line ) mp_print_ln(mp);
1750 if ( mp->tally<mp->trick_count )
1751 mp->trick_buf[mp->tally % mp->error_line]=s;
1754 if ( mp->pool_ptr>=mp->max_pool_ptr ) {
1755 mp_unit_str_room(mp);
1756 if ( mp->pool_ptr>=mp->pool_size )
1757 goto DONE; /* drop characters if string space is full */
1762 { char ss[2]; ss[0] = xchr(s); ss[1]=0;
1763 do_fprintf(mp->wr_file[(mp->selector-write_file)],(char *)ss);
1770 @ The |print_char| procedure sends one character to the desired destination.
1771 File names and string expressions might contain |ASCII_code| values that
1772 can't be printed using |print_visible_char|. These characters will be
1773 printed in three- or four-symbol form like `\.{\^\^A}' or `\.{\^\^e4}'.
1774 (This procedure assumes that it is safe to bypass all checks for unprintable
1775 characters when |selector| is in the range |0..max_write_files-1|.
1776 The user might want to write unprintable characters.
1778 @d print_lc_hex(A) do { l=(A);
1779 mp_print_visible_char(mp, (l<10 ? l+'0' : l-10+'a'));
1782 @<Basic printing...@>=
1783 void mp_print_char (MP mp, ASCII_code k) { /* prints a single character */
1784 int l; /* small index or counter */
1785 if ( mp->selector<pseudo || mp->selector>=write_file) {
1786 mp_print_visible_char(mp, k);
1787 } else if ( @<Character |k| cannot be printed@> ) {
1790 mp_print_visible_char(mp, k+0100);
1791 } else if ( k<0200 ) {
1792 mp_print_visible_char(mp, k-0100);
1794 print_lc_hex(k / 16);
1795 print_lc_hex(k % 16);
1798 mp_print_visible_char(mp, k);
1802 @ An entire string is output by calling |print|. Note that if we are outputting
1803 the single standard ASCII character \.c, we could call |print("c")|, since
1804 |"c"=99| is the number of a single-character string, as explained above. But
1805 |print_char("c")| is quicker, so \MP\ goes directly to the |print_char|
1806 routine when it knows that this is safe. (The present implementation
1807 assumes that it is always safe to print a visible ASCII character.)
1808 @^system dependencies@>
1811 void mp_do_print (MP mp, const char *ss, unsigned int len) { /* prints string |s| */
1814 mp_print_char(mp, ss[j]); incr(j);
1820 void mp_print (MP mp, const char *ss) {
1821 if (ss==NULL) return;
1822 mp_do_print(mp, ss, strlen(ss));
1824 void mp_print_str (MP mp, str_number s) {
1825 pool_pointer j; /* current character code position */
1826 if ( (s<0)||(s>mp->max_str_ptr) ) {
1827 mp_do_print(mp,"???",3); /* this can't happen */
1831 mp_do_print(mp, (char *)(mp->str_pool+j), (str_stop(s)-j));
1835 @ Here is the very first thing that \MP\ prints: a headline that identifies
1836 the version number and base name. The |term_offset| variable is temporarily
1837 incorrect, but the discrepancy is not serious since we assume that the banner
1838 and mem identifier together will occupy at most |max_print_line|
1839 character positions.
1841 @<Initialize the output...@>=
1843 if (mp->mem_ident!=NULL)
1844 mp_print(mp,mp->mem_ident);
1848 @ The procedure |print_nl| is like |print|, but it makes sure that the
1849 string appears at the beginning of a new line.
1852 void mp_print_nl (MP mp, const char *s) { /* prints string |s| at beginning of line */
1853 switch(mp->selector) {
1855 if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_ln(mp);
1858 if ( mp->file_offset>0 ) mp_print_ln(mp);
1861 if ( mp->term_offset>0 ) mp_print_ln(mp);
1867 } /* there are no other cases */
1871 @ An array of digits in the range |0..9| is printed by |print_the_digs|.
1874 void mp_print_the_digs (MP mp, eight_bits k) {
1875 /* prints |dig[k-1]|$\,\ldots\,$|dig[0]| */
1877 decr(k); mp_print_char(mp, '0'+mp->dig[k]);
1881 @ The following procedure, which prints out the decimal representation of a
1882 given integer |n|, has been written carefully so that it works properly
1883 if |n=0| or if |(-n)| would cause overflow. It does not apply |%| or |/|
1884 to negative arguments, since such operations are not implemented consistently
1888 void mp_print_int (MP mp,integer n) { /* prints an integer in decimal form */
1889 integer m; /* used to negate |n| in possibly dangerous cases */
1890 int k = 0; /* index to current digit; we assume that $|n|<10^{23}$ */
1892 mp_print_char(mp, '-');
1893 if ( n>-100000000 ) {
1896 m=-1-n; n=m / 10; m=(m % 10)+1; k=1;
1900 mp->dig[0]=0; incr(n);
1905 mp->dig[k]=n % 10; n=n / 10; incr(k);
1907 mp_print_the_digs(mp, k);
1911 void mp_print_int (MP mp,integer n);
1913 @ \MP\ also makes use of a trivial procedure to print two digits. The
1914 following subroutine is usually called with a parameter in the range |0<=n<=99|.
1917 void mp_print_dd (MP mp,integer n) { /* prints two least significant digits */
1919 mp_print_char(mp, '0'+(n / 10));
1920 mp_print_char(mp, '0'+(n % 10));
1925 void mp_print_dd (MP mp,integer n);
1927 @ Here is a procedure that asks the user to type a line of input,
1928 assuming that the |selector| setting is either |term_only| or |term_and_log|.
1929 The input is placed into locations |first| through |last-1| of the
1930 |buffer| array, and echoed on the transcript file if appropriate.
1932 This procedure is never called when |interaction<mp_scroll_mode|.
1934 @d prompt_input(A) do {
1935 if (!mp->noninteractive) {
1936 wake_up_terminal; mp_print(mp, (A));
1939 } while (0) /* prints a string and gets a line of input */
1942 void mp_term_input (MP mp) { /* gets a line from the terminal */
1943 size_t k; /* index into |buffer| */
1944 update_terminal; /* Now the user sees the prompt for sure */
1945 if (!mp_input_ln(mp, mp->term_in )) {
1946 if (!mp->noninteractive) {
1947 mp_fatal_error(mp, "End of file on the terminal!");
1948 @.End of file on the terminal@>
1949 } else { /* we are done with this input chunk */
1950 longjmp(*(mp->jump_buf),1);
1953 if (!mp->noninteractive) {
1954 mp->term_offset=0; /* the user's line ended with \<\rm return> */
1955 decr(mp->selector); /* prepare to echo the input */
1956 if ( mp->last!=mp->first ) {
1957 for (k=mp->first;k<=mp->last-1;k++) {
1958 mp_print_char(mp, mp->buffer[k]);
1962 mp->buffer[mp->last]='%';
1963 incr(mp->selector); /* restore previous status */
1967 @* \[6] Reporting errors.
1968 When something anomalous is detected, \MP\ typically does something like this:
1969 $$\vbox{\halign{#\hfil\cr
1970 |print_err("Something anomalous has been detected");|\cr
1971 |help3("This is the first line of my offer to help.")|\cr
1972 |("This is the second line. I'm trying to")|\cr
1973 |("explain the best way for you to proceed.");|\cr
1975 A two-line help message would be given using |help2|, etc.; these informal
1976 helps should use simple vocabulary that complements the words used in the
1977 official error message that was printed. (Outside the U.S.A., the help
1978 messages should preferably be translated into the local vernacular. Each
1979 line of help is at most 60 characters long, in the present implementation,
1980 so that |max_print_line| will not be exceeded.)
1982 The |print_err| procedure supplies a `\.!' before the official message,
1983 and makes sure that the terminal is awake if a stop is going to occur.
1984 The |error| procedure supplies a `\..' after the official message, then it
1985 shows the location of the error; and if |interaction=error_stop_mode|,
1986 it also enters into a dialog with the user, during which time the help
1987 message may be printed.
1988 @^system dependencies@>
1990 @ The global variable |interaction| has four settings, representing increasing
1991 amounts of user interaction:
1994 enum mp_interaction_mode {
1995 mp_unspecified_mode=0, /* extra value for command-line switch */
1996 mp_batch_mode, /* omits all stops and omits terminal output */
1997 mp_nonstop_mode, /* omits all stops */
1998 mp_scroll_mode, /* omits error stops */
1999 mp_error_stop_mode /* stops at every opportunity to interact */
2002 @ @<Option variables@>=
2003 int interaction; /* current level of interaction */
2004 int noninteractive; /* do we have a terminal? */
2006 @ Set it here so it can be overwritten by the commandline
2008 @<Allocate or initialize ...@>=
2009 mp->interaction=opt->interaction;
2010 if (mp->interaction==mp_unspecified_mode || mp->interaction>mp_error_stop_mode)
2011 mp->interaction=mp_error_stop_mode;
2012 if (mp->interaction<mp_unspecified_mode)
2013 mp->interaction=mp_batch_mode;
2014 mp->noninteractive=opt->noninteractive;
2018 @d print_err(A) mp_print_err(mp,(A))
2021 void mp_print_err(MP mp, const char * A);
2024 void mp_print_err(MP mp, const char * A) {
2025 if ( mp->interaction==mp_error_stop_mode )
2027 mp_print_nl(mp, "! ");
2033 @ \MP\ is careful not to call |error| when the print |selector| setting
2034 might be unusual. The only possible values of |selector| at the time of
2037 \yskip\hang|no_print| (when |interaction=mp_batch_mode|
2038 and |log_file| not yet open);
2040 \hang|term_only| (when |interaction>mp_batch_mode| and |log_file| not yet open);
2042 \hang|log_only| (when |interaction=mp_batch_mode| and |log_file| is open);
2044 \hang|term_and_log| (when |interaction>mp_batch_mode| and |log_file| is open).
2046 @<Initialize the print |selector| based on |interaction|@>=
2047 if ( mp->interaction==mp_batch_mode ) mp->selector=no_print; else mp->selector=term_only
2049 @ A global variable |deletions_allowed| is set |false| if the |get_next|
2050 routine is active when |error| is called; this ensures that |get_next|
2051 will never be called recursively.
2054 The global variable |history| records the worst level of error that
2055 has been detected. It has four possible values: |spotless|, |warning_issued|,
2056 |error_message_issued|, and |fatal_error_stop|.
2058 Another global variable, |error_count|, is increased by one when an
2059 |error| occurs without an interactive dialog, and it is reset to zero at
2060 the end of every statement. If |error_count| reaches 100, \MP\ decides
2061 that there is no point in continuing further.
2064 enum mp_history_states {
2065 mp_spotless=0, /* |history| value when nothing has been amiss yet */
2066 mp_warning_issued, /* |history| value when |begin_diagnostic| has been called */
2067 mp_error_message_issued, /* |history| value when |error| has been called */
2068 mp_fatal_error_stop, /* |history| value when termination was premature */
2069 mp_system_error_stop /* |history| value when termination was due to disaster */
2073 boolean deletions_allowed; /* is it safe for |error| to call |get_next|? */
2074 int history; /* has the source input been clean so far? */
2075 int error_count; /* the number of scrolled errors since the last statement ended */
2077 @ The value of |history| is initially |fatal_error_stop|, but it will
2078 be changed to |spotless| if \MP\ survives the initialization process.
2080 @<Allocate or ...@>=
2081 mp->deletions_allowed=true; mp->error_count=0; /* |history| is initialized elsewhere */
2083 @ Since errors can be detected almost anywhere in \MP, we want to declare the
2084 error procedures near the beginning of the program. But the error procedures
2085 in turn use some other procedures, which need to be declared |forward|
2086 before we get to |error| itself.
2088 It is possible for |error| to be called recursively if some error arises
2089 when |get_next| is being used to delete a token, and/or if some fatal error
2090 occurs while \MP\ is trying to fix a non-fatal one. But such recursion
2092 is never more than two levels deep.
2095 void mp_get_next (MP mp);
2096 void mp_term_input (MP mp);
2097 void mp_show_context (MP mp);
2098 void mp_begin_file_reading (MP mp);
2099 void mp_open_log_file (MP mp);
2100 void mp_clear_for_error_prompt (MP mp);
2101 @<Declare the procedure called |flush_string|@>
2104 void mp_normalize_selector (MP mp);
2106 @ Individual lines of help are recorded in the array |help_line|, which
2107 contains entries in positions |0..(help_ptr-1)|. They should be printed
2108 in reverse order, i.e., with |help_line[0]| appearing last.
2110 @d hlp1(A) mp->help_line[0]=(A); }
2111 @d hlp2(A) mp->help_line[1]=(A); hlp1
2112 @d hlp3(A) mp->help_line[2]=(A); hlp2
2113 @d hlp4(A) mp->help_line[3]=(A); hlp3
2114 @d hlp5(A) mp->help_line[4]=(A); hlp4
2115 @d hlp6(A) mp->help_line[5]=(A); hlp5
2116 @d help0 mp->help_ptr=0 /* sometimes there might be no help */
2117 @d help1 { mp->help_ptr=1; hlp1 /* use this with one help line */
2118 @d help2 { mp->help_ptr=2; hlp2 /* use this with two help lines */
2119 @d help3 { mp->help_ptr=3; hlp3 /* use this with three help lines */
2120 @d help4 { mp->help_ptr=4; hlp4 /* use this with four help lines */
2121 @d help5 { mp->help_ptr=5; hlp5 /* use this with five help lines */
2122 @d help6 { mp->help_ptr=6; hlp6 /* use this with six help lines */
2125 const char * help_line[6]; /* helps for the next |error| */
2126 unsigned int help_ptr; /* the number of help lines present */
2127 boolean use_err_help; /* should the |err_help| string be shown? */
2128 str_number err_help; /* a string set up by \&{errhelp} */
2129 str_number filename_template; /* a string set up by \&{filenametemplate} */
2131 @ @<Allocate or ...@>=
2132 mp->help_ptr=0; mp->use_err_help=false; mp->err_help=0; mp->filename_template=0;
2134 @ The |jump_out| procedure just cuts across all active procedure levels and
2135 goes to |end_of_MP|. This is the only nonlocal |goto| statement in the
2136 whole program. It is used when there is no recovery from a particular error.
2138 The program uses a |jump_buf| to handle this, this is initialized at three
2139 spots: the start of |mp_new|, the start of |mp_initialize|, and the start
2140 of |mp_run|. Those are the only library enty points.
2142 @^system dependencies@>
2147 @ @<Install and test the non-local jump buffer@>=
2148 mp->jump_buf = &buf;
2149 if (setjmp(*(mp->jump_buf)) != 0) { return mp->history; }
2151 @ @<Setup the non-local jump buffer in |mp_new|@>=
2152 if (setjmp(buf) != 0) { return NULL; }
2155 @ If the array of internals is still |NULL| when |jump_out| is called, a
2156 crash occured during initialization, and it is not safe to run the normal
2160 void mp_jump_out (MP mp) {
2161 if (mp->internal!=NULL && mp->history < mp_system_error_stop)
2162 mp_close_files_and_terminate(mp);
2163 longjmp(*(mp->jump_buf),1);
2166 @ Here now is the general |error| routine.
2169 void mp_error (MP mp) { /* completes the job of error reporting */
2170 ASCII_code c; /* what the user types */
2171 integer s1,s2,s3; /* used to save global variables when deleting tokens */
2172 pool_pointer j; /* character position being printed */
2173 if ( mp->history<mp_error_message_issued )
2174 mp->history=mp_error_message_issued;
2175 mp_print_char(mp, '.'); mp_show_context(mp);
2176 if ((!mp->noninteractive) && (mp->interaction==mp_error_stop_mode )) {
2177 @<Get user's advice and |return|@>;
2179 incr(mp->error_count);
2180 if ( mp->error_count==100 ) {
2181 mp_print_nl(mp,"(That makes 100 errors; please try again.)");
2182 @.That makes 100 errors...@>
2183 mp->history=mp_fatal_error_stop; mp_jump_out(mp);
2185 @<Put help message on the transcript file@>;
2187 void mp_warn (MP mp, const char *msg) {
2188 int saved_selector = mp->selector;
2189 mp_normalize_selector(mp);
2190 mp_print_nl(mp,"Warning: ");
2193 mp->selector = saved_selector;
2196 @ @<Exported function ...@>=
2197 void mp_error (MP mp);
2198 void mp_warn (MP mp, const char *msg);
2201 @ @<Get user's advice...@>=
2204 mp_clear_for_error_prompt(mp); prompt_input("? ");
2206 if ( mp->last==mp->first ) return;
2207 c=mp->buffer[mp->first];
2208 if ( c>='a' ) c=c+'A'-'a'; /* convert to uppercase */
2209 @<Interpret code |c| and |return| if done@>;
2212 @ It is desirable to provide an `\.E' option here that gives the user
2213 an easy way to return from \MP\ to the system editor, with the offending
2214 line ready to be edited. But such an extension requires some system
2215 wizardry, so the present implementation simply types out the name of the
2217 edited and the relevant line number.
2218 @^system dependencies@>
2221 typedef void (*mp_run_editor_command)(MP, char *, int);
2223 @ @<Option variables@>=
2224 mp_run_editor_command run_editor;
2226 @ @<Allocate or initialize ...@>=
2227 set_callback_option(run_editor);
2230 void mp_run_editor (MP mp, char *fname, int fline);
2232 @ @c void mp_run_editor (MP mp, char *fname, int fline) {
2233 mp_print_nl(mp, "You want to edit file ");
2234 @.You want to edit file x@>
2235 mp_print(mp, fname);
2236 mp_print(mp, " at line ");
2237 mp_print_int(mp, fline);
2238 mp->interaction=mp_scroll_mode;
2243 There is a secret `\.D' option available when the debugging routines haven't
2247 @<Interpret code |c| and |return| if done@>=
2249 case '0': case '1': case '2': case '3': case '4':
2250 case '5': case '6': case '7': case '8': case '9':
2251 if ( mp->deletions_allowed ) {
2252 @<Delete |c-"0"| tokens and |continue|@>;
2256 if ( mp->file_ptr>0 ){
2257 (mp->run_editor)(mp,
2258 str(mp->input_stack[mp->file_ptr].name_field),
2263 @<Print the help information and |continue|@>;
2266 @<Introduce new material from the terminal and |return|@>;
2268 case 'Q': case 'R': case 'S':
2269 @<Change the interaction level and |return|@>;
2272 mp->interaction=mp_scroll_mode; mp_jump_out(mp);
2277 @<Print the menu of available options@>
2279 @ @<Print the menu...@>=
2281 mp_print(mp, "Type <return> to proceed, S to scroll future error messages,");
2282 @.Type <return> to proceed...@>
2283 mp_print_nl(mp, "R to run without stopping, Q to run quietly,");
2284 mp_print_nl(mp, "I to insert something, ");
2285 if ( mp->file_ptr>0 )
2286 mp_print(mp, "E to edit your file,");
2287 if ( mp->deletions_allowed )
2288 mp_print_nl(mp, "1 or ... or 9 to ignore the next 1 to 9 tokens of input,");
2289 mp_print_nl(mp, "H for help, X to quit.");
2292 @ Here the author of \MP\ apologizes for making use of the numerical
2293 relation between |"Q"|, |"R"|, |"S"|, and the desired interaction settings
2294 |mp_batch_mode|, |mp_nonstop_mode|, |mp_scroll_mode|.
2295 @^Knuth, Donald Ervin@>
2297 @<Change the interaction...@>=
2299 mp->error_count=0; mp->interaction=mp_batch_mode+c-'Q';
2300 mp_print(mp, "OK, entering ");
2302 case 'Q': mp_print(mp, "batchmode"); decr(mp->selector); break;
2303 case 'R': mp_print(mp, "nonstopmode"); break;
2304 case 'S': mp_print(mp, "scrollmode"); break;
2305 } /* there are no other cases */
2306 mp_print(mp, "..."); mp_print_ln(mp); update_terminal; return;
2309 @ When the following code is executed, |buffer[(first+1)..(last-1)]| may
2310 contain the material inserted by the user; otherwise another prompt will
2311 be given. In order to understand this part of the program fully, you need
2312 to be familiar with \MP's input stacks.
2314 @<Introduce new material...@>=
2316 mp_begin_file_reading(mp); /* enter a new syntactic level for terminal input */
2317 if ( mp->last>mp->first+1 ) {
2318 loc=mp->first+1; mp->buffer[mp->first]=' ';
2320 prompt_input("insert>"); loc=mp->first;
2323 mp->first=mp->last+1; mp->cur_input.limit_field=mp->last; return;
2326 @ We allow deletion of up to 99 tokens at a time.
2328 @<Delete |c-"0"| tokens...@>=
2330 s1=mp->cur_cmd; s2=mp->cur_mod; s3=mp->cur_sym; mp->OK_to_interrupt=false;
2331 if ( (mp->last>mp->first+1) && (mp->buffer[mp->first+1]>='0')&&(mp->buffer[mp->first+1]<='9') )
2332 c=c*10+mp->buffer[mp->first+1]-'0'*11;
2336 mp_get_next(mp); /* one-level recursive call of |error| is possible */
2337 @<Decrease the string reference count, if the current token is a string@>;
2340 mp->cur_cmd=s1; mp->cur_mod=s2; mp->cur_sym=s3; mp->OK_to_interrupt=true;
2341 help2("I have just deleted some text, as you asked.")
2342 ("You can now delete more, or insert, or whatever.");
2343 mp_show_context(mp);
2347 @ @<Print the help info...@>=
2349 if ( mp->use_err_help ) {
2350 @<Print the string |err_help|, possibly on several lines@>;
2351 mp->use_err_help=false;
2353 if ( mp->help_ptr==0 ) {
2354 help2("Sorry, I don't know how to help in this situation.")
2355 ("Maybe you should try asking a human?");
2358 decr(mp->help_ptr); mp_print(mp, mp->help_line[mp->help_ptr]); mp_print_ln(mp);
2359 } while (mp->help_ptr!=0);
2361 help4("Sorry, I already gave what help I could...")
2362 ("Maybe you should try asking a human?")
2363 ("An error might have occurred before I noticed any problems.")
2364 ("``If all else fails, read the instructions.''");
2368 @ @<Print the string |err_help|, possibly on several lines@>=
2369 j=mp->str_start[mp->err_help];
2370 while ( j<str_stop(mp->err_help) ) {
2371 if ( mp->str_pool[j]!='%' ) mp_print_str(mp, mp->str_pool[j]);
2372 else if ( j+1==str_stop(mp->err_help) ) mp_print_ln(mp);
2373 else if ( mp->str_pool[j+1]!='%' ) mp_print_ln(mp);
2374 else { incr(j); mp_print_char(mp, '%'); };
2378 @ @<Put help message on the transcript file@>=
2379 if ( mp->interaction>mp_batch_mode ) decr(mp->selector); /* avoid terminal output */
2380 if ( mp->use_err_help ) {
2381 mp_print_nl(mp, "");
2382 @<Print the string |err_help|, possibly on several lines@>;
2384 while ( mp->help_ptr>0 ){
2385 decr(mp->help_ptr); mp_print_nl(mp, mp->help_line[mp->help_ptr]);
2389 if ( mp->interaction>mp_batch_mode ) incr(mp->selector); /* re-enable terminal output */
2392 @ In anomalous cases, the print selector might be in an unknown state;
2393 the following subroutine is called to fix things just enough to keep
2394 running a bit longer.
2397 void mp_normalize_selector (MP mp) {
2398 if ( mp->log_opened ) mp->selector=term_and_log;
2399 else mp->selector=term_only;
2400 if ( mp->job_name==NULL) mp_open_log_file(mp);
2401 if ( mp->interaction==mp_batch_mode ) decr(mp->selector);
2404 @ The following procedure prints \MP's last words before dying.
2406 @d succumb { if ( mp->interaction==mp_error_stop_mode )
2407 mp->interaction=mp_scroll_mode; /* no more interaction */
2408 if ( mp->log_opened ) mp_error(mp);
2409 mp->history=mp_fatal_error_stop; mp_jump_out(mp); /* irrecoverable error */
2413 void mp_fatal_error (MP mp, const char *s) { /* prints |s|, and that's it */
2414 mp_normalize_selector(mp);
2415 print_err("Emergency stop"); help1(s); succumb;
2419 @ @<Exported function ...@>=
2420 void mp_fatal_error (MP mp, const char *s);
2423 @ Here is the most dreaded error message.
2426 void mp_overflow (MP mp, const char *s, integer n) { /* stop due to finiteness */
2427 mp_normalize_selector(mp);
2428 print_err("MetaPost capacity exceeded, sorry [");
2429 @.MetaPost capacity exceeded ...@>
2430 mp_print(mp, s); mp_print_char(mp, '='); mp_print_int(mp, n); mp_print_char(mp, ']');
2431 help2("If you really absolutely need more capacity,")
2432 ("you can ask a wizard to enlarge me.");
2436 @ @<Internal library declarations@>=
2437 void mp_overflow (MP mp, const char *s, integer n);
2439 @ The program might sometime run completely amok, at which point there is
2440 no choice but to stop. If no previous error has been detected, that's bad
2441 news; a message is printed that is really intended for the \MP\
2442 maintenance person instead of the user (unless the user has been
2443 particularly diabolical). The index entries for `this can't happen' may
2444 help to pinpoint the problem.
2447 @<Internal library ...@>=
2448 void mp_confusion (MP mp, const char *s);
2450 @ @<Error hand...@>=
2451 void mp_confusion (MP mp, const char *s) {
2452 /* consistency check violated; |s| tells where */
2453 mp_normalize_selector(mp);
2454 if ( mp->history<mp_error_message_issued ) {
2455 print_err("This can't happen ("); mp_print(mp, s); mp_print_char(mp, ')');
2456 @.This can't happen@>
2457 help1("I'm broken. Please show this to someone who can fix can fix");
2459 print_err("I can\'t go on meeting you like this");
2460 @.I can't go on...@>
2461 help2("One of your faux pas seems to have wounded me deeply...")
2462 ("in fact, I'm barely conscious. Please fix it and try again.");
2467 @ Users occasionally want to interrupt \MP\ while it's running.
2468 If the runtime system allows this, one can implement
2469 a routine that sets the global variable |interrupt| to some nonzero value
2470 when such an interrupt is signaled. Otherwise there is probably at least
2471 a way to make |interrupt| nonzero using the C debugger.
2472 @^system dependencies@>
2475 @d check_interrupt { if ( mp->interrupt!=0 )
2476 mp_pause_for_instructions(mp); }
2479 integer interrupt; /* should \MP\ pause for instructions? */
2480 boolean OK_to_interrupt; /* should interrupts be observed? */
2481 integer run_state; /* are we processing input ?*/
2483 @ @<Allocate or ...@>=
2484 mp->interrupt=0; mp->OK_to_interrupt=true; mp->run_state=0;
2486 @ When an interrupt has been detected, the program goes into its
2487 highest interaction level and lets the user have the full flexibility of
2488 the |error| routine. \MP\ checks for interrupts only at times when it is
2492 void mp_pause_for_instructions (MP mp) {
2493 if ( mp->OK_to_interrupt ) {
2494 mp->interaction=mp_error_stop_mode;
2495 if ( (mp->selector==log_only)||(mp->selector==no_print) )
2497 print_err("Interruption");
2500 ("Try to insert some instructions for me (e.g.,`I show x'),")
2501 ("unless you just want to quit by typing `X'.");
2502 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
2507 @ Many of \MP's error messages state that a missing token has been
2508 inserted behind the scenes. We can save string space and program space
2509 by putting this common code into a subroutine.
2512 void mp_missing_err (MP mp, const char *s) {
2513 print_err("Missing `"); mp_print(mp, s); mp_print(mp, "' has been inserted");
2514 @.Missing...inserted@>
2517 @* \[7] Arithmetic with scaled numbers.
2518 The principal computations performed by \MP\ are done entirely in terms of
2519 integers less than $2^{31}$ in magnitude; thus, the arithmetic specified in this
2520 program can be carried out in exactly the same way on a wide variety of
2521 computers, including some small ones.
2524 But C does not rigidly define the |/| operation in the case of negative
2525 dividends; for example, the result of |(-2*n-1) / 2| is |-(n+1)| on some
2526 computers and |-n| on others (is this true ?). There are two principal
2527 types of arithmetic: ``translation-preserving,'' in which the identity
2528 |(a+q*b)/b=(a/b)+q| is valid; and ``negation-preserving,'' in which
2529 |(-a)/b=-(a/b)|. This leads to two \MP s, which can produce
2530 different results, although the differences should be negligible when the
2531 language is being used properly. The \TeX\ processor has been defined
2532 carefully so that both varieties of arithmetic will produce identical
2533 output, but it would be too inefficient to constrain \MP\ in a similar way.
2535 @d el_gordo 017777777777 /* $2^{31}-1$, the largest value that \MP\ likes */
2537 @ One of \MP's most common operations is the calculation of
2538 $\lfloor{a+b\over2}\rfloor$,
2539 the midpoint of two given integers |a| and~|b|. The most decent way to do
2540 this is to write `|(a+b)/2|'; but on many machines it is more efficient
2541 to calculate `|(a+b)>>1|'.
2543 Therefore the midpoint operation will always be denoted by `|half(a+b)|'
2544 in this program. If \MP\ is being implemented with languages that permit
2545 binary shifting, the |half| macro should be changed to make this operation
2546 as efficient as possible. Since some systems have shift operators that can
2547 only be trusted to work on positive numbers, there is also a macro |halfp|
2548 that is used only when the quantity being halved is known to be positive
2551 @d half(A) ((A) / 2)
2552 @d halfp(A) ((A) >> 1)
2554 @ A single computation might use several subroutine calls, and it is
2555 desirable to avoid producing multiple error messages in case of arithmetic
2556 overflow. So the routines below set the global variable |arith_error| to |true|
2557 instead of reporting errors directly to the user.
2558 @^overflow in arithmetic@>
2561 boolean arith_error; /* has arithmetic overflow occurred recently? */
2563 @ @<Allocate or ...@>=
2564 mp->arith_error=false;
2566 @ At crucial points the program will say |check_arith|, to test if
2567 an arithmetic error has been detected.
2569 @d check_arith { if ( mp->arith_error ) mp_clear_arith(mp); }
2572 void mp_clear_arith (MP mp) {
2573 print_err("Arithmetic overflow");
2574 @.Arithmetic overflow@>
2575 help4("Uh, oh. A little while ago one of the quantities that I was")
2576 ("computing got too large, so I'm afraid your answers will be")
2577 ("somewhat askew. You'll probably have to adopt different")
2578 ("tactics next time. But I shall try to carry on anyway.");
2580 mp->arith_error=false;
2583 @ Addition is not always checked to make sure that it doesn't overflow,
2584 but in places where overflow isn't too unlikely the |slow_add| routine
2587 @c integer mp_slow_add (MP mp,integer x, integer y) {
2589 if ( y<=el_gordo-x ) {
2592 mp->arith_error=true;
2595 } else if ( -y<=el_gordo+x ) {
2598 mp->arith_error=true;
2603 @ Fixed-point arithmetic is done on {\sl scaled integers\/} that are multiples
2604 of $2^{-16}$. In other words, a binary point is assumed to be sixteen bit
2605 positions from the right end of a binary computer word.
2607 @d quarter_unit 040000 /* $2^{14}$, represents 0.250000 */
2608 @d half_unit 0100000 /* $2^{15}$, represents 0.50000 */
2609 @d three_quarter_unit 0140000 /* $3\cdot2^{14}$, represents 0.75000 */
2610 @d unity 0200000 /* $2^{16}$, represents 1.00000 */
2611 @d two 0400000 /* $2^{17}$, represents 2.00000 */
2612 @d three 0600000 /* $2^{17}+2^{16}$, represents 3.00000 */
2615 typedef integer scaled; /* this type is used for scaled integers */
2616 typedef unsigned char small_number; /* this type is self-explanatory */
2618 @ The following function is used to create a scaled integer from a given decimal
2619 fraction $(.d_0d_1\ldots d_{k-1})$, where |0<=k<=17|. The digit $d_i$ is
2620 given in |dig[i]|, and the calculation produces a correctly rounded result.
2623 scaled mp_round_decimals (MP mp,small_number k) {
2624 /* converts a decimal fraction */
2625 integer a = 0; /* the accumulator */
2627 a=(a+mp->dig[k]*two) / 10;
2632 @ Conversely, here is a procedure analogous to |print_int|. If the output
2633 of this procedure is subsequently read by \MP\ and converted by the
2634 |round_decimals| routine above, it turns out that the original value will
2635 be reproduced exactly. A decimal point is printed only if the value is
2636 not an integer. If there is more than one way to print the result with
2637 the optimum number of digits following the decimal point, the closest
2638 possible value is given.
2640 The invariant relation in the \&{repeat} loop is that a sequence of
2641 decimal digits yet to be printed will yield the original number if and only if
2642 they form a fraction~$f$ in the range $s-\delta\L10\cdot2^{16}f<s$.
2643 We can stop if and only if $f=0$ satisfies this condition; the loop will
2644 terminate before $s$ can possibly become zero.
2646 @<Basic printing...@>=
2647 void mp_print_scaled (MP mp,scaled s) { /* prints scaled real, rounded to five digits */
2648 scaled delta; /* amount of allowable inaccuracy */
2650 mp_print_char(mp, '-');
2651 negate(s); /* print the sign, if negative */
2653 mp_print_int(mp, s / unity); /* print the integer part */
2657 mp_print_char(mp, '.');
2660 s=s+0100000-(delta / 2); /* round the final digit */
2661 mp_print_char(mp, '0'+(s / unity));
2668 @ We often want to print two scaled quantities in parentheses,
2669 separated by a comma.
2671 @<Basic printing...@>=
2672 void mp_print_two (MP mp,scaled x, scaled y) { /* prints `|(x,y)|' */
2673 mp_print_char(mp, '(');
2674 mp_print_scaled(mp, x);
2675 mp_print_char(mp, ',');
2676 mp_print_scaled(mp, y);
2677 mp_print_char(mp, ')');
2680 @ The |scaled| quantities in \MP\ programs are generally supposed to be
2681 less than $2^{12}$ in absolute value, so \MP\ does much of its internal
2682 arithmetic with 28~significant bits of precision. A |fraction| denotes
2683 a scaled integer whose binary point is assumed to be 28 bit positions
2686 @d fraction_half 01000000000 /* $2^{27}$, represents 0.50000000 */
2687 @d fraction_one 02000000000 /* $2^{28}$, represents 1.00000000 */
2688 @d fraction_two 04000000000 /* $2^{29}$, represents 2.00000000 */
2689 @d fraction_three 06000000000 /* $3\cdot2^{28}$, represents 3.00000000 */
2690 @d fraction_four 010000000000 /* $2^{30}$, represents 4.00000000 */
2693 typedef integer fraction; /* this type is used for scaled fractions */
2695 @ In fact, the two sorts of scaling discussed above aren't quite
2696 sufficient; \MP\ has yet another, used internally to keep track of angles
2697 in units of $2^{-20}$ degrees.
2699 @d forty_five_deg 0264000000 /* $45\cdot2^{20}$, represents $45^\circ$ */
2700 @d ninety_deg 0550000000 /* $90\cdot2^{20}$, represents $90^\circ$ */
2701 @d one_eighty_deg 01320000000 /* $180\cdot2^{20}$, represents $180^\circ$ */
2702 @d three_sixty_deg 02640000000 /* $360\cdot2^{20}$, represents $360^\circ$ */
2705 typedef integer angle; /* this type is used for scaled angles */
2707 @ The |make_fraction| routine produces the |fraction| equivalent of
2708 |p/q|, given integers |p| and~|q|; it computes the integer
2709 $f=\lfloor2^{28}p/q+{1\over2}\rfloor$, when $p$ and $q$ are
2710 positive. If |p| and |q| are both of the same scaled type |t|,
2711 the ``type relation'' |make_fraction(t,t)=fraction| is valid;
2712 and it's also possible to use the subroutine ``backwards,'' using
2713 the relation |make_fraction(t,fraction)=t| between scaled types.
2715 If the result would have magnitude $2^{31}$ or more, |make_fraction|
2716 sets |arith_error:=true|. Most of \MP's internal computations have
2717 been designed to avoid this sort of error.
2719 If this subroutine were programmed in assembly language on a typical
2720 machine, we could simply compute |(@t$2^{28}$@>*p)div q|, since a
2721 double-precision product can often be input to a fixed-point division
2722 instruction. But when we are restricted to int-eger arithmetic it
2723 is necessary either to resort to multiple-precision maneuvering
2724 or to use a simple but slow iteration. The multiple-precision technique
2725 would be about three times faster than the code adopted here, but it
2726 would be comparatively long and tricky, involving about sixteen
2727 additional multiplications and divisions.
2729 This operation is part of \MP's ``inner loop''; indeed, it will
2730 consume nearly 10\pct! of the running time (exclusive of input and output)
2731 if the code below is left unchanged. A machine-dependent recoding
2732 will therefore make \MP\ run faster. The present implementation
2733 is highly portable, but slow; it avoids multiplication and division
2734 except in the initial stage. System wizards should be careful to
2735 replace it with a routine that is guaranteed to produce identical
2736 results in all cases.
2737 @^system dependencies@>
2739 As noted below, a few more routines should also be replaced by machine-dependent
2740 code, for efficiency. But when a procedure is not part of the ``inner loop,''
2741 such changes aren't advisable; simplicity and robustness are
2742 preferable to trickery, unless the cost is too high.
2746 fraction mp_make_fraction (MP mp,integer p, integer q);
2747 integer mp_take_scaled (MP mp,integer q, scaled f) ;
2749 @ If FIXPT is not defined, we need these preprocessor values
2751 @d ELGORDO 0x7fffffff
2752 @d TWEXP31 2147483648.0
2753 @d TWEXP28 268435456.0
2755 @d TWEXP_16 (1.0/65536.0)
2756 @d TWEXP_28 (1.0/268435456.0)
2760 fraction mp_make_fraction (MP mp,integer p, integer q) {
2762 integer f; /* the fraction bits, with a leading 1 bit */
2763 integer n; /* the integer part of $\vert p/q\vert$ */
2764 integer be_careful; /* disables certain compiler optimizations */
2765 boolean negative = false; /* should the result be negated? */
2767 negate(p); negative=true;
2771 if ( q==0 ) mp_confusion(mp, '/');
2773 @:this can't happen /}{\quad \./@>
2774 negate(q); negative = ! negative;
2778 mp->arith_error=true;
2779 return ( negative ? -el_gordo : el_gordo);
2781 n=(n-1)*fraction_one;
2782 @<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>;
2783 return (negative ? (-(f+n)) : (f+n));
2789 if (q==0) mp_confusion(mp,'/');
2791 d = TWEXP28 * (double)p /(double)q;
2794 if (d>=TWEXP31) {mp->arith_error=true; return ELGORDO;}
2796 if (d==i && ( ((q>0 ? -q : q)&077777)
2797 * (((i&037777)<<1)-1) & 04000)!=0) --i;
2800 if (d<= -TWEXP31) {mp->arith_error=true; return -ELGORDO;}
2802 if (d==i && ( ((q>0 ? q : -q)&077777)
2803 * (((i&037777)<<1)+1) & 04000)!=0) ++i;
2809 @ The |repeat| loop here preserves the following invariant relations
2810 between |f|, |p|, and~|q|:
2811 (i)~|0<=p<q|; (ii)~$fq+p=2^k(q+p_0)$, where $k$ is an integer and
2812 $p_0$ is the original value of~$p$.
2814 Notice that the computation specifies
2815 |(p-q)+p| instead of |(p+p)-q|, because the latter could overflow.
2816 Let us hope that optimizing compilers do not miss this point; a
2817 special variable |be_careful| is used to emphasize the necessary
2818 order of computation. Optimizing compilers should keep |be_careful|
2819 in a register, not store it in memory.
2822 @<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>=
2826 be_careful=p-q; p=be_careful+p;
2832 } while (f<fraction_one);
2834 if ( be_careful+p>=0 ) incr(f);
2837 @ The dual of |make_fraction| is |take_fraction|, which multiplies a
2838 given integer~|q| by a fraction~|f|. When the operands are positive, it
2839 computes $p=\lfloor qf/2^{28}+{1\over2}\rfloor$, a symmetric function
2842 This routine is even more ``inner loopy'' than |make_fraction|;
2843 the present implementation consumes almost 20\pct! of \MP's computation
2844 time during typical jobs, so a machine-language substitute is advisable.
2845 @^inner loop@> @^system dependencies@>
2848 integer mp_take_fraction (MP mp,integer q, fraction f) ;
2852 integer mp_take_fraction (MP mp,integer q, fraction f) {
2853 integer p; /* the fraction so far */
2854 boolean negative; /* should the result be negated? */
2855 integer n; /* additional multiple of $q$ */
2856 integer be_careful; /* disables certain compiler optimizations */
2857 @<Reduce to the case that |f>=0| and |q>=0|@>;
2858 if ( f<fraction_one ) {
2861 n=f / fraction_one; f=f % fraction_one;
2862 if ( q<=el_gordo / n ) {
2865 mp->arith_error=true; n=el_gordo;
2869 @<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>;
2870 be_careful=n-el_gordo;
2871 if ( be_careful+p>0 ){
2872 mp->arith_error=true; n=el_gordo-p;
2879 integer mp_take_fraction (MP mp,integer p, fraction q) {
2882 d = (double)p * (double)q * TWEXP_28;
2886 if (d!=TWEXP31 || (((p&077777)*(q&077777))&040000)==0)
2887 mp->arith_error = true;
2891 if (d==i && (((p&077777)*(q&077777))&040000)!=0) --i;
2895 if (d!= -TWEXP31 || ((-(p&077777)*(q&077777))&040000)==0)
2896 mp->arith_error = true;
2900 if (d==i && ((-(p&077777)*(q&077777))&040000)!=0) ++i;
2906 @ @<Reduce to the case that |f>=0| and |q>=0|@>=
2910 negate( f); negative=true;
2913 negate(q); negative=! negative;
2916 @ The invariant relations in this case are (i)~$\lfloor(qf+p)/2^k\rfloor
2917 =\lfloor qf_0/2^{28}+{1\over2}\rfloor$, where $k$ is an integer and
2918 $f_0$ is the original value of~$f$; (ii)~$2^k\L f<2^{k+1}$.
2921 @<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>=
2922 p=fraction_half; /* that's $2^{27}$; the invariants hold now with $k=28$ */
2923 if ( q<fraction_four ) {
2925 if ( odd(f) ) p=halfp(p+q); else p=halfp(p);
2930 if ( odd(f) ) p=p+halfp(q-p); else p=halfp(p);
2936 @ When we want to multiply something by a |scaled| quantity, we use a scheme
2937 analogous to |take_fraction| but with a different scaling.
2938 Given positive operands, |take_scaled|
2939 computes the quantity $p=\lfloor qf/2^{16}+{1\over2}\rfloor$.
2941 Once again it is a good idea to use a machine-language replacement if
2942 possible; otherwise |take_scaled| will use more than 2\pct! of the running time
2943 when the Computer Modern fonts are being generated.
2948 integer mp_take_scaled (MP mp,integer q, scaled f) {
2949 integer p; /* the fraction so far */
2950 boolean negative; /* should the result be negated? */
2951 integer n; /* additional multiple of $q$ */
2952 integer be_careful; /* disables certain compiler optimizations */
2953 @<Reduce to the case that |f>=0| and |q>=0|@>;
2957 n=f / unity; f=f % unity;
2958 if ( q<=el_gordo / n ) {
2961 mp->arith_error=true; n=el_gordo;
2965 @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>;
2966 be_careful=n-el_gordo;
2967 if ( be_careful+p>0 ) {
2968 mp->arith_error=true; n=el_gordo-p;
2970 return ( negative ?(-(n+p)) :(n+p));
2972 integer mp_take_scaled (MP mp,integer p, scaled q) {
2975 d = (double)p * (double)q * TWEXP_16;
2979 if (d!=TWEXP31 || (((p&077777)*(q&077777))&040000)==0)
2980 mp->arith_error = true;
2984 if (d==i && (((p&077777)*(q&077777))&040000)!=0) --i;
2988 if (d!= -TWEXP31 || ((-(p&077777)*(q&077777))&040000)==0)
2989 mp->arith_error = true;
2993 if (d==i && ((-(p&077777)*(q&077777))&040000)!=0) ++i;
2999 @ @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>=
3000 p=half_unit; /* that's $2^{15}$; the invariants hold now with $k=16$ */
3002 if ( q<fraction_four ) {
3004 p = (odd(f) ? halfp(p+q) : halfp(p));
3009 p = (odd(f) ? p+halfp(q-p) : halfp(p));
3014 @ For completeness, there's also |make_scaled|, which computes a
3015 quotient as a |scaled| number instead of as a |fraction|.
3016 In other words, the result is $\lfloor2^{16}p/q+{1\over2}\rfloor$, if the
3017 operands are positive. \ (This procedure is not used especially often,
3018 so it is not part of \MP's inner loop.)
3020 @<Internal library ...@>=
3021 scaled mp_make_scaled (MP mp,integer p, integer q) ;
3024 scaled mp_make_scaled (MP mp,integer p, integer q) {
3026 integer f; /* the fraction bits, with a leading 1 bit */
3027 integer n; /* the integer part of $\vert p/q\vert$ */
3028 boolean negative; /* should the result be negated? */
3029 integer be_careful; /* disables certain compiler optimizations */
3030 if ( p>=0 ) negative=false;
3031 else { negate(p); negative=true; };
3034 if ( q==0 ) mp_confusion(mp, "/");
3035 @:this can't happen /}{\quad \./@>
3037 negate(q); negative=! negative;
3041 mp->arith_error=true;
3042 return (negative ? (-el_gordo) : el_gordo);
3045 @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>;
3046 return ( negative ? (-(f+n)) :(f+n));
3052 if (q==0) mp_confusion(mp,"/");
3054 d = TWEXP16 * (double)p /(double)q;
3057 if (d>=TWEXP31) {mp->arith_error=true; return ELGORDO;}
3059 if (d==i && ( ((q>0 ? -q : q)&077777)
3060 * (((i&037777)<<1)-1) & 04000)!=0) --i;
3063 if (d<= -TWEXP31) {mp->arith_error=true; return -ELGORDO;}
3065 if (d==i && ( ((q>0 ? q : -q)&077777)
3066 * (((i&037777)<<1)+1) & 04000)!=0) ++i;
3072 @ @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>=
3075 be_careful=p-q; p=be_careful+p;
3076 if ( p>=0 ) f=f+f+1;
3077 else { f+=f; p=p+q; };
3080 if ( be_careful+p>=0 ) incr(f)
3082 @ Here is a typical example of how the routines above can be used.
3083 It computes the function
3084 $${1\over3\tau}f(\theta,\phi)=
3085 {\tau^{-1}\bigl(2+\sqrt2\,(\sin\theta-{1\over16}\sin\phi)
3086 (\sin\phi-{1\over16}\sin\theta)(\cos\theta-\cos\phi)\bigr)\over
3087 3\,\bigl(1+{1\over2}(\sqrt5-1)\cos\theta+{1\over2}(3-\sqrt5\,)\cos\phi\bigr)},$$
3088 where $\tau$ is a |scaled| ``tension'' parameter. This is \MP's magic
3089 fudge factor for placing the first control point of a curve that starts
3090 at an angle $\theta$ and ends at an angle $\phi$ from the straight path.
3091 (Actually, if the stated quantity exceeds 4, \MP\ reduces it to~4.)
3093 The trigonometric quantity to be multiplied by $\sqrt2$ is less than $\sqrt2$.
3094 (It's a sum of eight terms whose absolute values can be bounded using
3095 relations such as $\sin\theta\cos\theta\L{1\over2}$.) Thus the numerator
3096 is positive; and since the tension $\tau$ is constrained to be at least
3097 $3\over4$, the numerator is less than $16\over3$. The denominator is
3098 nonnegative and at most~6. Hence the fixed-point calculations below
3099 are guaranteed to stay within the bounds of a 32-bit computer word.
3101 The angles $\theta$ and $\phi$ are given implicitly in terms of |fraction|
3102 arguments |st|, |ct|, |sf|, and |cf|, representing $\sin\theta$, $\cos\theta$,
3103 $\sin\phi$, and $\cos\phi$, respectively.
3106 fraction mp_velocity (MP mp,fraction st, fraction ct, fraction sf,
3107 fraction cf, scaled t) {
3108 integer acc,num,denom; /* registers for intermediate calculations */
3109 acc=mp_take_fraction(mp, st-(sf / 16), sf-(st / 16));
3110 acc=mp_take_fraction(mp, acc,ct-cf);
3111 num=fraction_two+mp_take_fraction(mp, acc,379625062);
3112 /* $2^{28}\sqrt2\approx379625062.497$ */
3113 denom=fraction_three+mp_take_fraction(mp, ct,497706707)+mp_take_fraction(mp, cf,307599661);
3114 /* $3\cdot2^{27}\cdot(\sqrt5-1)\approx497706706.78$ and
3115 $3\cdot2^{27}\cdot(3-\sqrt5\,)\approx307599661.22$ */
3116 if ( t!=unity ) num=mp_make_scaled(mp, num,t);
3117 /* |make_scaled(fraction,scaled)=fraction| */
3118 if ( num / 4>=denom )
3119 return fraction_four;
3121 return mp_make_fraction(mp, num, denom);
3124 @ The following somewhat different subroutine tests rigorously if $ab$ is
3125 greater than, equal to, or less than~$cd$,
3126 given integers $(a,b,c,d)$. In most cases a quick decision is reached.
3127 The result is $+1$, 0, or~$-1$ in the three respective cases.
3129 @d mp_ab_vs_cd(M,A,B,C,D) mp_do_ab_vs_cd(A,B,C,D)
3132 integer mp_do_ab_vs_cd (integer a,integer b, integer c, integer d) {
3133 integer q,r; /* temporary registers */
3134 @<Reduce to the case that |a,c>=0|, |b,d>0|@>;
3136 q = a / d; r = c / b;
3138 return ( q>r ? 1 : -1);
3139 q = a % d; r = c % b;
3142 if ( q==0 ) return -1;
3144 } /* now |a>d>0| and |c>b>0| */
3147 @ @<Reduce to the case that |a...@>=
3148 if ( a<0 ) { negate(a); negate(b); };
3149 if ( c<0 ) { negate(c); negate(d); };
3152 if ( (a==0||b==0)&&(c==0||d==0) ) return 0;
3156 return ( a==0 ? 0 : -1);
3157 q=a; a=c; c=q; q=-b; b=-d; d=q;
3158 } else if ( b<=0 ) {
3159 if ( b<0 ) if ( a>0 ) return -1;
3160 return (c==0 ? 0 : -1);
3163 @ We conclude this set of elementary routines with some simple rounding
3164 and truncation operations.
3166 @<Internal library declarations@>=
3167 #define mp_floor_scaled(M,i) ((i)&(-65536))
3168 #define mp_round_unscaled(M,i) (((i>>15)+1)>>1)
3169 #define mp_round_fraction(M,i) (((i>>11)+1)>>1)
3172 @* \[8] Algebraic and transcendental functions.
3173 \MP\ computes all of the necessary special functions from scratch, without
3174 relying on |real| arithmetic or system subroutines for sines, cosines, etc.
3176 @ To get the square root of a |scaled| number |x|, we want to calculate
3177 $s=\lfloor 2^8\!\sqrt x +{1\over2}\rfloor$. If $x>0$, this is the unique
3178 integer such that $2^{16}x-s\L s^2<2^{16}x+s$. The following subroutine
3179 determines $s$ by an iterative method that maintains the invariant
3180 relations $x=2^{46-2k}x_0\bmod 2^{30}$, $0<y=\lfloor 2^{16-2k}x_0\rfloor
3181 -s^2+s\L q=2s$, where $x_0$ is the initial value of $x$. The value of~$y$
3182 might, however, be zero at the start of the first iteration.
3185 scaled mp_square_rt (MP mp,scaled x) ;
3188 scaled mp_square_rt (MP mp,scaled x) {
3189 small_number k; /* iteration control counter */
3190 integer y,q; /* registers for intermediate calculations */
3192 @<Handle square root of zero or negative argument@>;
3195 while ( x<fraction_two ) { /* i.e., |while x<@t$2^{29}$@>|\unskip */
3198 if ( x<fraction_four ) y=0;
3199 else { x=x-fraction_four; y=1; };
3201 @<Decrease |k| by 1, maintaining the invariant
3202 relations between |x|, |y|, and~|q|@>;
3208 @ @<Handle square root of zero...@>=
3211 print_err("Square root of ");
3212 @.Square root...replaced by 0@>
3213 mp_print_scaled(mp, x); mp_print(mp, " has been replaced by 0");
3214 help2("Since I don't take square roots of negative numbers,")
3215 ("I'm zeroing this one. Proceed, with fingers crossed.");
3221 @ @<Decrease |k| by 1, maintaining...@>=
3223 if ( x>=fraction_four ) { /* note that |fraction_four=@t$2^{30}$@>| */
3224 x=x-fraction_four; incr(y);
3226 x+=x; y=y+y-q; q+=q;
3227 if ( x>=fraction_four ) { x=x-fraction_four; incr(y); };
3228 if ( y>q ){ y=y-q; q=q+2; }
3229 else if ( y<=0 ) { q=q-2; y=y+q; };
3232 @ Pythagorean addition $\psqrt{a^2+b^2}$ is implemented by an elegant
3233 iterative scheme due to Cleve Moler and Donald Morrison [{\sl IBM Journal
3234 @^Moler, Cleve Barry@>
3235 @^Morrison, Donald Ross@>
3236 of Research and Development\/ \bf27} (1983), 577--581]. It modifies |a| and~|b|
3237 in such a way that their Pythagorean sum remains invariant, while the
3238 smaller argument decreases.
3240 @<Internal library ...@>=
3241 integer mp_pyth_add (MP mp,integer a, integer b);
3245 integer mp_pyth_add (MP mp,integer a, integer b) {
3246 fraction r; /* register used to transform |a| and |b| */
3247 boolean big; /* is the result dangerously near $2^{31}$? */
3249 if ( a<b ) { r=b; b=a; a=r; }; /* now |0<=b<=a| */
3251 if ( a<fraction_two ) {
3254 a=a / 4; b=b / 4; big=true;
3255 }; /* we reduced the precision to avoid arithmetic overflow */
3256 @<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>;
3258 if ( a<fraction_two ) {
3261 mp->arith_error=true; a=el_gordo;
3268 @ The key idea here is to reflect the vector $(a,b)$ about the
3269 line through $(a,b/2)$.
3271 @<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>=
3273 r=mp_make_fraction(mp, b,a);
3274 r=mp_take_fraction(mp, r,r); /* now $r\approx b^2/a^2$ */
3276 r=mp_make_fraction(mp, r,fraction_four+r);
3277 a=a+mp_take_fraction(mp, a+a,r); b=mp_take_fraction(mp, b,r);
3281 @ Here is a similar algorithm for $\psqrt{a^2-b^2}$.
3282 It converges slowly when $b$ is near $a$, but otherwise it works fine.
3285 integer mp_pyth_sub (MP mp,integer a, integer b) {
3286 fraction r; /* register used to transform |a| and |b| */
3287 boolean big; /* is the input dangerously near $2^{31}$? */
3290 @<Handle erroneous |pyth_sub| and set |a:=0|@>;
3292 if ( a<fraction_four ) {
3295 a=halfp(a); b=halfp(b); big=true;
3297 @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>;
3298 if ( big ) double(a);
3303 @ @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>=
3305 r=mp_make_fraction(mp, b,a);
3306 r=mp_take_fraction(mp, r,r); /* now $r\approx b^2/a^2$ */
3308 r=mp_make_fraction(mp, r,fraction_four-r);
3309 a=a-mp_take_fraction(mp, a+a,r); b=mp_take_fraction(mp, b,r);
3312 @ @<Handle erroneous |pyth_sub| and set |a:=0|@>=
3315 print_err("Pythagorean subtraction "); mp_print_scaled(mp, a);
3316 mp_print(mp, "+-+"); mp_print_scaled(mp, b);
3317 mp_print(mp, " has been replaced by 0");
3319 help2("Since I don't take square roots of negative numbers,")
3320 ("I'm zeroing this one. Proceed, with fingers crossed.");
3326 @ The subroutines for logarithm and exponential involve two tables.
3327 The first is simple: |two_to_the[k]| equals $2^k$. The second involves
3328 a bit more calculation, which the author claims to have done correctly:
3329 |spec_log[k]| is $2^{27}$ times $\ln\bigl(1/(1-2^{-k})\bigr)=
3330 2^{-k}+{1\over2}2^{-2k}+{1\over3}2^{-3k}+\cdots\,$, rounded to the
3333 @d two_to_the(A) (1<<(A))
3336 static const integer spec_log[29] = { 0, /* special logarithms */
3337 93032640, 38612034, 17922280, 8662214, 4261238, 2113709,
3338 1052693, 525315, 262400, 131136, 65552, 32772, 16385,
3339 8192, 4096, 2048, 1024, 512, 256, 128, 64, 32, 16, 8, 4, 2, 1, 1 };
3341 @ @<Local variables for initialization@>=
3342 integer k; /* all-purpose loop index */
3345 @ Here is the routine that calculates $2^8$ times the natural logarithm
3346 of a |scaled| quantity; it is an integer approximation to $2^{24}\ln(x/2^{16})$,
3347 when |x| is a given positive integer.
3349 The method is based on exercise 1.2.2--25 in {\sl The Art of Computer
3350 Programming\/}: During the main iteration we have $1\L 2^{-30}x<1/(1-2^{1-k})$,
3351 and the logarithm of $2^{30}x$ remains to be added to an accumulator
3352 register called~$y$. Three auxiliary bits of accuracy are retained in~$y$
3353 during the calculation, and sixteen auxiliary bits to extend |y| are
3354 kept in~|z| during the initial argument reduction. (We add
3355 $100\cdot2^{16}=6553600$ to~|z| and subtract 100 from~|y| so that |z| will
3356 not become negative; also, the actual amount subtracted from~|y| is~96,
3357 not~100, because we want to add~4 for rounding before the final division by~8.)
3360 scaled mp_m_log (MP mp,scaled x) {
3361 integer y,z; /* auxiliary registers */
3362 integer k; /* iteration counter */
3364 @<Handle non-positive logarithm@>;
3366 y=1302456956+4-100; /* $14\times2^{27}\ln2\approx1302456956.421063$ */
3367 z=27595+6553600; /* and $2^{16}\times .421063\approx 27595$ */
3368 while ( x<fraction_four ) {
3369 double(x); y-=93032639; z-=48782;
3370 } /* $2^{27}\ln2\approx 93032639.74436163$ and $2^{16}\times.74436163\approx 48782$ */
3371 y=y+(z / unity); k=2;
3372 while ( x>fraction_four+4 ) {
3373 @<Increase |k| until |x| can be multiplied by a
3374 factor of $2^{-k}$, and adjust $y$ accordingly@>;
3380 @ @<Increase |k| until |x| can...@>=
3382 z=((x-1) / two_to_the(k))+1; /* $z=\lceil x/2^k\rceil$ */
3383 while ( x<fraction_four+z ) { z=halfp(z+1); incr(k); };
3384 y+=spec_log[k]; x-=z;
3387 @ @<Handle non-positive logarithm@>=
3389 print_err("Logarithm of ");
3390 @.Logarithm...replaced by 0@>
3391 mp_print_scaled(mp, x); mp_print(mp, " has been replaced by 0");
3392 help2("Since I don't take logs of non-positive numbers,")
3393 ("I'm zeroing this one. Proceed, with fingers crossed.");
3398 @ Conversely, the exponential routine calculates $\exp(x/2^8)$,
3399 when |x| is |scaled|. The result is an integer approximation to
3400 $2^{16}\exp(x/2^{24})$, when |x| is regarded as an integer.
3403 scaled mp_m_exp (MP mp,scaled x) {
3404 small_number k; /* loop control index */
3405 integer y,z; /* auxiliary registers */
3406 if ( x>174436200 ) {
3407 /* $2^{24}\ln((2^{31}-1)/2^{16})\approx 174436199.51$ */
3408 mp->arith_error=true;
3410 } else if ( x<-197694359 ) {
3411 /* $2^{24}\ln(2^{-1}/2^{16})\approx-197694359.45$ */
3415 z=-8*x; y=04000000; /* $y=2^{20}$ */
3417 if ( x<=127919879 ) {
3419 /* $2^{27}\ln((2^{31}-1)/2^{20})\approx 1023359037.125$ */
3421 z=8*(174436200-x); /* |z| is always nonnegative */
3425 @<Multiply |y| by $\exp(-z/2^{27})$@>;
3427 return ((y+8) / 16);
3433 @ The idea here is that subtracting |spec_log[k]| from |z| corresponds
3434 to multiplying |y| by $1-2^{-k}$.
3436 A subtle point (which had to be checked) was that if $x=127919879$, the
3437 value of~|y| will decrease so that |y+8| doesn't overflow. In fact,
3438 $z$ will be 5 in this case, and |y| will decrease by~64 when |k=25|
3439 and by~16 when |k=27|.
3441 @<Multiply |y| by...@>=
3444 while ( z>=spec_log[k] ) {
3446 y=y-1-((y-two_to_the(k-1)) / two_to_the(k));
3451 @ The trigonometric subroutines use an auxiliary table such that
3452 |spec_atan[k]| contains an approximation to the |angle| whose tangent
3453 is~$1/2^k$. $\arctan2^{-k}$ times $2^{20}\cdot180/\pi$
3456 static const angle spec_atan[27] = { 0, 27855475, 14718068, 7471121, 3750058,
3457 1876857, 938658, 469357, 234682, 117342, 58671, 29335, 14668, 7334, 3667,
3458 1833, 917, 458, 229, 115, 57, 29, 14, 7, 4, 2, 1 };
3460 @ Given integers |x| and |y|, not both zero, the |n_arg| function
3461 returns the |angle| whose tangent points in the direction $(x,y)$.
3462 This subroutine first determines the correct octant, then solves the
3463 problem for |0<=y<=x|, then converts the result appropriately to
3464 return an answer in the range |-one_eighty_deg<=@t$\theta$@><=one_eighty_deg|.
3465 (The answer is |+one_eighty_deg| if |y=0| and |x<0|, but an answer of
3466 |-one_eighty_deg| is possible if, for example, |y=-1| and $x=-2^{30}$.)
3468 The octants are represented in a ``Gray code,'' since that turns out
3469 to be computationally simplest.
3475 @d second_octant (first_octant+switch_x_and_y)
3476 @d third_octant (first_octant+switch_x_and_y+negate_x)
3477 @d fourth_octant (first_octant+negate_x)
3478 @d fifth_octant (first_octant+negate_x+negate_y)
3479 @d sixth_octant (first_octant+switch_x_and_y+negate_x+negate_y)
3480 @d seventh_octant (first_octant+switch_x_and_y+negate_y)
3481 @d eighth_octant (first_octant+negate_y)
3484 angle mp_n_arg (MP mp,integer x, integer y) {
3485 angle z; /* auxiliary register */
3486 integer t; /* temporary storage */
3487 small_number k; /* loop counter */
3488 int octant; /* octant code */
3490 octant=first_octant;
3492 negate(x); octant=first_octant+negate_x;
3495 negate(y); octant=octant+negate_y;
3498 t=y; y=x; x=t; octant=octant+switch_x_and_y;
3501 @<Handle undefined arg@>;
3503 @<Set variable |z| to the arg of $(x,y)$@>;
3504 @<Return an appropriate answer based on |z| and |octant|@>;
3508 @ @<Handle undefined arg@>=
3510 print_err("angle(0,0) is taken as zero");
3511 @.angle(0,0)...zero@>
3512 help2("The `angle' between two identical points is undefined.")
3513 ("I'm zeroing this one. Proceed, with fingers crossed.");
3518 @ @<Return an appropriate answer...@>=
3520 case first_octant: return z;
3521 case second_octant: return (ninety_deg-z);
3522 case third_octant: return (ninety_deg+z);
3523 case fourth_octant: return (one_eighty_deg-z);
3524 case fifth_octant: return (z-one_eighty_deg);
3525 case sixth_octant: return (-z-ninety_deg);
3526 case seventh_octant: return (z-ninety_deg);
3527 case eighth_octant: return (-z);
3528 }; /* there are no other cases */
3531 @ At this point we have |x>=y>=0|, and |x>0|. The numbers are scaled up
3532 or down until $2^{28}\L x<2^{29}$, so that accurate fixed-point calculations
3535 @<Set variable |z| to the arg...@>=
3536 while ( x>=fraction_two ) {
3537 x=halfp(x); y=halfp(y);
3541 while ( x<fraction_one ) {
3544 @<Increase |z| to the arg of $(x,y)$@>;
3547 @ During the calculations of this section, variables |x| and~|y|
3548 represent actual coordinates $(x,2^{-k}y)$. We will maintain the
3549 condition |x>=y|, so that the tangent will be at most $2^{-k}$.
3550 If $x<2y$, the tangent is greater than $2^{-k-1}$. The transformation
3551 $(a,b)\mapsto(a+b\tan\phi,b-a\tan\phi)$ replaces $(a,b)$ by
3552 coordinates whose angle has decreased by~$\phi$; in the special case
3553 $a=x$, $b=2^{-k}y$, and $\tan\phi=2^{-k-1}$, this operation reduces
3554 to the particularly simple iteration shown here. [Cf.~John E. Meggitt,
3555 @^Meggitt, John E.@>
3556 {\sl IBM Journal of Research and Development\/ \bf6} (1962), 210--226.]
3558 The initial value of |x| will be multiplied by at most
3559 $(1+{1\over2})(1+{1\over8})(1+{1\over32})\cdots\approx 1.7584$; hence
3560 there is no chance of integer overflow.
3562 @<Increase |z|...@>=
3567 z=z+spec_atan[k]; t=x; x=x+(y / two_to_the(k+k)); y=y-t;
3572 if ( y>x ) { z=z+spec_atan[k]; y=y-x; };
3575 @ Conversely, the |n_sin_cos| routine takes an |angle| and produces the sine
3576 and cosine of that angle. The results of this routine are
3577 stored in global integer variables |n_sin| and |n_cos|.
3580 fraction n_sin;fraction n_cos; /* results computed by |n_sin_cos| */
3582 @ Given an integer |z| that is $2^{20}$ times an angle $\theta$ in degrees,
3583 the purpose of |n_sin_cos(z)| is to set
3584 |x=@t$r\cos\theta$@>| and |y=@t$r\sin\theta$@>| (approximately),
3585 for some rather large number~|r|. The maximum of |x| and |y|
3586 will be between $2^{28}$ and $2^{30}$, so that there will be hardly
3587 any loss of accuracy. Then |x| and~|y| are divided by~|r|.
3590 void mp_n_sin_cos (MP mp,angle z) { /* computes a multiple of the sine
3592 small_number k; /* loop control variable */
3593 int q; /* specifies the quadrant */
3594 fraction r; /* magnitude of |(x,y)| */
3595 integer x,y,t; /* temporary registers */
3596 while ( z<0 ) z=z+three_sixty_deg;
3597 z=z % three_sixty_deg; /* now |0<=z<three_sixty_deg| */
3598 q=z / forty_five_deg; z=z % forty_five_deg;
3599 x=fraction_one; y=x;
3600 if ( ! odd(q) ) z=forty_five_deg-z;
3601 @<Subtract angle |z| from |(x,y)|@>;
3602 @<Convert |(x,y)| to the octant determined by~|q|@>;
3603 r=mp_pyth_add(mp, x,y);
3604 mp->n_cos=mp_make_fraction(mp, x,r);
3605 mp->n_sin=mp_make_fraction(mp, y,r);
3608 @ In this case the octants are numbered sequentially.
3610 @<Convert |(x,...@>=
3613 case 1: t=x; x=y; y=t; break;
3614 case 2: t=x; x=-y; y=t; break;
3615 case 3: negate(x); break;
3616 case 4: negate(x); negate(y); break;
3617 case 5: t=x; x=-y; y=-t; break;
3618 case 6: t=x; x=y; y=-t; break;
3619 case 7: negate(y); break;
3620 } /* there are no other cases */
3622 @ The main iteration of |n_sin_cos| is similar to that of |n_arg| but
3623 applied in reverse. The values of |spec_atan[k]| decrease slowly enough
3624 that this loop is guaranteed to terminate before the (nonexistent) value
3625 |spec_atan[27]| would be required.
3627 @<Subtract angle |z|...@>=
3630 if ( z>=spec_atan[k] ) {
3631 z=z-spec_atan[k]; t=x;
3632 x=t+y / two_to_the(k);
3633 y=y-t / two_to_the(k);
3637 if ( y<0 ) y=0 /* this precaution may never be needed */
3639 @ And now let's complete our collection of numeric utility routines
3640 by considering random number generation.
3641 \MP\ generates pseudo-random numbers with the additive scheme recommended
3642 in Section 3.6 of {\sl The Art of Computer Programming}; however, the
3643 results are random fractions between 0 and |fraction_one-1|, inclusive.
3645 There's an auxiliary array |randoms| that contains 55 pseudo-random
3646 fractions. Using the recurrence $x_n=(x_{n-55}-x_{n-31})\bmod 2^{28}$,
3647 we generate batches of 55 new $x_n$'s at a time by calling |new_randoms|.
3648 The global variable |j_random| tells which element has most recently
3650 The global variable |random_seed| was introduced in version 0.9,
3651 for the sole reason of stressing the fact that the initial value of the
3652 random seed is system-dependant. The initialization code below will initialize
3653 this variable to |(internal[mp_time] div unity)+internal[mp_day]|, but this
3654 is not good enough on modern fast machines that are capable of running
3655 multiple MetaPost processes within the same second.
3656 @^system dependencies@>
3659 fraction randoms[55]; /* the last 55 random values generated */
3660 int j_random; /* the number of unused |randoms| */
3662 @ @<Option variables@>=
3663 int random_seed; /* the default random seed */
3665 @ @<Allocate or initialize ...@>=
3666 mp->random_seed = (scaled)opt->random_seed;
3668 @ To consume a random fraction, the program below will say `|next_random|'
3669 and then it will fetch |randoms[j_random]|.
3671 @d next_random { if ( mp->j_random==0 ) mp_new_randoms(mp);
3672 else decr(mp->j_random); }
3675 void mp_new_randoms (MP mp) {
3676 int k; /* index into |randoms| */
3677 fraction x; /* accumulator */
3678 for (k=0;k<=23;k++) {
3679 x=mp->randoms[k]-mp->randoms[k+31];
3680 if ( x<0 ) x=x+fraction_one;
3683 for (k=24;k<= 54;k++){
3684 x=mp->randoms[k]-mp->randoms[k-24];
3685 if ( x<0 ) x=x+fraction_one;
3692 void mp_init_randoms (MP mp,scaled seed);
3694 @ To initialize the |randoms| table, we call the following routine.
3697 void mp_init_randoms (MP mp,scaled seed) {
3698 fraction j,jj,k; /* more or less random integers */
3699 int i; /* index into |randoms| */
3701 while ( j>=fraction_one ) j=halfp(j);
3703 for (i=0;i<=54;i++ ){
3705 if ( k<0 ) k=k+fraction_one;
3706 mp->randoms[(i*21)% 55]=j;
3710 mp_new_randoms(mp); /* ``warm up'' the array */
3713 @ To produce a uniform random number in the range |0<=u<x| or |0>=u>x|
3714 or |0=u=x|, given a |scaled| value~|x|, we proceed as shown here.
3716 Note that the call of |take_fraction| will produce the values 0 and~|x|
3717 with about half the probability that it will produce any other particular
3718 values between 0 and~|x|, because it rounds its answers.
3721 scaled mp_unif_rand (MP mp,scaled x) {
3722 scaled y; /* trial value */
3723 next_random; y=mp_take_fraction(mp, abs(x),mp->randoms[mp->j_random]);
3724 if ( y==abs(x) ) return 0;
3725 else if ( x>0 ) return y;
3729 @ Finally, a normal deviate with mean zero and unit standard deviation
3730 can readily be obtained with the ratio method (Algorithm 3.4.1R in
3731 {\sl The Art of Computer Programming\/}).
3734 scaled mp_norm_rand (MP mp) {
3735 integer x,u,l; /* what the book would call $2^{16}X$, $2^{28}U$, and $-2^{24}\ln U$ */
3739 x=mp_take_fraction(mp, 112429,mp->randoms[mp->j_random]-fraction_half);
3740 /* $2^{16}\sqrt{8/e}\approx 112428.82793$ */
3741 next_random; u=mp->randoms[mp->j_random];
3742 } while (abs(x)>=u);
3743 x=mp_make_fraction(mp, x,u);
3744 l=139548960-mp_m_log(mp, u); /* $2^{24}\cdot12\ln2\approx139548959.6165$ */
3745 } while (mp_ab_vs_cd(mp, 1024,l,x,x)<0);
3749 @* \[9] Packed data.
3750 In order to make efficient use of storage space, \MP\ bases its major data
3751 structures on a |memory_word|, which contains either a (signed) integer,
3752 possibly scaled, or a small number of fields that are one half or one
3753 quarter of the size used for storing integers.
3755 If |x| is a variable of type |memory_word|, it contains up to four
3756 fields that can be referred to as follows:
3757 $$\vbox{\halign{\hfil#&#\hfil&#\hfil\cr
3758 |x|&.|int|&(an |integer|)\cr
3759 |x|&.|sc|\qquad&(a |scaled| integer)\cr
3760 |x.hh.lh|, |x.hh|&.|rh|&(two halfword fields)\cr
3761 |x.hh.b0|, |x.hh.b1|, |x.hh|&.|rh|&(two quarterword fields, one halfword
3763 |x.qqqq.b0|, |x.qqqq.b1|, |x.qqqq|&.|b2|, |x.qqqq.b3|\hskip-100pt
3764 &\qquad\qquad\qquad(four quarterword fields)\cr}}$$
3765 This is somewhat cumbersome to write, and not very readable either, but
3766 macros will be used to make the notation shorter and more transparent.
3767 The code below gives a formal definition of |memory_word| and
3768 its subsidiary types, using packed variant records. \MP\ makes no
3769 assumptions about the relative positions of the fields within a word.
3771 @d max_quarterword 0x3FFF /* largest allowable value in a |quarterword| */
3772 @d max_halfword 0xFFFFFFF /* largest allowable value in a |halfword| */
3774 @ Here are the inequalities that the quarterword and halfword values
3775 must satisfy (or rather, the inequalities that they mustn't satisfy):
3777 @<Check the ``constant''...@>=
3778 if (mp->ini_version) {
3779 if ( mp->mem_max!=mp->mem_top ) mp->bad=8;
3781 if ( mp->mem_max<mp->mem_top ) mp->bad=8;
3783 if ( mp->mem_max>=max_halfword ) mp->bad=12;
3784 if ( mp->max_strings>max_halfword ) mp->bad=13;
3786 @ The macros |qi| and |qo| are used for input to and output
3787 from quarterwords. These are legacy macros.
3788 @^system dependencies@>
3790 @d qo(A) (A) /* to read eight bits from a quarterword */
3791 @d qi(A) (A) /* to store eight bits in a quarterword */
3793 @ The reader should study the following definitions closely:
3794 @^system dependencies@>
3796 @d sc cint /* |scaled| data is equivalent to |integer| */
3799 typedef short quarterword; /* 1/4 of a word */
3800 typedef int halfword; /* 1/2 of a word */
3805 struct { /* Make B0,B1 overlap the most significant bytes of LH. */
3812 quarterword B2, B3, B0, B1;
3827 @ When debugging, we may want to print a |memory_word| without knowing
3828 what type it is; so we print it in all modes.
3832 void mp_print_word (MP mp,memory_word w) {
3833 /* prints |w| in all ways */
3834 mp_print_int(mp, w.cint); mp_print_char(mp, ' ');
3835 mp_print_scaled(mp, w.sc); mp_print_char(mp, ' ');
3836 mp_print_scaled(mp, w.sc / 010000); mp_print_ln(mp);
3837 mp_print_int(mp, w.hh.lh); mp_print_char(mp, '=');
3838 mp_print_int(mp, w.hh.b0); mp_print_char(mp, ':');
3839 mp_print_int(mp, w.hh.b1); mp_print_char(mp, ';');
3840 mp_print_int(mp, w.hh.rh); mp_print_char(mp, ' ');
3841 mp_print_int(mp, w.qqqq.b0); mp_print_char(mp, ':');
3842 mp_print_int(mp, w.qqqq.b1); mp_print_char(mp, ':');
3843 mp_print_int(mp, w.qqqq.b2); mp_print_char(mp, ':');
3844 mp_print_int(mp, w.qqqq.b3);
3848 @* \[10] Dynamic memory allocation.
3850 The \MP\ system does nearly all of its own memory allocation, so that it
3851 can readily be transported into environments that do not have automatic
3852 facilities for strings, garbage collection, etc., and so that it can be in
3853 control of what error messages the user receives. The dynamic storage
3854 requirements of \MP\ are handled by providing a large array |mem| in
3855 which consecutive blocks of words are used as nodes by the \MP\ routines.
3857 Pointer variables are indices into this array, or into another array
3858 called |eqtb| that will be explained later. A pointer variable might
3859 also be a special flag that lies outside the bounds of |mem|, so we
3860 allow pointers to assume any |halfword| value. The minimum memory
3861 index represents a null pointer.
3863 @d null 0 /* the null pointer */
3864 @d mp_void (null+1) /* a null pointer different from |null| */
3868 typedef halfword pointer; /* a flag or a location in |mem| or |eqtb| */
3870 @ The |mem| array is divided into two regions that are allocated separately,
3871 but the dividing line between these two regions is not fixed; they grow
3872 together until finding their ``natural'' size in a particular job.
3873 Locations less than or equal to |lo_mem_max| are used for storing
3874 variable-length records consisting of two or more words each. This region
3875 is maintained using an algorithm similar to the one described in exercise
3876 2.5--19 of {\sl The Art of Computer Programming}. However, no size field
3877 appears in the allocated nodes; the program is responsible for knowing the
3878 relevant size when a node is freed. Locations greater than or equal to
3879 |hi_mem_min| are used for storing one-word records; a conventional
3880 \.{AVAIL} stack is used for allocation in this region.
3882 Locations of |mem| between |0| and |mem_top| may be dumped as part
3883 of preloaded mem files, by the \.{INIMP} preprocessor.
3885 Production versions of \MP\ may extend the memory at the top end in order to
3886 provide more space; these locations, between |mem_top| and |mem_max|,
3887 are always used for single-word nodes.
3889 The key pointers that govern |mem| allocation have a prescribed order:
3890 $$\hbox{|null=0<lo_mem_max<hi_mem_min<mem_top<=mem_end<=mem_max|.}$$
3893 memory_word *mem; /* the big dynamic storage area */
3894 pointer lo_mem_max; /* the largest location of variable-size memory in use */
3895 pointer hi_mem_min; /* the smallest location of one-word memory in use */
3899 @d xfree(A) do { mp_xfree(A); A=NULL; } while (0)
3900 @d xrealloc(P,A,B) mp_xrealloc(mp,P,A,B)
3901 @d xmalloc(A,B) mp_xmalloc(mp,A,B)
3902 @d xstrdup(A) mp_xstrdup(mp,A)
3903 @d XREALLOC(a,b,c) a = xrealloc(a,(b+1),sizeof(c));
3905 @<Declare helpers@>=
3906 void mp_xfree (void *x);
3907 void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size) ;
3908 void *mp_xmalloc (MP mp, size_t nmem, size_t size) ;
3909 char *mp_xstrdup(MP mp, const char *s);
3910 void mp_do_snprintf(char *str, int size, const char *fmt, ...);
3912 @ The |max_size_test| guards against overflow, on the assumption that
3913 |size_t| is at least 31bits wide.
3915 @d max_size_test 0x7FFFFFFF
3918 void mp_xfree (void *x) {
3919 if (x!=NULL) free(x);
3921 void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size) {
3923 if ((max_size_test/size)<nmem) {
3924 do_fprintf(mp->err_out,"Memory size overflow!\n");
3925 mp->history =mp_fatal_error_stop; mp_jump_out(mp);
3927 w = realloc (p,(nmem*size));
3929 do_fprintf(mp->err_out,"Out of memory!\n");
3930 mp->history =mp_system_error_stop; mp_jump_out(mp);
3934 void *mp_xmalloc (MP mp, size_t nmem, size_t size) {
3936 if ((max_size_test/size)<nmem) {
3937 do_fprintf(mp->err_out,"Memory size overflow!\n");
3938 mp->history =mp_fatal_error_stop; mp_jump_out(mp);
3940 w = malloc (nmem*size);
3942 do_fprintf(mp->err_out,"Out of memory!\n");
3943 mp->history =mp_system_error_stop; mp_jump_out(mp);
3947 char *mp_xstrdup(MP mp, const char *s) {
3953 do_fprintf(mp->err_out,"Out of memory!\n");
3954 mp->history =mp_system_error_stop; mp_jump_out(mp);
3959 @ @<Internal library declarations@>=
3960 #ifdef HAVE_SNPRINTF
3961 #define mp_snprintf (void)snprintf
3963 #define mp_snprintf mp_do_snprintf
3966 @ This internal version is rather stupid, but good enough for its purpose.
3969 void mp_do_snprintf (char *str, int size, const char *format, ...) {
3974 work = (char *)workbuf;
3975 va_start(ap, format);
3977 for (fmt=format;*fmt!='\0';fmt++) {
3983 char *s = va_arg(ap, char *);
3986 if (size-->0) res++;
3993 sprintf(work,"%i",va_arg(ap, int));
3996 if (size-->0) res++;
4002 sprintf(work,"%g",va_arg(ap, double));
4005 if (size-->0) res++;
4011 if (size-->0) res++;
4019 if (size-->0) res++;
4027 @<Allocate or initialize ...@>=
4028 mp->mem = xmalloc ((mp->mem_max+1),sizeof (memory_word));
4029 memset(mp->mem,0,(mp->mem_max+1)*sizeof (memory_word));
4031 @ @<Dealloc variables@>=
4034 @ Users who wish to study the memory requirements of particular applications can
4035 can use optional special features that keep track of current and
4036 maximum memory usage. When code between the delimiters |stat| $\ldots$
4037 |tats| is not ``commented out,'' \MP\ will run a bit slower but it will
4038 report these statistics when |mp_tracing_stats| is positive.
4041 integer var_used; integer dyn_used; /* how much memory is in use */
4043 @ Let's consider the one-word memory region first, since it's the
4044 simplest. The pointer variable |mem_end| holds the highest-numbered location
4045 of |mem| that has ever been used. The free locations of |mem| that
4046 occur between |hi_mem_min| and |mem_end|, inclusive, are of type
4047 |two_halves|, and we write |info(p)| and |link(p)| for the |lh|
4048 and |rh| fields of |mem[p]| when it is of this type. The single-word
4049 free locations form a linked list
4050 $$|avail|,\;\hbox{|link(avail)|},\;\hbox{|link(link(avail))|},\;\ldots$$
4051 terminated by |null|.
4053 @d link(A) mp->mem[(A)].hh.rh /* the |link| field of a memory word */
4054 @d info(A) mp->mem[(A)].hh.lh /* the |info| field of a memory word */
4057 pointer avail; /* head of the list of available one-word nodes */
4058 pointer mem_end; /* the last one-word node used in |mem| */
4060 @ If one-word memory is exhausted, it might mean that the user has forgotten
4061 a token like `\&{enddef}' or `\&{endfor}'. We will define some procedures
4062 later that try to help pinpoint the trouble.
4065 @<Declare the procedure called |show_token_list|@>
4066 @<Declare the procedure called |runaway|@>
4068 @ The function |get_avail| returns a pointer to a new one-word node whose
4069 |link| field is null. However, \MP\ will halt if there is no more room left.
4073 pointer mp_get_avail (MP mp) { /* single-word node allocation */
4074 pointer p; /* the new node being got */
4075 p=mp->avail; /* get top location in the |avail| stack */
4077 mp->avail=link(mp->avail); /* and pop it off */
4078 } else if ( mp->mem_end<mp->mem_max ) { /* or go into virgin territory */
4079 incr(mp->mem_end); p=mp->mem_end;
4081 decr(mp->hi_mem_min); p=mp->hi_mem_min;
4082 if ( mp->hi_mem_min<=mp->lo_mem_max ) {
4083 mp_runaway(mp); /* if memory is exhausted, display possible runaway text */
4084 mp_overflow(mp, "main memory size",mp->mem_max);
4085 /* quit; all one-word nodes are busy */
4086 @:MetaPost capacity exceeded main memory size}{\quad main memory size@>
4089 link(p)=null; /* provide an oft-desired initialization of the new node */
4090 incr(mp->dyn_used);/* maintain statistics */
4094 @ Conversely, a one-word node is recycled by calling |free_avail|.
4096 @d free_avail(A) /* single-word node liberation */
4097 { link((A))=mp->avail; mp->avail=(A); decr(mp->dyn_used); }
4099 @ There's also a |fast_get_avail| routine, which saves the procedure-call
4100 overhead at the expense of extra programming. This macro is used in
4101 the places that would otherwise account for the most calls of |get_avail|.
4104 @d fast_get_avail(A) {
4105 (A)=mp->avail; /* avoid |get_avail| if possible, to save time */
4106 if ( (A)==null ) { (A)=mp_get_avail(mp); }
4107 else { mp->avail=link((A)); link((A))=null; incr(mp->dyn_used); }
4110 @ The available-space list that keeps track of the variable-size portion
4111 of |mem| is a nonempty, doubly-linked circular list of empty nodes,
4112 pointed to by the roving pointer |rover|.
4114 Each empty node has size 2 or more; the first word contains the special
4115 value |max_halfword| in its |link| field and the size in its |info| field;
4116 the second word contains the two pointers for double linking.
4118 Each nonempty node also has size 2 or more. Its first word is of type
4119 |two_halves|\kern-1pt, and its |link| field is never equal to |max_halfword|.
4120 Otherwise there is complete flexibility with respect to the contents
4121 of its other fields and its other words.
4123 (We require |mem_max<max_halfword| because terrible things can happen
4124 when |max_halfword| appears in the |link| field of a nonempty node.)
4126 @d empty_flag max_halfword /* the |link| of an empty variable-size node */
4127 @d is_empty(A) (link((A))==empty_flag) /* tests for empty node */
4128 @d node_size info /* the size field in empty variable-size nodes */
4129 @d llink(A) info((A)+1) /* left link in doubly-linked list of empty nodes */
4130 @d rlink(A) link((A)+1) /* right link in doubly-linked list of empty nodes */
4133 pointer rover; /* points to some node in the list of empties */
4135 @ A call to |get_node| with argument |s| returns a pointer to a new node
4136 of size~|s|, which must be 2~or more. The |link| field of the first word
4137 of this new node is set to null. An overflow stop occurs if no suitable
4140 If |get_node| is called with $s=2^{30}$, it simply merges adjacent free
4141 areas and returns the value |max_halfword|.
4143 @<Internal library declarations@>=
4144 pointer mp_get_node (MP mp,integer s) ;
4147 pointer mp_get_node (MP mp,integer s) { /* variable-size node allocation */
4148 pointer p; /* the node currently under inspection */
4149 pointer q; /* the node physically after node |p| */
4150 integer r; /* the newly allocated node, or a candidate for this honor */
4151 integer t,tt; /* temporary registers */
4154 p=mp->rover; /* start at some free node in the ring */
4156 @<Try to allocate within node |p| and its physical successors,
4157 and |goto found| if allocation was possible@>;
4158 if (rlink(p)==null || (rlink(p)==p && p!=mp->rover)) {
4159 print_err("Free list garbled");
4160 help3("I found an entry in the list of free nodes that links")
4161 ("badly. I will try to ignore the broken link, but something")
4162 ("is seriously amiss. It is wise to warn the maintainers.")
4166 p=rlink(p); /* move to the next node in the ring */
4167 } while (p!=mp->rover); /* repeat until the whole list has been traversed */
4168 if ( s==010000000000 ) {
4169 return max_halfword;
4171 if ( mp->lo_mem_max+2<mp->hi_mem_min ) {
4172 if ( mp->lo_mem_max+2<=max_halfword ) {
4173 @<Grow more variable-size memory and |goto restart|@>;
4176 mp_overflow(mp, "main memory size",mp->mem_max);
4177 /* sorry, nothing satisfactory is left */
4178 @:MetaPost capacity exceeded main memory size}{\quad main memory size@>
4180 link(r)=null; /* this node is now nonempty */
4181 mp->var_used+=s; /* maintain usage statistics */
4185 @ The lower part of |mem| grows by 1000 words at a time, unless
4186 we are very close to going under. When it grows, we simply link
4187 a new node into the available-space list. This method of controlled
4188 growth helps to keep the |mem| usage consecutive when \MP\ is
4189 implemented on ``virtual memory'' systems.
4192 @<Grow more variable-size memory and |goto restart|@>=
4194 if ( mp->hi_mem_min-mp->lo_mem_max>=1998 ) {
4195 t=mp->lo_mem_max+1000;
4197 t=mp->lo_mem_max+1+(mp->hi_mem_min-mp->lo_mem_max) / 2;
4198 /* |lo_mem_max+2<=t<hi_mem_min| */
4200 if ( t>max_halfword ) t=max_halfword;
4201 p=llink(mp->rover); q=mp->lo_mem_max; rlink(p)=q; llink(mp->rover)=q;
4202 rlink(q)=mp->rover; llink(q)=p; link(q)=empty_flag;
4203 node_size(q)=t-mp->lo_mem_max;
4204 mp->lo_mem_max=t; link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null;
4209 @ @<Try to allocate...@>=
4210 q=p+node_size(p); /* find the physical successor */
4211 while ( is_empty(q) ) { /* merge node |p| with node |q| */
4212 t=rlink(q); tt=llink(q);
4214 if ( q==mp->rover ) mp->rover=t;
4215 llink(t)=tt; rlink(tt)=t;
4220 @<Allocate from the top of node |p| and |goto found|@>;
4223 if ( rlink(p)!=p ) {
4224 @<Allocate entire node |p| and |goto found|@>;
4227 node_size(p)=q-p /* reset the size in case it grew */
4229 @ @<Allocate from the top...@>=
4231 node_size(p)=r-p; /* store the remaining size */
4232 mp->rover=p; /* start searching here next time */
4236 @ Here we delete node |p| from the ring, and let |rover| rove around.
4238 @<Allocate entire...@>=
4240 mp->rover=rlink(p); t=llink(p);
4241 llink(mp->rover)=t; rlink(t)=mp->rover;
4245 @ Conversely, when some variable-size node |p| of size |s| is no longer needed,
4246 the operation |free_node(p,s)| will make its words available, by inserting
4247 |p| as a new empty node just before where |rover| now points.
4249 @<Internal library declarations@>=
4250 void mp_free_node (MP mp, pointer p, halfword s) ;
4253 void mp_free_node (MP mp, pointer p, halfword s) { /* variable-size node
4255 pointer q; /* |llink(rover)| */
4256 node_size(p)=s; link(p)=empty_flag;
4258 q=llink(mp->rover); llink(p)=q; rlink(p)=mp->rover; /* set both links */
4259 llink(mp->rover)=p; rlink(q)=p; /* insert |p| into the ring */
4260 mp->var_used-=s; /* maintain statistics */
4263 @ Just before \.{INIMP} writes out the memory, it sorts the doubly linked
4264 available space list. The list is probably very short at such times, so a
4265 simple insertion sort is used. The smallest available location will be
4266 pointed to by |rover|, the next-smallest by |rlink(rover)|, etc.
4269 void mp_sort_avail (MP mp) { /* sorts the available variable-size nodes
4271 pointer p,q,r; /* indices into |mem| */
4272 pointer old_rover; /* initial |rover| setting */
4273 p=mp_get_node(mp, 010000000000); /* merge adjacent free areas */
4274 p=rlink(mp->rover); rlink(mp->rover)=max_halfword; old_rover=mp->rover;
4275 while ( p!=old_rover ) {
4276 @<Sort |p| into the list starting at |rover|
4277 and advance |p| to |rlink(p)|@>;
4280 while ( rlink(p)!=max_halfword ) {
4281 llink(rlink(p))=p; p=rlink(p);
4283 rlink(p)=mp->rover; llink(mp->rover)=p;
4286 @ The following |while| loop is guaranteed to
4287 terminate, since the list that starts at
4288 |rover| ends with |max_halfword| during the sorting procedure.
4291 if ( p<mp->rover ) {
4292 q=p; p=rlink(q); rlink(q)=mp->rover; mp->rover=q;
4295 while ( rlink(q)<p ) q=rlink(q);
4296 r=rlink(p); rlink(p)=rlink(q); rlink(q)=p; p=r;
4299 @* \[11] Memory layout.
4300 Some areas of |mem| are dedicated to fixed usage, since static allocation is
4301 more efficient than dynamic allocation when we can get away with it. For
4302 example, locations |0| to |1| are always used to store a
4303 two-word dummy token whose second word is zero.
4304 The following macro definitions accomplish the static allocation by giving
4305 symbolic names to the fixed positions. Static variable-size nodes appear
4306 in locations |0| through |lo_mem_stat_max|, and static single-word nodes
4307 appear in locations |hi_mem_stat_min| through |mem_top|, inclusive.
4309 @d null_dash (2) /* the first two words are reserved for a null value */
4310 @d dep_head (null_dash+3) /* we will define |dash_node_size=3| */
4311 @d zero_val (dep_head+2) /* two words for a permanently zero value */
4312 @d temp_val (zero_val+2) /* two words for a temporary value node */
4313 @d end_attr temp_val /* we use |end_attr+2| only */
4314 @d inf_val (end_attr+2) /* and |inf_val+1| only */
4315 @d test_pen (inf_val+2)
4316 /* nine words for a pen used when testing the turning number */
4317 @d bad_vardef (test_pen+9) /* two words for \&{vardef} error recovery */
4318 @d lo_mem_stat_max (bad_vardef+1) /* largest statically
4319 allocated word in the variable-size |mem| */
4321 @d sentinel mp->mem_top /* end of sorted lists */
4322 @d temp_head (mp->mem_top-1) /* head of a temporary list of some kind */
4323 @d hold_head (mp->mem_top-2) /* head of a temporary list of another kind */
4324 @d spec_head (mp->mem_top-3) /* head of a list of unprocessed \&{special} items */
4325 @d hi_mem_stat_min (mp->mem_top-3) /* smallest statically allocated word in
4326 the one-word |mem| */
4328 @ The following code gets the dynamic part of |mem| off to a good start,
4329 when \MP\ is initializing itself the slow way.
4331 @<Initialize table entries (done by \.{INIMP} only)@>=
4332 mp->rover=lo_mem_stat_max+1; /* initialize the dynamic memory */
4333 link(mp->rover)=empty_flag;
4334 node_size(mp->rover)=1000; /* which is a 1000-word available node */
4335 llink(mp->rover)=mp->rover; rlink(mp->rover)=mp->rover;
4336 mp->lo_mem_max=mp->rover+1000;
4337 link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null;
4338 for (k=hi_mem_stat_min;k<=(int)mp->mem_top;k++) {
4339 mp->mem[k]=mp->mem[mp->lo_mem_max]; /* clear list heads */
4341 mp->avail=null; mp->mem_end=mp->mem_top;
4342 mp->hi_mem_min=hi_mem_stat_min; /* initialize the one-word memory */
4343 mp->var_used=lo_mem_stat_max+1;
4344 mp->dyn_used=mp->mem_top+1-(hi_mem_stat_min); /* initialize statistics */
4345 @<Initialize a pen at |test_pen| so that it fits in nine words@>;
4347 @ The procedure |flush_list(p)| frees an entire linked list of one-word
4348 nodes that starts at a given position, until coming to |sentinel| or a
4349 pointer that is not in the one-word region. Another procedure,
4350 |flush_node_list|, frees an entire linked list of one-word and two-word
4351 nodes, until coming to a |null| pointer.
4355 void mp_flush_list (MP mp,pointer p) { /* makes list of single-word nodes available */
4356 pointer q,r; /* list traversers */
4357 if ( p>=mp->hi_mem_min ) if ( p!=sentinel ) {
4362 if ( r<mp->hi_mem_min ) break;
4363 } while (r!=sentinel);
4364 /* now |q| is the last node on the list */
4365 link(q)=mp->avail; mp->avail=p;
4369 void mp_flush_node_list (MP mp,pointer p) {
4370 pointer q; /* the node being recycled */
4373 if ( q<mp->hi_mem_min )
4374 mp_free_node(mp, q,2);
4380 @ If \MP\ is extended improperly, the |mem| array might get screwed up.
4381 For example, some pointers might be wrong, or some ``dead'' nodes might not
4382 have been freed when the last reference to them disappeared. Procedures
4383 |check_mem| and |search_mem| are available to help diagnose such
4384 problems. These procedures make use of two arrays called |free| and
4385 |was_free| that are present only if \MP's debugging routines have
4386 been included. (You may want to decrease the size of |mem| while you
4390 Because |boolean|s are typedef-d as ints, it is better to use
4391 unsigned chars here.
4394 unsigned char *free; /* free cells */
4395 unsigned char *was_free; /* previously free cells */
4396 pointer was_mem_end; pointer was_lo_max; pointer was_hi_min;
4397 /* previous |mem_end|, |lo_mem_max|,and |hi_mem_min| */
4398 boolean panicking; /* do we want to check memory constantly? */
4400 @ @<Allocate or initialize ...@>=
4401 mp->free = xmalloc ((mp->mem_max+1),sizeof (unsigned char));
4402 mp->was_free = xmalloc ((mp->mem_max+1), sizeof (unsigned char));
4404 @ @<Dealloc variables@>=
4406 xfree(mp->was_free);
4408 @ @<Allocate or ...@>=
4409 mp->was_mem_end=0; /* indicate that everything was previously free */
4410 mp->was_lo_max=0; mp->was_hi_min=mp->mem_max;
4411 mp->panicking=false;
4413 @ @<Declare |mp_reallocate| functions@>=
4414 void mp_reallocate_memory(MP mp, int l) ;
4417 void mp_reallocate_memory(MP mp, int l) {
4418 XREALLOC(mp->free, l, unsigned char);
4419 XREALLOC(mp->was_free, l, unsigned char);
4421 int newarea = l-mp->mem_max;
4422 XREALLOC(mp->mem, l, memory_word);
4423 memset (mp->mem+(mp->mem_max+1),0,sizeof(memory_word)*(newarea));
4425 XREALLOC(mp->mem, l, memory_word);
4426 memset(mp->mem,0,sizeof(memory_word)*(l+1));
4429 if (mp->ini_version)
4435 @ Procedure |check_mem| makes sure that the available space lists of
4436 |mem| are well formed, and it optionally prints out all locations
4437 that are reserved now but were free the last time this procedure was called.
4440 void mp_check_mem (MP mp,boolean print_locs ) {
4441 pointer p,q,r; /* current locations of interest in |mem| */
4442 boolean clobbered; /* is something amiss? */
4443 for (p=0;p<=mp->lo_mem_max;p++) {
4444 mp->free[p]=false; /* you can probably do this faster */
4446 for (p=mp->hi_mem_min;p<= mp->mem_end;p++) {
4447 mp->free[p]=false; /* ditto */
4449 @<Check single-word |avail| list@>;
4450 @<Check variable-size |avail| list@>;
4451 @<Check flags of unavailable nodes@>;
4452 @<Check the list of linear dependencies@>;
4454 @<Print newly busy locations@>;
4456 memcpy(mp->was_free,mp->free, sizeof(char)*(mp->mem_end+1));
4457 mp->was_mem_end=mp->mem_end;
4458 mp->was_lo_max=mp->lo_mem_max;
4459 mp->was_hi_min=mp->hi_mem_min;
4462 @ @<Check single-word...@>=
4463 p=mp->avail; q=null; clobbered=false;
4465 if ( (p>mp->mem_end)||(p<mp->hi_mem_min) ) clobbered=true;
4466 else if ( mp->free[p] ) clobbered=true;
4468 mp_print_nl(mp, "AVAIL list clobbered at ");
4469 @.AVAIL list clobbered...@>
4470 mp_print_int(mp, q); break;
4472 mp->free[p]=true; q=p; p=link(q);
4475 @ @<Check variable-size...@>=
4476 p=mp->rover; q=null; clobbered=false;
4478 if ( (p>=mp->lo_mem_max)||(p<0) ) clobbered=true;
4479 else if ( (rlink(p)>=mp->lo_mem_max)||(rlink(p)<0) ) clobbered=true;
4480 else if ( !(is_empty(p))||(node_size(p)<2)||
4481 (p+node_size(p)>mp->lo_mem_max)|| (llink(rlink(p))!=p) ) clobbered=true;
4483 mp_print_nl(mp, "Double-AVAIL list clobbered at ");
4484 @.Double-AVAIL list clobbered...@>
4485 mp_print_int(mp, q); break;
4487 for (q=p;q<=p+node_size(p)-1;q++) { /* mark all locations free */
4488 if ( mp->free[q] ) {
4489 mp_print_nl(mp, "Doubly free location at ");
4490 @.Doubly free location...@>
4491 mp_print_int(mp, q); break;
4496 } while (p!=mp->rover)
4499 @ @<Check flags...@>=
4501 while ( p<=mp->lo_mem_max ) { /* node |p| should not be empty */
4502 if ( is_empty(p) ) {
4503 mp_print_nl(mp, "Bad flag at "); mp_print_int(mp, p);
4506 while ( (p<=mp->lo_mem_max) && ! mp->free[p] ) incr(p);
4507 while ( (p<=mp->lo_mem_max) && mp->free[p] ) incr(p);
4510 @ @<Print newly busy...@>=
4512 @<Do intialization required before printing new busy locations@>;
4513 mp_print_nl(mp, "New busy locs:");
4515 for (p=0;p<= mp->lo_mem_max;p++ ) {
4516 if ( ! mp->free[p] && ((p>mp->was_lo_max) || mp->was_free[p]) ) {
4517 @<Indicate that |p| is a new busy location@>;
4520 for (p=mp->hi_mem_min;p<=mp->mem_end;p++ ) {
4521 if ( ! mp->free[p] &&
4522 ((p<mp->was_hi_min) || (p>mp->was_mem_end) || mp->was_free[p]) ) {
4523 @<Indicate that |p| is a new busy location@>;
4526 @<Finish printing new busy locations@>;
4529 @ There might be many new busy locations so we are careful to print contiguous
4530 blocks compactly. During this operation |q| is the last new busy location and
4531 |r| is the start of the block containing |q|.
4533 @<Indicate that |p| is a new busy location@>=
4537 mp_print(mp, ".."); mp_print_int(mp, q);
4539 mp_print_char(mp, ' '); mp_print_int(mp, p);
4545 @ @<Do intialization required before printing new busy locations@>=
4546 q=mp->mem_max; r=mp->mem_max
4548 @ @<Finish printing new busy locations@>=
4550 mp_print(mp, ".."); mp_print_int(mp, q);
4553 @ The |search_mem| procedure attempts to answer the question ``Who points
4554 to node~|p|?'' In doing so, it fetches |link| and |info| fields of |mem|
4555 that might not be of type |two_halves|. Strictly speaking, this is
4556 undefined, and it can lead to ``false drops'' (words that seem to
4557 point to |p| purely by coincidence). But for debugging purposes, we want
4558 to rule out the places that do {\sl not\/} point to |p|, so a few false
4559 drops are tolerable.
4562 void mp_search_mem (MP mp, pointer p) { /* look for pointers to |p| */
4563 integer q; /* current position being searched */
4564 for (q=0;q<=mp->lo_mem_max;q++) {
4566 mp_print_nl(mp, "LINK("); mp_print_int(mp, q); mp_print_char(mp, ')');
4569 mp_print_nl(mp, "INFO("); mp_print_int(mp, q); mp_print_char(mp, ')');
4572 for (q=mp->hi_mem_min;q<=mp->mem_end;q++) {
4574 mp_print_nl(mp, "LINK("); mp_print_int(mp, q); mp_print_char(mp, ')');
4577 mp_print_nl(mp, "INFO("); mp_print_int(mp, q); mp_print_char(mp, ')');
4580 @<Search |eqtb| for equivalents equal to |p|@>;
4583 @* \[12] The command codes.
4584 Before we can go much further, we need to define symbolic names for the internal
4585 code numbers that represent the various commands obeyed by \MP. These codes
4586 are somewhat arbitrary, but not completely so. For example,
4587 some codes have been made adjacent so that |case| statements in the
4588 program need not consider cases that are widely spaced, or so that |case|
4589 statements can be replaced by |if| statements. A command can begin an
4590 expression if and only if its code lies between |min_primary_command| and
4591 |max_primary_command|, inclusive. The first token of a statement that doesn't
4592 begin with an expression has a command code between |min_command| and
4593 |max_statement_command|, inclusive. Anything less than |min_command| is
4594 eliminated during macro expansions, and anything no more than |max_pre_command|
4595 is eliminated when expanding \TeX\ material. Ranges such as
4596 |min_secondary_command..max_secondary_command| are used when parsing
4597 expressions, but the relative ordering within such a range is generally not
4600 The ordering of the highest-numbered commands
4601 (|comma<semicolon<end_group<stop|) is crucial for the parsing and
4602 error-recovery methods of this program as is the ordering |if_test<fi_or_else|
4603 for the smallest two commands. The ordering is also important in the ranges
4604 |numeric_token..plus_or_minus| and |left_brace..ampersand|.
4606 At any rate, here is the list, for future reference.
4608 @d start_tex 1 /* begin \TeX\ material (\&{btex}, \&{verbatimtex}) */
4609 @d etex_marker 2 /* end \TeX\ material (\&{etex}) */
4610 @d mpx_break 3 /* stop reading an \.{MPX} file (\&{mpxbreak}) */
4611 @d max_pre_command mpx_break
4612 @d if_test 4 /* conditional text (\&{if}) */
4613 @d fi_or_else 5 /* delimiters for conditionals (\&{elseif}, \&{else}, \&{fi}) */
4614 @d input 6 /* input a source file (\&{input}, \&{endinput}) */
4615 @d iteration 7 /* iterate (\&{for}, \&{forsuffixes}, \&{forever}, \&{endfor}) */
4616 @d repeat_loop 8 /* special command substituted for \&{endfor} */
4617 @d exit_test 9 /* premature exit from a loop (\&{exitif}) */
4618 @d relax 10 /* do nothing (\.{\char`\\}) */
4619 @d scan_tokens 11 /* put a string into the input buffer */
4620 @d expand_after 12 /* look ahead one token */
4621 @d defined_macro 13 /* a macro defined by the user */
4622 @d min_command (defined_macro+1)
4623 @d save_command 14 /* save a list of tokens (\&{save}) */
4624 @d interim_command 15 /* save an internal quantity (\&{interim}) */
4625 @d let_command 16 /* redefine a symbolic token (\&{let}) */
4626 @d new_internal 17 /* define a new internal quantity (\&{newinternal}) */
4627 @d macro_def 18 /* define a macro (\&{def}, \&{vardef}, etc.) */
4628 @d ship_out_command 19 /* output a character (\&{shipout}) */
4629 @d add_to_command 20 /* add to edges (\&{addto}) */
4630 @d bounds_command 21 /* add bounding path to edges (\&{setbounds}, \&{clip}) */
4631 @d tfm_command 22 /* command for font metric info (\&{ligtable}, etc.) */
4632 @d protection_command 23 /* set protection flag (\&{outer}, \&{inner}) */
4633 @d show_command 24 /* diagnostic output (\&{show}, \&{showvariable}, etc.) */
4634 @d mode_command 25 /* set interaction level (\&{batchmode}, etc.) */
4635 @d mp_random_seed 26 /* initialize random number generator (\&{randomseed}) */
4636 @d message_command 27 /* communicate to user (\&{message}, \&{errmessage}) */
4637 @d every_job_command 28 /* designate a starting token (\&{everyjob}) */
4638 @d delimiters 29 /* define a pair of delimiters (\&{delimiters}) */
4639 @d special_command 30 /* output special info (\&{special})
4640 or font map info (\&{fontmapfile}, \&{fontmapline}) */
4641 @d write_command 31 /* write text to a file (\&{write}) */
4642 @d type_name 32 /* declare a type (\&{numeric}, \&{pair}, etc.) */
4643 @d max_statement_command type_name
4644 @d min_primary_command type_name
4645 @d left_delimiter 33 /* the left delimiter of a matching pair */
4646 @d begin_group 34 /* beginning of a group (\&{begingroup}) */
4647 @d nullary 35 /* an operator without arguments (e.g., \&{normaldeviate}) */
4648 @d unary 36 /* an operator with one argument (e.g., \&{sqrt}) */
4649 @d str_op 37 /* convert a suffix to a string (\&{str}) */
4650 @d cycle 38 /* close a cyclic path (\&{cycle}) */
4651 @d primary_binary 39 /* binary operation taking `\&{of}' (e.g., \&{point}) */
4652 @d capsule_token 40 /* a value that has been put into a token list */
4653 @d string_token 41 /* a string constant (e.g., |"hello"|) */
4654 @d internal_quantity 42 /* internal numeric parameter (e.g., \&{pausing}) */
4655 @d min_suffix_token internal_quantity
4656 @d tag_token 43 /* a symbolic token without a primitive meaning */
4657 @d numeric_token 44 /* a numeric constant (e.g., \.{3.14159}) */
4658 @d max_suffix_token numeric_token
4659 @d plus_or_minus 45 /* either `\.+' or `\.-' */
4660 @d max_primary_command plus_or_minus /* should also be |numeric_token+1| */
4661 @d min_tertiary_command plus_or_minus
4662 @d tertiary_secondary_macro 46 /* a macro defined by \&{secondarydef} */
4663 @d tertiary_binary 47 /* an operator at the tertiary level (e.g., `\.{++}') */
4664 @d max_tertiary_command tertiary_binary
4665 @d left_brace 48 /* the operator `\.{\char`\{}' */
4666 @d min_expression_command left_brace
4667 @d path_join 49 /* the operator `\.{..}' */
4668 @d ampersand 50 /* the operator `\.\&' */
4669 @d expression_tertiary_macro 51 /* a macro defined by \&{tertiarydef} */
4670 @d expression_binary 52 /* an operator at the expression level (e.g., `\.<') */
4671 @d equals 53 /* the operator `\.=' */
4672 @d max_expression_command equals
4673 @d and_command 54 /* the operator `\&{and}' */
4674 @d min_secondary_command and_command
4675 @d secondary_primary_macro 55 /* a macro defined by \&{primarydef} */
4676 @d slash 56 /* the operator `\./' */
4677 @d secondary_binary 57 /* an operator at the binary level (e.g., \&{shifted}) */
4678 @d max_secondary_command secondary_binary
4679 @d param_type 58 /* type of parameter (\&{primary}, \&{expr}, \&{suffix}, etc.) */
4680 @d controls 59 /* specify control points explicitly (\&{controls}) */
4681 @d tension 60 /* specify tension between knots (\&{tension}) */
4682 @d at_least 61 /* bounded tension value (\&{atleast}) */
4683 @d curl_command 62 /* specify curl at an end knot (\&{curl}) */
4684 @d macro_special 63 /* special macro operators (\&{quote}, \.{\#\AT!}, etc.) */
4685 @d right_delimiter 64 /* the right delimiter of a matching pair */
4686 @d left_bracket 65 /* the operator `\.[' */
4687 @d right_bracket 66 /* the operator `\.]' */
4688 @d right_brace 67 /* the operator `\.{\char`\}}' */
4689 @d with_option 68 /* option for filling (\&{withpen}, \&{withweight}, etc.) */
4691 /* variant of \&{addto} (\&{contour}, \&{doublepath}, \&{also}) */
4692 @d of_token 70 /* the operator `\&{of}' */
4693 @d to_token 71 /* the operator `\&{to}' */
4694 @d step_token 72 /* the operator `\&{step}' */
4695 @d until_token 73 /* the operator `\&{until}' */
4696 @d within_token 74 /* the operator `\&{within}' */
4697 @d lig_kern_token 75
4698 /* the operators `\&{kern}' and `\.{=:}' and `\.{=:\char'174}', etc. */
4699 @d assignment 76 /* the operator `\.{:=}' */
4700 @d skip_to 77 /* the operation `\&{skipto}' */
4701 @d bchar_label 78 /* the operator `\.{\char'174\char'174:}' */
4702 @d double_colon 79 /* the operator `\.{::}' */
4703 @d colon 80 /* the operator `\.:' */
4705 @d comma 81 /* the operator `\.,', must be |colon+1| */
4706 @d end_of_statement (mp->cur_cmd>comma)
4707 @d semicolon 82 /* the operator `\.;', must be |comma+1| */
4708 @d end_group 83 /* end a group (\&{endgroup}), must be |semicolon+1| */
4709 @d stop 84 /* end a job (\&{end}, \&{dump}), must be |end_group+1| */
4710 @d max_command_code stop
4711 @d outer_tag (max_command_code+1) /* protection code added to command code */
4714 typedef int command_code;
4716 @ Variables and capsules in \MP\ have a variety of ``types,''
4717 distinguished by the code numbers defined here. These numbers are also
4718 not completely arbitrary. Things that get expanded must have types
4719 |>mp_independent|; a type remaining after expansion is numeric if and only if
4720 its code number is at least |numeric_type|; objects containing numeric
4721 parts must have types between |transform_type| and |pair_type|;
4722 all other types must be smaller than |transform_type|; and among the types
4723 that are not unknown or vacuous, the smallest two must be |boolean_type|
4724 and |string_type| in that order.
4726 @d undefined 0 /* no type has been declared */
4727 @d unknown_tag 1 /* this constant is added to certain type codes below */
4728 @d unknown_types mp_unknown_boolean: case mp_unknown_string:
4729 case mp_unknown_pen: case mp_unknown_picture: case mp_unknown_path
4732 enum mp_variable_type {
4733 mp_vacuous=1, /* no expression was present */
4734 mp_boolean_type, /* \&{boolean} with a known value */
4736 mp_string_type, /* \&{string} with a known value */
4738 mp_pen_type, /* \&{pen} with a known value */
4740 mp_path_type, /* \&{path} with a known value */
4742 mp_picture_type, /* \&{picture} with a known value */
4744 mp_transform_type, /* \&{transform} variable or capsule */
4745 mp_color_type, /* \&{color} variable or capsule */
4746 mp_cmykcolor_type, /* \&{cmykcolor} variable or capsule */
4747 mp_pair_type, /* \&{pair} variable or capsule */
4748 mp_numeric_type, /* variable that has been declared \&{numeric} but not used */
4749 mp_known, /* \&{numeric} with a known value */
4750 mp_dependent, /* a linear combination with |fraction| coefficients */
4751 mp_proto_dependent, /* a linear combination with |scaled| coefficients */
4752 mp_independent, /* \&{numeric} with unknown value */
4753 mp_token_list, /* variable name or suffix argument or text argument */
4754 mp_structured, /* variable with subscripts and attributes */
4755 mp_unsuffixed_macro, /* variable defined with \&{vardef} but no \.{\AT!\#} */
4756 mp_suffixed_macro /* variable defined with \&{vardef} and \.{\AT!\#} */
4760 void mp_print_type (MP mp,small_number t) ;
4762 @ @<Basic printing procedures@>=
4763 void mp_print_type (MP mp,small_number t) {
4765 case mp_vacuous:mp_print(mp, "mp_vacuous"); break;
4766 case mp_boolean_type:mp_print(mp, "boolean"); break;
4767 case mp_unknown_boolean:mp_print(mp, "unknown boolean"); break;
4768 case mp_string_type:mp_print(mp, "string"); break;
4769 case mp_unknown_string:mp_print(mp, "unknown string"); break;
4770 case mp_pen_type:mp_print(mp, "pen"); break;
4771 case mp_unknown_pen:mp_print(mp, "unknown pen"); break;
4772 case mp_path_type:mp_print(mp, "path"); break;
4773 case mp_unknown_path:mp_print(mp, "unknown path"); break;
4774 case mp_picture_type:mp_print(mp, "picture"); break;
4775 case mp_unknown_picture:mp_print(mp, "unknown picture"); break;
4776 case mp_transform_type:mp_print(mp, "transform"); break;
4777 case mp_color_type:mp_print(mp, "color"); break;
4778 case mp_cmykcolor_type:mp_print(mp, "cmykcolor"); break;
4779 case mp_pair_type:mp_print(mp, "pair"); break;
4780 case mp_known:mp_print(mp, "known numeric"); break;
4781 case mp_dependent:mp_print(mp, "dependent"); break;
4782 case mp_proto_dependent:mp_print(mp, "proto-dependent"); break;
4783 case mp_numeric_type:mp_print(mp, "numeric"); break;
4784 case mp_independent:mp_print(mp, "independent"); break;
4785 case mp_token_list:mp_print(mp, "token list"); break;
4786 case mp_structured:mp_print(mp, "mp_structured"); break;
4787 case mp_unsuffixed_macro:mp_print(mp, "unsuffixed macro"); break;
4788 case mp_suffixed_macro:mp_print(mp, "suffixed macro"); break;
4789 default: mp_print(mp, "undefined"); break;
4793 @ Values inside \MP\ are stored in two-word nodes that have a |name_type|
4794 as well as a |type|. The possibilities for |name_type| are defined
4795 here; they will be explained in more detail later.
4799 mp_root=0, /* |name_type| at the top level of a variable */
4800 mp_saved_root, /* same, when the variable has been saved */
4801 mp_structured_root, /* |name_type| where a |mp_structured| branch occurs */
4802 mp_subscr, /* |name_type| in a subscript node */
4803 mp_attr, /* |name_type| in an attribute node */
4804 mp_x_part_sector, /* |name_type| in the \&{xpart} of a node */
4805 mp_y_part_sector, /* |name_type| in the \&{ypart} of a node */
4806 mp_xx_part_sector, /* |name_type| in the \&{xxpart} of a node */
4807 mp_xy_part_sector, /* |name_type| in the \&{xypart} of a node */
4808 mp_yx_part_sector, /* |name_type| in the \&{yxpart} of a node */
4809 mp_yy_part_sector, /* |name_type| in the \&{yypart} of a node */
4810 mp_red_part_sector, /* |name_type| in the \&{redpart} of a node */
4811 mp_green_part_sector, /* |name_type| in the \&{greenpart} of a node */
4812 mp_blue_part_sector, /* |name_type| in the \&{bluepart} of a node */
4813 mp_cyan_part_sector, /* |name_type| in the \&{redpart} of a node */
4814 mp_magenta_part_sector, /* |name_type| in the \&{greenpart} of a node */
4815 mp_yellow_part_sector, /* |name_type| in the \&{bluepart} of a node */
4816 mp_black_part_sector, /* |name_type| in the \&{greenpart} of a node */
4817 mp_grey_part_sector, /* |name_type| in the \&{bluepart} of a node */
4818 mp_capsule, /* |name_type| in stashed-away subexpressions */
4819 mp_token /* |name_type| in a numeric token or string token */
4822 @ Primitive operations that produce values have a secondary identification
4823 code in addition to their command code; it's something like genera and species.
4824 For example, `\.*' has the command code |primary_binary|, and its
4825 secondary identification is |times|. The secondary codes start at 30 so that
4826 they don't overlap with the type codes; some type codes (e.g., |mp_string_type|)
4827 are used as operators as well as type identifications. The relative values
4828 are not critical, except for |true_code..false_code|, |or_op..and_op|,
4829 and |filled_op..bounded_op|. The restrictions are that
4830 |and_op-false_code=or_op-true_code|, that the ordering of
4831 |x_part...blue_part| must match that of |x_part_sector..mp_blue_part_sector|,
4832 and the ordering of |filled_op..bounded_op| must match that of the code
4833 values they test for.
4835 @d true_code 30 /* operation code for \.{true} */
4836 @d false_code 31 /* operation code for \.{false} */
4837 @d null_picture_code 32 /* operation code for \.{nullpicture} */
4838 @d null_pen_code 33 /* operation code for \.{nullpen} */
4839 @d job_name_op 34 /* operation code for \.{jobname} */
4840 @d read_string_op 35 /* operation code for \.{readstring} */
4841 @d pen_circle 36 /* operation code for \.{pencircle} */
4842 @d normal_deviate 37 /* operation code for \.{normaldeviate} */
4843 @d read_from_op 38 /* operation code for \.{readfrom} */
4844 @d close_from_op 39 /* operation code for \.{closefrom} */
4845 @d odd_op 40 /* operation code for \.{odd} */
4846 @d known_op 41 /* operation code for \.{known} */
4847 @d unknown_op 42 /* operation code for \.{unknown} */
4848 @d not_op 43 /* operation code for \.{not} */
4849 @d decimal 44 /* operation code for \.{decimal} */
4850 @d reverse 45 /* operation code for \.{reverse} */
4851 @d make_path_op 46 /* operation code for \.{makepath} */
4852 @d make_pen_op 47 /* operation code for \.{makepen} */
4853 @d oct_op 48 /* operation code for \.{oct} */
4854 @d hex_op 49 /* operation code for \.{hex} */
4855 @d ASCII_op 50 /* operation code for \.{ASCII} */
4856 @d char_op 51 /* operation code for \.{char} */
4857 @d length_op 52 /* operation code for \.{length} */
4858 @d turning_op 53 /* operation code for \.{turningnumber} */
4859 @d color_model_part 54 /* operation code for \.{colormodel} */
4860 @d x_part 55 /* operation code for \.{xpart} */
4861 @d y_part 56 /* operation code for \.{ypart} */
4862 @d xx_part 57 /* operation code for \.{xxpart} */
4863 @d xy_part 58 /* operation code for \.{xypart} */
4864 @d yx_part 59 /* operation code for \.{yxpart} */
4865 @d yy_part 60 /* operation code for \.{yypart} */
4866 @d red_part 61 /* operation code for \.{redpart} */
4867 @d green_part 62 /* operation code for \.{greenpart} */
4868 @d blue_part 63 /* operation code for \.{bluepart} */
4869 @d cyan_part 64 /* operation code for \.{cyanpart} */
4870 @d magenta_part 65 /* operation code for \.{magentapart} */
4871 @d yellow_part 66 /* operation code for \.{yellowpart} */
4872 @d black_part 67 /* operation code for \.{blackpart} */
4873 @d grey_part 68 /* operation code for \.{greypart} */
4874 @d font_part 69 /* operation code for \.{fontpart} */
4875 @d text_part 70 /* operation code for \.{textpart} */
4876 @d path_part 71 /* operation code for \.{pathpart} */
4877 @d pen_part 72 /* operation code for \.{penpart} */
4878 @d dash_part 73 /* operation code for \.{dashpart} */
4879 @d sqrt_op 74 /* operation code for \.{sqrt} */
4880 @d m_exp_op 75 /* operation code for \.{mexp} */
4881 @d m_log_op 76 /* operation code for \.{mlog} */
4882 @d sin_d_op 77 /* operation code for \.{sind} */
4883 @d cos_d_op 78 /* operation code for \.{cosd} */
4884 @d floor_op 79 /* operation code for \.{floor} */
4885 @d uniform_deviate 80 /* operation code for \.{uniformdeviate} */
4886 @d char_exists_op 81 /* operation code for \.{charexists} */
4887 @d font_size 82 /* operation code for \.{fontsize} */
4888 @d ll_corner_op 83 /* operation code for \.{llcorner} */
4889 @d lr_corner_op 84 /* operation code for \.{lrcorner} */
4890 @d ul_corner_op 85 /* operation code for \.{ulcorner} */
4891 @d ur_corner_op 86 /* operation code for \.{urcorner} */
4892 @d arc_length 87 /* operation code for \.{arclength} */
4893 @d angle_op 88 /* operation code for \.{angle} */
4894 @d cycle_op 89 /* operation code for \.{cycle} */
4895 @d filled_op 90 /* operation code for \.{filled} */
4896 @d stroked_op 91 /* operation code for \.{stroked} */
4897 @d textual_op 92 /* operation code for \.{textual} */
4898 @d clipped_op 93 /* operation code for \.{clipped} */
4899 @d bounded_op 94 /* operation code for \.{bounded} */
4900 @d plus 95 /* operation code for \.+ */
4901 @d minus 96 /* operation code for \.- */
4902 @d times 97 /* operation code for \.* */
4903 @d over 98 /* operation code for \./ */
4904 @d pythag_add 99 /* operation code for \.{++} */
4905 @d pythag_sub 100 /* operation code for \.{+-+} */
4906 @d or_op 101 /* operation code for \.{or} */
4907 @d and_op 102 /* operation code for \.{and} */
4908 @d less_than 103 /* operation code for \.< */
4909 @d less_or_equal 104 /* operation code for \.{<=} */
4910 @d greater_than 105 /* operation code for \.> */
4911 @d greater_or_equal 106 /* operation code for \.{>=} */
4912 @d equal_to 107 /* operation code for \.= */
4913 @d unequal_to 108 /* operation code for \.{<>} */
4914 @d concatenate 109 /* operation code for \.\& */
4915 @d rotated_by 110 /* operation code for \.{rotated} */
4916 @d slanted_by 111 /* operation code for \.{slanted} */
4917 @d scaled_by 112 /* operation code for \.{scaled} */
4918 @d shifted_by 113 /* operation code for \.{shifted} */
4919 @d transformed_by 114 /* operation code for \.{transformed} */
4920 @d x_scaled 115 /* operation code for \.{xscaled} */
4921 @d y_scaled 116 /* operation code for \.{yscaled} */
4922 @d z_scaled 117 /* operation code for \.{zscaled} */
4923 @d in_font 118 /* operation code for \.{infont} */
4924 @d intersect 119 /* operation code for \.{intersectiontimes} */
4925 @d double_dot 120 /* operation code for improper \.{..} */
4926 @d substring_of 121 /* operation code for \.{substring} */
4927 @d min_of substring_of
4928 @d subpath_of 122 /* operation code for \.{subpath} */
4929 @d direction_time_of 123 /* operation code for \.{directiontime} */
4930 @d point_of 124 /* operation code for \.{point} */
4931 @d precontrol_of 125 /* operation code for \.{precontrol} */
4932 @d postcontrol_of 126 /* operation code for \.{postcontrol} */
4933 @d pen_offset_of 127 /* operation code for \.{penoffset} */
4934 @d arc_time_of 128 /* operation code for \.{arctime} */
4935 @d mp_version 129 /* operation code for \.{mpversion} */
4936 @d envelope_of 130 /* operation code for \.{envelope} */
4938 @c void mp_print_op (MP mp,quarterword c) {
4939 if (c<=mp_numeric_type ) {
4940 mp_print_type(mp, c);
4943 case true_code:mp_print(mp, "true"); break;
4944 case false_code:mp_print(mp, "false"); break;
4945 case null_picture_code:mp_print(mp, "nullpicture"); break;
4946 case null_pen_code:mp_print(mp, "nullpen"); break;
4947 case job_name_op:mp_print(mp, "jobname"); break;
4948 case read_string_op:mp_print(mp, "readstring"); break;
4949 case pen_circle:mp_print(mp, "pencircle"); break;
4950 case normal_deviate:mp_print(mp, "normaldeviate"); break;
4951 case read_from_op:mp_print(mp, "readfrom"); break;
4952 case close_from_op:mp_print(mp, "closefrom"); break;
4953 case odd_op:mp_print(mp, "odd"); break;
4954 case known_op:mp_print(mp, "known"); break;
4955 case unknown_op:mp_print(mp, "unknown"); break;
4956 case not_op:mp_print(mp, "not"); break;
4957 case decimal:mp_print(mp, "decimal"); break;
4958 case reverse:mp_print(mp, "reverse"); break;
4959 case make_path_op:mp_print(mp, "makepath"); break;
4960 case make_pen_op:mp_print(mp, "makepen"); break;
4961 case oct_op:mp_print(mp, "oct"); break;
4962 case hex_op:mp_print(mp, "hex"); break;
4963 case ASCII_op:mp_print(mp, "ASCII"); break;
4964 case char_op:mp_print(mp, "char"); break;
4965 case length_op:mp_print(mp, "length"); break;
4966 case turning_op:mp_print(mp, "turningnumber"); break;
4967 case x_part:mp_print(mp, "xpart"); break;
4968 case y_part:mp_print(mp, "ypart"); break;
4969 case xx_part:mp_print(mp, "xxpart"); break;
4970 case xy_part:mp_print(mp, "xypart"); break;
4971 case yx_part:mp_print(mp, "yxpart"); break;
4972 case yy_part:mp_print(mp, "yypart"); break;
4973 case red_part:mp_print(mp, "redpart"); break;
4974 case green_part:mp_print(mp, "greenpart"); break;
4975 case blue_part:mp_print(mp, "bluepart"); break;
4976 case cyan_part:mp_print(mp, "cyanpart"); break;
4977 case magenta_part:mp_print(mp, "magentapart"); break;
4978 case yellow_part:mp_print(mp, "yellowpart"); break;
4979 case black_part:mp_print(mp, "blackpart"); break;
4980 case grey_part:mp_print(mp, "greypart"); break;
4981 case color_model_part:mp_print(mp, "colormodel"); break;
4982 case font_part:mp_print(mp, "fontpart"); break;
4983 case text_part:mp_print(mp, "textpart"); break;
4984 case path_part:mp_print(mp, "pathpart"); break;
4985 case pen_part:mp_print(mp, "penpart"); break;
4986 case dash_part:mp_print(mp, "dashpart"); break;
4987 case sqrt_op:mp_print(mp, "sqrt"); break;
4988 case m_exp_op:mp_print(mp, "mexp"); break;
4989 case m_log_op:mp_print(mp, "mlog"); break;
4990 case sin_d_op:mp_print(mp, "sind"); break;
4991 case cos_d_op:mp_print(mp, "cosd"); break;
4992 case floor_op:mp_print(mp, "floor"); break;
4993 case uniform_deviate:mp_print(mp, "uniformdeviate"); break;
4994 case char_exists_op:mp_print(mp, "charexists"); break;
4995 case font_size:mp_print(mp, "fontsize"); break;
4996 case ll_corner_op:mp_print(mp, "llcorner"); break;
4997 case lr_corner_op:mp_print(mp, "lrcorner"); break;
4998 case ul_corner_op:mp_print(mp, "ulcorner"); break;
4999 case ur_corner_op:mp_print(mp, "urcorner"); break;
5000 case arc_length:mp_print(mp, "arclength"); break;
5001 case angle_op:mp_print(mp, "angle"); break;
5002 case cycle_op:mp_print(mp, "cycle"); break;
5003 case filled_op:mp_print(mp, "filled"); break;
5004 case stroked_op:mp_print(mp, "stroked"); break;
5005 case textual_op:mp_print(mp, "textual"); break;
5006 case clipped_op:mp_print(mp, "clipped"); break;
5007 case bounded_op:mp_print(mp, "bounded"); break;
5008 case plus:mp_print_char(mp, '+'); break;
5009 case minus:mp_print_char(mp, '-'); break;
5010 case times:mp_print_char(mp, '*'); break;
5011 case over:mp_print_char(mp, '/'); break;
5012 case pythag_add:mp_print(mp, "++"); break;
5013 case pythag_sub:mp_print(mp, "+-+"); break;
5014 case or_op:mp_print(mp, "or"); break;
5015 case and_op:mp_print(mp, "and"); break;
5016 case less_than:mp_print_char(mp, '<'); break;
5017 case less_or_equal:mp_print(mp, "<="); break;
5018 case greater_than:mp_print_char(mp, '>'); break;
5019 case greater_or_equal:mp_print(mp, ">="); break;
5020 case equal_to:mp_print_char(mp, '='); break;
5021 case unequal_to:mp_print(mp, "<>"); break;
5022 case concatenate:mp_print(mp, "&"); break;
5023 case rotated_by:mp_print(mp, "rotated"); break;
5024 case slanted_by:mp_print(mp, "slanted"); break;
5025 case scaled_by:mp_print(mp, "scaled"); break;
5026 case shifted_by:mp_print(mp, "shifted"); break;
5027 case transformed_by:mp_print(mp, "transformed"); break;
5028 case x_scaled:mp_print(mp, "xscaled"); break;
5029 case y_scaled:mp_print(mp, "yscaled"); break;
5030 case z_scaled:mp_print(mp, "zscaled"); break;
5031 case in_font:mp_print(mp, "infont"); break;
5032 case intersect:mp_print(mp, "intersectiontimes"); break;
5033 case substring_of:mp_print(mp, "substring"); break;
5034 case subpath_of:mp_print(mp, "subpath"); break;
5035 case direction_time_of:mp_print(mp, "directiontime"); break;
5036 case point_of:mp_print(mp, "point"); break;
5037 case precontrol_of:mp_print(mp, "precontrol"); break;
5038 case postcontrol_of:mp_print(mp, "postcontrol"); break;
5039 case pen_offset_of:mp_print(mp, "penoffset"); break;
5040 case arc_time_of:mp_print(mp, "arctime"); break;
5041 case mp_version:mp_print(mp, "mpversion"); break;
5042 case envelope_of:mp_print(mp, "envelope"); break;
5043 default: mp_print(mp, ".."); break;
5048 @ \MP\ also has a bunch of internal parameters that a user might want to
5049 fuss with. Every such parameter has an identifying code number, defined here.
5052 enum mp_given_internal {
5053 mp_tracing_titles=1, /* show titles online when they appear */
5054 mp_tracing_equations, /* show each variable when it becomes known */
5055 mp_tracing_capsules, /* show capsules too */
5056 mp_tracing_choices, /* show the control points chosen for paths */
5057 mp_tracing_specs, /* show path subdivision prior to filling with polygonal a pen */
5058 mp_tracing_commands, /* show commands and operations before they are performed */
5059 mp_tracing_restores, /* show when a variable or internal is restored */
5060 mp_tracing_macros, /* show macros before they are expanded */
5061 mp_tracing_output, /* show digitized edges as they are output */
5062 mp_tracing_stats, /* show memory usage at end of job */
5063 mp_tracing_lost_chars, /* show characters that aren't \&{infont} */
5064 mp_tracing_online, /* show long diagnostics on terminal and in the log file */
5065 mp_year, /* the current year (e.g., 1984) */
5066 mp_month, /* the current month (e.g., 3 $\equiv$ March) */
5067 mp_day, /* the current day of the month */
5068 mp_time, /* the number of minutes past midnight when this job started */
5069 mp_char_code, /* the number of the next character to be output */
5070 mp_char_ext, /* the extension code of the next character to be output */
5071 mp_char_wd, /* the width of the next character to be output */
5072 mp_char_ht, /* the height of the next character to be output */
5073 mp_char_dp, /* the depth of the next character to be output */
5074 mp_char_ic, /* the italic correction of the next character to be output */
5075 mp_design_size, /* the unit of measure used for |mp_char_wd..mp_char_ic|, in points */
5076 mp_pausing, /* positive to display lines on the terminal before they are read */
5077 mp_showstopping, /* positive to stop after each \&{show} command */
5078 mp_fontmaking, /* positive if font metric output is to be produced */
5079 mp_linejoin, /* as in \ps: 0 for mitered, 1 for round, 2 for beveled */
5080 mp_linecap, /* as in \ps: 0 for butt, 1 for round, 2 for square */
5081 mp_miterlimit, /* controls miter length as in \ps */
5082 mp_warning_check, /* controls error message when variable value is large */
5083 mp_boundary_char, /* the right boundary character for ligatures */
5084 mp_prologues, /* positive to output conforming PostScript using built-in fonts */
5085 mp_true_corners, /* positive to make \&{llcorner} etc. ignore \&{setbounds} */
5086 mp_default_color_model, /* the default color model for unspecified items */
5087 mp_restore_clip_color,
5088 mp_procset, /* wether or not create PostScript command shortcuts */
5089 mp_gtroffmode /* whether the user specified |-troff| on the command line */
5094 @d max_given_internal mp_gtroffmode
5097 scaled *internal; /* the values of internal quantities */
5098 char **int_name; /* their names */
5099 int int_ptr; /* the maximum internal quantity defined so far */
5100 int max_internal; /* current maximum number of internal quantities */
5102 @ @<Option variables@>=
5105 @ @<Allocate or initialize ...@>=
5106 mp->max_internal=2*max_given_internal;
5107 mp->internal = xmalloc ((mp->max_internal+1), sizeof(scaled));
5108 mp->int_name = xmalloc ((mp->max_internal+1), sizeof(char *));
5109 mp->troff_mode=(opt->troff_mode>0 ? true : false);
5111 @ @<Exported function ...@>=
5112 int mp_troff_mode(MP mp);
5115 int mp_troff_mode(MP mp) { return mp->troff_mode; }
5117 @ @<Set initial ...@>=
5118 for (k=0;k<= mp->max_internal; k++ ) {
5120 mp->int_name[k]=NULL;
5122 mp->int_ptr=max_given_internal;
5124 @ The symbolic names for internal quantities are put into \MP's hash table
5125 by using a routine called |primitive|, which will be defined later. Let us
5126 enter them now, so that we don't have to list all those names again
5129 @<Put each of \MP's primitives into the hash table@>=
5130 mp_primitive(mp, "tracingtitles",internal_quantity,mp_tracing_titles);
5131 @:tracingtitles_}{\&{tracingtitles} primitive@>
5132 mp_primitive(mp, "tracingequations",internal_quantity,mp_tracing_equations);
5133 @:mp_tracing_equations_}{\&{tracingequations} primitive@>
5134 mp_primitive(mp, "tracingcapsules",internal_quantity,mp_tracing_capsules);
5135 @:mp_tracing_capsules_}{\&{tracingcapsules} primitive@>
5136 mp_primitive(mp, "tracingchoices",internal_quantity,mp_tracing_choices);
5137 @:mp_tracing_choices_}{\&{tracingchoices} primitive@>
5138 mp_primitive(mp, "tracingspecs",internal_quantity,mp_tracing_specs);
5139 @:mp_tracing_specs_}{\&{tracingspecs} primitive@>
5140 mp_primitive(mp, "tracingcommands",internal_quantity,mp_tracing_commands);
5141 @:mp_tracing_commands_}{\&{tracingcommands} primitive@>
5142 mp_primitive(mp, "tracingrestores",internal_quantity,mp_tracing_restores);
5143 @:mp_tracing_restores_}{\&{tracingrestores} primitive@>
5144 mp_primitive(mp, "tracingmacros",internal_quantity,mp_tracing_macros);
5145 @:mp_tracing_macros_}{\&{tracingmacros} primitive@>
5146 mp_primitive(mp, "tracingoutput",internal_quantity,mp_tracing_output);
5147 @:mp_tracing_output_}{\&{tracingoutput} primitive@>
5148 mp_primitive(mp, "tracingstats",internal_quantity,mp_tracing_stats);
5149 @:mp_tracing_stats_}{\&{tracingstats} primitive@>
5150 mp_primitive(mp, "tracinglostchars",internal_quantity,mp_tracing_lost_chars);
5151 @:mp_tracing_lost_chars_}{\&{tracinglostchars} primitive@>
5152 mp_primitive(mp, "tracingonline",internal_quantity,mp_tracing_online);
5153 @:mp_tracing_online_}{\&{tracingonline} primitive@>
5154 mp_primitive(mp, "year",internal_quantity,mp_year);
5155 @:mp_year_}{\&{year} primitive@>
5156 mp_primitive(mp, "month",internal_quantity,mp_month);
5157 @:mp_month_}{\&{month} primitive@>
5158 mp_primitive(mp, "day",internal_quantity,mp_day);
5159 @:mp_day_}{\&{day} primitive@>
5160 mp_primitive(mp, "time",internal_quantity,mp_time);
5161 @:time_}{\&{time} primitive@>
5162 mp_primitive(mp, "charcode",internal_quantity,mp_char_code);
5163 @:mp_char_code_}{\&{charcode} primitive@>
5164 mp_primitive(mp, "charext",internal_quantity,mp_char_ext);
5165 @:mp_char_ext_}{\&{charext} primitive@>
5166 mp_primitive(mp, "charwd",internal_quantity,mp_char_wd);
5167 @:mp_char_wd_}{\&{charwd} primitive@>
5168 mp_primitive(mp, "charht",internal_quantity,mp_char_ht);
5169 @:mp_char_ht_}{\&{charht} primitive@>
5170 mp_primitive(mp, "chardp",internal_quantity,mp_char_dp);
5171 @:mp_char_dp_}{\&{chardp} primitive@>
5172 mp_primitive(mp, "charic",internal_quantity,mp_char_ic);
5173 @:mp_char_ic_}{\&{charic} primitive@>
5174 mp_primitive(mp, "designsize",internal_quantity,mp_design_size);
5175 @:mp_design_size_}{\&{designsize} primitive@>
5176 mp_primitive(mp, "pausing",internal_quantity,mp_pausing);
5177 @:mp_pausing_}{\&{pausing} primitive@>
5178 mp_primitive(mp, "showstopping",internal_quantity,mp_showstopping);
5179 @:mp_showstopping_}{\&{showstopping} primitive@>
5180 mp_primitive(mp, "fontmaking",internal_quantity,mp_fontmaking);
5181 @:mp_fontmaking_}{\&{fontmaking} primitive@>
5182 mp_primitive(mp, "linejoin",internal_quantity,mp_linejoin);
5183 @:mp_linejoin_}{\&{linejoin} primitive@>
5184 mp_primitive(mp, "linecap",internal_quantity,mp_linecap);
5185 @:mp_linecap_}{\&{linecap} primitive@>
5186 mp_primitive(mp, "miterlimit",internal_quantity,mp_miterlimit);
5187 @:mp_miterlimit_}{\&{miterlimit} primitive@>
5188 mp_primitive(mp, "warningcheck",internal_quantity,mp_warning_check);
5189 @:mp_warning_check_}{\&{warningcheck} primitive@>
5190 mp_primitive(mp, "boundarychar",internal_quantity,mp_boundary_char);
5191 @:mp_boundary_char_}{\&{boundarychar} primitive@>
5192 mp_primitive(mp, "prologues",internal_quantity,mp_prologues);
5193 @:mp_prologues_}{\&{prologues} primitive@>
5194 mp_primitive(mp, "truecorners",internal_quantity,mp_true_corners);
5195 @:mp_true_corners_}{\&{truecorners} primitive@>
5196 mp_primitive(mp, "mpprocset",internal_quantity,mp_procset);
5197 @:mp_procset_}{\&{mpprocset} primitive@>
5198 mp_primitive(mp, "troffmode",internal_quantity,mp_gtroffmode);
5199 @:troffmode_}{\&{troffmode} primitive@>
5200 mp_primitive(mp, "defaultcolormodel",internal_quantity,mp_default_color_model);
5201 @:mp_default_color_model_}{\&{defaultcolormodel} primitive@>
5202 mp_primitive(mp, "restoreclipcolor",internal_quantity,mp_restore_clip_color);
5203 @:mp_restore_clip_color_}{\&{restoreclipcolor} primitive@>
5205 @ Colors can be specified in four color models. In the special
5206 case of |no_model|, MetaPost does not output any color operator to
5207 the postscript output.
5209 Note: these values are passed directly on to |with_option|. This only
5210 works because the other possible values passed to |with_option| are
5211 8 and 10 respectively (from |with_pen| and |with_picture|).
5213 There is a first state, that is only used for |gs_colormodel|. It flags
5214 the fact that there has not been any kind of color specification by
5215 the user so far in the game.
5218 enum mp_color_model {
5223 mp_uninitialized_model=9
5227 @ @<Initialize table entries (done by \.{INIMP} only)@>=
5228 mp->internal[mp_default_color_model]=(mp_rgb_model*unity);
5229 mp->internal[mp_restore_clip_color]=unity;
5231 @ Well, we do have to list the names one more time, for use in symbolic
5234 @<Initialize table...@>=
5235 mp->int_name[mp_tracing_titles]=xstrdup("tracingtitles");
5236 mp->int_name[mp_tracing_equations]=xstrdup("tracingequations");
5237 mp->int_name[mp_tracing_capsules]=xstrdup("tracingcapsules");
5238 mp->int_name[mp_tracing_choices]=xstrdup("tracingchoices");
5239 mp->int_name[mp_tracing_specs]=xstrdup("tracingspecs");
5240 mp->int_name[mp_tracing_commands]=xstrdup("tracingcommands");
5241 mp->int_name[mp_tracing_restores]=xstrdup("tracingrestores");
5242 mp->int_name[mp_tracing_macros]=xstrdup("tracingmacros");
5243 mp->int_name[mp_tracing_output]=xstrdup("tracingoutput");
5244 mp->int_name[mp_tracing_stats]=xstrdup("tracingstats");
5245 mp->int_name[mp_tracing_lost_chars]=xstrdup("tracinglostchars");
5246 mp->int_name[mp_tracing_online]=xstrdup("tracingonline");
5247 mp->int_name[mp_year]=xstrdup("year");
5248 mp->int_name[mp_month]=xstrdup("month");
5249 mp->int_name[mp_day]=xstrdup("day");
5250 mp->int_name[mp_time]=xstrdup("time");
5251 mp->int_name[mp_char_code]=xstrdup("charcode");
5252 mp->int_name[mp_char_ext]=xstrdup("charext");
5253 mp->int_name[mp_char_wd]=xstrdup("charwd");
5254 mp->int_name[mp_char_ht]=xstrdup("charht");
5255 mp->int_name[mp_char_dp]=xstrdup("chardp");
5256 mp->int_name[mp_char_ic]=xstrdup("charic");
5257 mp->int_name[mp_design_size]=xstrdup("designsize");
5258 mp->int_name[mp_pausing]=xstrdup("pausing");
5259 mp->int_name[mp_showstopping]=xstrdup("showstopping");
5260 mp->int_name[mp_fontmaking]=xstrdup("fontmaking");
5261 mp->int_name[mp_linejoin]=xstrdup("linejoin");
5262 mp->int_name[mp_linecap]=xstrdup("linecap");
5263 mp->int_name[mp_miterlimit]=xstrdup("miterlimit");
5264 mp->int_name[mp_warning_check]=xstrdup("warningcheck");
5265 mp->int_name[mp_boundary_char]=xstrdup("boundarychar");
5266 mp->int_name[mp_prologues]=xstrdup("prologues");
5267 mp->int_name[mp_true_corners]=xstrdup("truecorners");
5268 mp->int_name[mp_default_color_model]=xstrdup("defaultcolormodel");
5269 mp->int_name[mp_procset]=xstrdup("mpprocset");
5270 mp->int_name[mp_gtroffmode]=xstrdup("troffmode");
5271 mp->int_name[mp_restore_clip_color]=xstrdup("restoreclipcolor");
5273 @ The following procedure, which is called just before \MP\ initializes its
5274 input and output, establishes the initial values of the date and time.
5275 @^system dependencies@>
5277 Note that the values are |scaled| integers. Hence \MP\ can no longer
5278 be used after the year 32767.
5281 void mp_fix_date_and_time (MP mp) {
5282 time_t aclock = time ((time_t *) 0);
5283 struct tm *tmptr = localtime (&aclock);
5284 mp->internal[mp_time]=
5285 (tmptr->tm_hour*60+tmptr->tm_min)*unity; /* minutes since midnight */
5286 mp->internal[mp_day]=(tmptr->tm_mday)*unity; /* fourth day of the month */
5287 mp->internal[mp_month]=(tmptr->tm_mon+1)*unity; /* seventh month of the year */
5288 mp->internal[mp_year]=(tmptr->tm_year+1900)*unity; /* Anno Domini */
5292 void mp_fix_date_and_time (MP mp) ;
5294 @ \MP\ is occasionally supposed to print diagnostic information that
5295 goes only into the transcript file, unless |mp_tracing_online| is positive.
5296 Now that we have defined |mp_tracing_online| we can define
5297 two routines that adjust the destination of print commands:
5300 void mp_begin_diagnostic (MP mp) ;
5301 void mp_end_diagnostic (MP mp,boolean blank_line);
5302 void mp_print_diagnostic (MP mp, const char *s, const char *t, boolean nuline) ;
5304 @ @<Basic printing...@>=
5305 @<Declare a function called |true_line|@>
5306 void mp_begin_diagnostic (MP mp) { /* prepare to do some tracing */
5307 mp->old_setting=mp->selector;
5308 if ((mp->internal[mp_tracing_online]<=0)&&(mp->selector==term_and_log)){
5310 if ( mp->history==mp_spotless ) mp->history=mp_warning_issued;
5314 void mp_end_diagnostic (MP mp,boolean blank_line) {
5315 /* restore proper conditions after tracing */
5316 mp_print_nl(mp, "");
5317 if ( blank_line ) mp_print_ln(mp);
5318 mp->selector=mp->old_setting;
5324 unsigned int old_setting;
5326 @ We will occasionally use |begin_diagnostic| in connection with line-number
5327 printing, as follows. (The parameter |s| is typically |"Path"| or
5328 |"Cycle spec"|, etc.)
5330 @<Basic printing...@>=
5331 void mp_print_diagnostic (MP mp, const char *s, const char *t, boolean nuline) {
5332 mp_begin_diagnostic(mp);
5333 if ( nuline ) mp_print_nl(mp, s); else mp_print(mp, s);
5334 mp_print(mp, " at line ");
5335 mp_print_int(mp, mp_true_line(mp));
5336 mp_print(mp, t); mp_print_char(mp, ':');
5339 @ The 256 |ASCII_code| characters are grouped into classes by means of
5340 the |char_class| table. Individual class numbers have no semantic
5341 or syntactic significance, except in a few instances defined here.
5342 There's also |max_class|, which can be used as a basis for additional
5343 class numbers in nonstandard extensions of \MP.
5345 @d digit_class 0 /* the class number of \.{0123456789} */
5346 @d period_class 1 /* the class number of `\..' */
5347 @d space_class 2 /* the class number of spaces and nonstandard characters */
5348 @d percent_class 3 /* the class number of `\.\%' */
5349 @d string_class 4 /* the class number of `\."' */
5350 @d right_paren_class 8 /* the class number of `\.)' */
5351 @d isolated_classes 5: case 6: case 7: case 8 /* characters that make length-one tokens only */
5352 @d letter_class 9 /* letters and the underline character */
5353 @d left_bracket_class 17 /* `\.[' */
5354 @d right_bracket_class 18 /* `\.]' */
5355 @d invalid_class 20 /* bad character in the input */
5356 @d max_class 20 /* the largest class number */
5359 int char_class[256]; /* the class numbers */
5361 @ If changes are made to accommodate non-ASCII character sets, they should
5362 follow the guidelines in Appendix~C of {\sl The {\logos METAFONT\/}book}.
5363 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
5364 @^system dependencies@>
5366 @<Set initial ...@>=
5367 for (k='0';k<='9';k++)
5368 mp->char_class[k]=digit_class;
5369 mp->char_class['.']=period_class;
5370 mp->char_class[' ']=space_class;
5371 mp->char_class['%']=percent_class;
5372 mp->char_class['"']=string_class;
5373 mp->char_class[',']=5;
5374 mp->char_class[';']=6;
5375 mp->char_class['(']=7;
5376 mp->char_class[')']=right_paren_class;
5377 for (k='A';k<= 'Z';k++ )
5378 mp->char_class[k]=letter_class;
5379 for (k='a';k<='z';k++)
5380 mp->char_class[k]=letter_class;
5381 mp->char_class['_']=letter_class;
5382 mp->char_class['<']=10;
5383 mp->char_class['=']=10;
5384 mp->char_class['>']=10;
5385 mp->char_class[':']=10;
5386 mp->char_class['|']=10;
5387 mp->char_class['`']=11;
5388 mp->char_class['\'']=11;
5389 mp->char_class['+']=12;
5390 mp->char_class['-']=12;
5391 mp->char_class['/']=13;
5392 mp->char_class['*']=13;
5393 mp->char_class['\\']=13;
5394 mp->char_class['!']=14;
5395 mp->char_class['?']=14;
5396 mp->char_class['#']=15;
5397 mp->char_class['&']=15;
5398 mp->char_class['@@']=15;
5399 mp->char_class['$']=15;
5400 mp->char_class['^']=16;
5401 mp->char_class['~']=16;
5402 mp->char_class['[']=left_bracket_class;
5403 mp->char_class[']']=right_bracket_class;
5404 mp->char_class['{']=19;
5405 mp->char_class['}']=19;
5407 mp->char_class[k]=invalid_class;
5408 mp->char_class['\t']=space_class;
5409 mp->char_class['\f']=space_class;
5410 for (k=127;k<=255;k++)
5411 mp->char_class[k]=invalid_class;
5413 @* \[13] The hash table.
5414 Symbolic tokens are stored and retrieved by means of a fairly standard hash
5415 table algorithm called the method of ``coalescing lists'' (cf.\ Algorithm 6.4C
5416 in {\sl The Art of Computer Programming\/}). Once a symbolic token enters the
5417 table, it is never removed.
5419 The actual sequence of characters forming a symbolic token is
5420 stored in the |str_pool| array together with all the other strings. An
5421 auxiliary array |hash| consists of items with two halfword fields per
5422 word. The first of these, called |next(p)|, points to the next identifier
5423 belonging to the same coalesced list as the identifier corresponding to~|p|;
5424 and the other, called |text(p)|, points to the |str_start| entry for
5425 |p|'s identifier. If position~|p| of the hash table is empty, we have
5426 |text(p)=0|; if position |p| is either empty or the end of a coalesced
5427 hash list, we have |next(p)=0|.
5429 An auxiliary pointer variable called |hash_used| is maintained in such a
5430 way that all locations |p>=hash_used| are nonempty. The global variable
5431 |st_count| tells how many symbolic tokens have been defined, if statistics
5434 The first 256 locations of |hash| are reserved for symbols of length one.
5436 There's a parallel array called |eqtb| that contains the current equivalent
5437 values of each symbolic token. The entries of this array consist of
5438 two halfwords called |eq_type| (a command code) and |equiv| (a secondary
5439 piece of information that qualifies the |eq_type|).
5441 @d next(A) mp->hash[(A)].lh /* link for coalesced lists */
5442 @d text(A) mp->hash[(A)].rh /* string number for symbolic token name */
5443 @d eq_type(A) mp->eqtb[(A)].lh /* the current ``meaning'' of a symbolic token */
5444 @d equiv(A) mp->eqtb[(A)].rh /* parametric part of a token's meaning */
5445 @d hash_base 257 /* hashing actually starts here */
5446 @d hash_is_full (mp->hash_used==hash_base) /* are all positions occupied? */
5449 pointer hash_used; /* allocation pointer for |hash| */
5450 integer st_count; /* total number of known identifiers */
5452 @ Certain entries in the hash table are ``frozen'' and not redefinable,
5453 since they are used in error recovery.
5455 @d hash_top (hash_base+mp->hash_size) /* the first location of the frozen area */
5456 @d frozen_inaccessible hash_top /* |hash| location to protect the frozen area */
5457 @d frozen_repeat_loop (hash_top+1) /* |hash| location of a loop-repeat token */
5458 @d frozen_right_delimiter (hash_top+2) /* |hash| location of a permanent `\.)' */
5459 @d frozen_left_bracket (hash_top+3) /* |hash| location of a permanent `\.[' */
5460 @d frozen_slash (hash_top+4) /* |hash| location of a permanent `\./' */
5461 @d frozen_colon (hash_top+5) /* |hash| location of a permanent `\.:' */
5462 @d frozen_semicolon (hash_top+6) /* |hash| location of a permanent `\.;' */
5463 @d frozen_end_for (hash_top+7) /* |hash| location of a permanent \&{endfor} */
5464 @d frozen_end_def (hash_top+8) /* |hash| location of a permanent \&{enddef} */
5465 @d frozen_fi (hash_top+9) /* |hash| location of a permanent \&{fi} */
5466 @d frozen_end_group (hash_top+10) /* |hash| location of a permanent `\.{endgroup}' */
5467 @d frozen_etex (hash_top+11) /* |hash| location of a permanent \&{etex} */
5468 @d frozen_mpx_break (hash_top+12) /* |hash| location of a permanent \&{mpxbreak} */
5469 @d frozen_bad_vardef (hash_top+13) /* |hash| location of `\.{a bad variable}' */
5470 @d frozen_undefined (hash_top+14) /* |hash| location that never gets defined */
5471 @d hash_end (hash_top+14) /* the actual size of the |hash| and |eqtb| arrays */
5474 two_halves *hash; /* the hash table */
5475 two_halves *eqtb; /* the equivalents */
5477 @ @<Allocate or initialize ...@>=
5478 mp->hash = xmalloc((hash_end+1),sizeof(two_halves));
5479 mp->eqtb = xmalloc((hash_end+1),sizeof(two_halves));
5481 @ @<Dealloc variables@>=
5486 next(1)=0; text(1)=0; eq_type(1)=tag_token; equiv(1)=null;
5487 for (k=2;k<=hash_end;k++) {
5488 mp->hash[k]=mp->hash[1]; mp->eqtb[k]=mp->eqtb[1];
5491 @ @<Initialize table entries...@>=
5492 mp->hash_used=frozen_inaccessible; /* nothing is used */
5494 text(frozen_bad_vardef)=intern("a bad variable");
5495 text(frozen_etex)=intern("etex");
5496 text(frozen_mpx_break)=intern("mpxbreak");
5497 text(frozen_fi)=intern("fi");
5498 text(frozen_end_group)=intern("endgroup");
5499 text(frozen_end_def)=intern("enddef");
5500 text(frozen_end_for)=intern("endfor");
5501 text(frozen_semicolon)=intern(";");
5502 text(frozen_colon)=intern(":");
5503 text(frozen_slash)=intern("/");
5504 text(frozen_left_bracket)=intern("[");
5505 text(frozen_right_delimiter)=intern(")");
5506 text(frozen_inaccessible)=intern(" INACCESSIBLE");
5507 eq_type(frozen_right_delimiter)=right_delimiter;
5509 @ @<Check the ``constant'' values...@>=
5510 if ( hash_end+mp->max_internal>max_halfword ) mp->bad=17;
5512 @ Here is the subroutine that searches the hash table for an identifier
5513 that matches a given string of length~|l| appearing in |buffer[j..
5514 (j+l-1)]|. If the identifier is not found, it is inserted; hence it
5515 will always be found, and the corresponding hash table address
5519 pointer mp_id_lookup (MP mp,integer j, integer l) { /* search the hash table */
5520 integer h; /* hash code */
5521 pointer p; /* index in |hash| array */
5522 pointer k; /* index in |buffer| array */
5524 @<Treat special case of length 1 and |break|@>;
5526 @<Compute the hash code |h|@>;
5527 p=h+hash_base; /* we start searching here; note that |0<=h<hash_prime| */
5529 if (text(p)>0 && length(text(p))==l && mp_str_eq_buf(mp, text(p),j))
5532 @<Insert a new symbolic token after |p|, then
5533 make |p| point to it and |break|@>;
5540 @ @<Treat special case of length 1...@>=
5541 p=mp->buffer[j]+1; text(p)=p-1; return p;
5544 @ @<Insert a new symbolic...@>=
5549 mp_overflow(mp, "hash size",mp->hash_size);
5550 @:MetaPost capacity exceeded hash size}{\quad hash size@>
5551 decr(mp->hash_used);
5552 } while (text(mp->hash_used)!=0); /* search for an empty location in |hash| */
5553 next(p)=mp->hash_used;
5557 for (k=j;k<=j+l-1;k++) {
5558 append_char(mp->buffer[k]);
5560 text(p)=mp_make_string(mp);
5561 mp->str_ref[text(p)]=max_str_ref;
5567 @ The value of |hash_prime| should be roughly 85\pct! of |hash_size|, and it
5568 should be a prime number. The theory of hashing tells us to expect fewer
5569 than two table probes, on the average, when the search is successful.
5570 [See J.~S. Vitter, {\sl Journal of the ACM\/ \bf30} (1983), 231--258.]
5571 @^Vitter, Jeffrey Scott@>
5573 @<Compute the hash code |h|@>=
5575 for (k=j+1;k<=j+l-1;k++){
5576 h=h+h+mp->buffer[k];
5577 while ( h>=mp->hash_prime ) h=h-mp->hash_prime;
5580 @ @<Search |eqtb| for equivalents equal to |p|@>=
5581 for (q=1;q<=hash_end;q++) {
5582 if ( equiv(q)==p ) {
5583 mp_print_nl(mp, "EQUIV(");
5584 mp_print_int(mp, q);
5585 mp_print_char(mp, ')');
5589 @ We need to put \MP's ``primitive'' symbolic tokens into the hash
5590 table, together with their command code (which will be the |eq_type|)
5591 and an operand (which will be the |equiv|). The |primitive| procedure
5592 does this, in a way that no \MP\ user can. The global value |cur_sym|
5593 contains the new |eqtb| pointer after |primitive| has acted.
5596 void mp_primitive (MP mp, const char *ss, halfword c, halfword o) {
5597 pool_pointer k; /* index into |str_pool| */
5598 small_number j; /* index into |buffer| */
5599 small_number l; /* length of the string */
5602 k=mp->str_start[s]; l=str_stop(s)-k;
5603 /* we will move |s| into the (empty) |buffer| */
5604 for (j=0;j<=l-1;j++) {
5605 mp->buffer[j]=mp->str_pool[k+j];
5607 mp->cur_sym=mp_id_lookup(mp, 0,l);
5608 if ( s>=256 ) { /* we don't want to have the string twice */
5609 mp_flush_string(mp, text(mp->cur_sym)); text(mp->cur_sym)=s;
5611 eq_type(mp->cur_sym)=c;
5612 equiv(mp->cur_sym)=o;
5616 @ Many of \MP's primitives need no |equiv|, since they are identifiable
5617 by their |eq_type| alone. These primitives are loaded into the hash table
5620 @<Put each of \MP's primitives into the hash table@>=
5621 mp_primitive(mp, "..",path_join,0);
5622 @:.._}{\.{..} primitive@>
5623 mp_primitive(mp, "[",left_bracket,0); mp->eqtb[frozen_left_bracket]=mp->eqtb[mp->cur_sym];
5624 @:[ }{\.{[} primitive@>
5625 mp_primitive(mp, "]",right_bracket,0);
5626 @:] }{\.{]} primitive@>
5627 mp_primitive(mp, "}",right_brace,0);
5628 @:]]}{\.{\char`\}} primitive@>
5629 mp_primitive(mp, "{",left_brace,0);
5630 @:][}{\.{\char`\{} primitive@>
5631 mp_primitive(mp, ":",colon,0); mp->eqtb[frozen_colon]=mp->eqtb[mp->cur_sym];
5632 @:: }{\.{:} primitive@>
5633 mp_primitive(mp, "::",double_colon,0);
5634 @::: }{\.{::} primitive@>
5635 mp_primitive(mp, "||:",bchar_label,0);
5636 @:::: }{\.{\char'174\char'174:} primitive@>
5637 mp_primitive(mp, ":=",assignment,0);
5638 @::=_}{\.{:=} primitive@>
5639 mp_primitive(mp, ",",comma,0);
5640 @:, }{\., primitive@>
5641 mp_primitive(mp, ";",semicolon,0); mp->eqtb[frozen_semicolon]=mp->eqtb[mp->cur_sym];
5642 @:; }{\.; primitive@>
5643 mp_primitive(mp, "\\",relax,0);
5644 @:]]\\}{\.{\char`\\} primitive@>
5646 mp_primitive(mp, "addto",add_to_command,0);
5647 @:add_to_}{\&{addto} primitive@>
5648 mp_primitive(mp, "atleast",at_least,0);
5649 @:at_least_}{\&{atleast} primitive@>
5650 mp_primitive(mp, "begingroup",begin_group,0); mp->bg_loc=mp->cur_sym;
5651 @:begin_group_}{\&{begingroup} primitive@>
5652 mp_primitive(mp, "controls",controls,0);
5653 @:controls_}{\&{controls} primitive@>
5654 mp_primitive(mp, "curl",curl_command,0);
5655 @:curl_}{\&{curl} primitive@>
5656 mp_primitive(mp, "delimiters",delimiters,0);
5657 @:delimiters_}{\&{delimiters} primitive@>
5658 mp_primitive(mp, "endgroup",end_group,0);
5659 mp->eqtb[frozen_end_group]=mp->eqtb[mp->cur_sym]; mp->eg_loc=mp->cur_sym;
5660 @:endgroup_}{\&{endgroup} primitive@>
5661 mp_primitive(mp, "everyjob",every_job_command,0);
5662 @:every_job_}{\&{everyjob} primitive@>
5663 mp_primitive(mp, "exitif",exit_test,0);
5664 @:exit_if_}{\&{exitif} primitive@>
5665 mp_primitive(mp, "expandafter",expand_after,0);
5666 @:expand_after_}{\&{expandafter} primitive@>
5667 mp_primitive(mp, "interim",interim_command,0);
5668 @:interim_}{\&{interim} primitive@>
5669 mp_primitive(mp, "let",let_command,0);
5670 @:let_}{\&{let} primitive@>
5671 mp_primitive(mp, "newinternal",new_internal,0);
5672 @:new_internal_}{\&{newinternal} primitive@>
5673 mp_primitive(mp, "of",of_token,0);
5674 @:of_}{\&{of} primitive@>
5675 mp_primitive(mp, "randomseed",mp_random_seed,0);
5676 @:mp_random_seed_}{\&{randomseed} primitive@>
5677 mp_primitive(mp, "save",save_command,0);
5678 @:save_}{\&{save} primitive@>
5679 mp_primitive(mp, "scantokens",scan_tokens,0);
5680 @:scan_tokens_}{\&{scantokens} primitive@>
5681 mp_primitive(mp, "shipout",ship_out_command,0);
5682 @:ship_out_}{\&{shipout} primitive@>
5683 mp_primitive(mp, "skipto",skip_to,0);
5684 @:skip_to_}{\&{skipto} primitive@>
5685 mp_primitive(mp, "special",special_command,0);
5686 @:special}{\&{special} primitive@>
5687 mp_primitive(mp, "fontmapfile",special_command,1);
5688 @:fontmapfile}{\&{fontmapfile} primitive@>
5689 mp_primitive(mp, "fontmapline",special_command,2);
5690 @:fontmapline}{\&{fontmapline} primitive@>
5691 mp_primitive(mp, "step",step_token,0);
5692 @:step_}{\&{step} primitive@>
5693 mp_primitive(mp, "str",str_op,0);
5694 @:str_}{\&{str} primitive@>
5695 mp_primitive(mp, "tension",tension,0);
5696 @:tension_}{\&{tension} primitive@>
5697 mp_primitive(mp, "to",to_token,0);
5698 @:to_}{\&{to} primitive@>
5699 mp_primitive(mp, "until",until_token,0);
5700 @:until_}{\&{until} primitive@>
5701 mp_primitive(mp, "within",within_token,0);
5702 @:within_}{\&{within} primitive@>
5703 mp_primitive(mp, "write",write_command,0);
5704 @:write_}{\&{write} primitive@>
5706 @ Each primitive has a corresponding inverse, so that it is possible to
5707 display the cryptic numeric contents of |eqtb| in symbolic form.
5708 Every call of |primitive| in this program is therefore accompanied by some
5709 straightforward code that forms part of the |print_cmd_mod| routine
5712 @<Cases of |print_cmd_mod| for symbolic printing of primitives@>=
5713 case add_to_command:mp_print(mp, "addto"); break;
5714 case assignment:mp_print(mp, ":="); break;
5715 case at_least:mp_print(mp, "atleast"); break;
5716 case bchar_label:mp_print(mp, "||:"); break;
5717 case begin_group:mp_print(mp, "begingroup"); break;
5718 case colon:mp_print(mp, ":"); break;
5719 case comma:mp_print(mp, ","); break;
5720 case controls:mp_print(mp, "controls"); break;
5721 case curl_command:mp_print(mp, "curl"); break;
5722 case delimiters:mp_print(mp, "delimiters"); break;
5723 case double_colon:mp_print(mp, "::"); break;
5724 case end_group:mp_print(mp, "endgroup"); break;
5725 case every_job_command:mp_print(mp, "everyjob"); break;
5726 case exit_test:mp_print(mp, "exitif"); break;
5727 case expand_after:mp_print(mp, "expandafter"); break;
5728 case interim_command:mp_print(mp, "interim"); break;
5729 case left_brace:mp_print(mp, "{"); break;
5730 case left_bracket:mp_print(mp, "["); break;
5731 case let_command:mp_print(mp, "let"); break;
5732 case new_internal:mp_print(mp, "newinternal"); break;
5733 case of_token:mp_print(mp, "of"); break;
5734 case path_join:mp_print(mp, ".."); break;
5735 case mp_random_seed:mp_print(mp, "randomseed"); break;
5736 case relax:mp_print_char(mp, '\\'); break;
5737 case right_brace:mp_print(mp, "}"); break;
5738 case right_bracket:mp_print(mp, "]"); break;
5739 case save_command:mp_print(mp, "save"); break;
5740 case scan_tokens:mp_print(mp, "scantokens"); break;
5741 case semicolon:mp_print(mp, ";"); break;
5742 case ship_out_command:mp_print(mp, "shipout"); break;
5743 case skip_to:mp_print(mp, "skipto"); break;
5744 case special_command: if ( m==2 ) mp_print(mp, "fontmapline"); else
5745 if ( m==1 ) mp_print(mp, "fontmapfile"); else
5746 mp_print(mp, "special"); break;
5747 case step_token:mp_print(mp, "step"); break;
5748 case str_op:mp_print(mp, "str"); break;
5749 case tension:mp_print(mp, "tension"); break;
5750 case to_token:mp_print(mp, "to"); break;
5751 case until_token:mp_print(mp, "until"); break;
5752 case within_token:mp_print(mp, "within"); break;
5753 case write_command:mp_print(mp, "write"); break;
5755 @ We will deal with the other primitives later, at some point in the program
5756 where their |eq_type| and |equiv| values are more meaningful. For example,
5757 the primitives for macro definitions will be loaded when we consider the
5758 routines that define macros.
5759 It is easy to find where each particular
5760 primitive was treated by looking in the index at the end; for example, the
5761 section where |"def"| entered |eqtb| is listed under `\&{def} primitive'.
5763 @* \[14] Token lists.
5764 A \MP\ token is either symbolic or numeric or a string, or it denotes
5765 a macro parameter or capsule; so there are five corresponding ways to encode it
5767 internally: (1)~A symbolic token whose hash code is~|p|
5768 is represented by the number |p|, in the |info| field of a single-word
5769 node in~|mem|. (2)~A numeric token whose |scaled| value is~|v| is
5770 represented in a two-word node of~|mem|; the |type| field is |known|,
5771 the |name_type| field is |token|, and the |value| field holds~|v|.
5772 The fact that this token appears in a two-word node rather than a
5773 one-word node is, of course, clear from the node address.
5774 (3)~A string token is also represented in a two-word node; the |type|
5775 field is |mp_string_type|, the |name_type| field is |token|, and the
5776 |value| field holds the corresponding |str_number|. (4)~Capsules have
5777 |name_type=capsule|, and their |type| and |value| fields represent
5778 arbitrary values (in ways to be explained later). (5)~Macro parameters
5779 are like symbolic tokens in that they appear in |info| fields of
5780 one-word nodes. The $k$th parameter is represented by |expr_base+k| if it
5781 is of type \&{expr}, or by |suffix_base+k| if it is of type \&{suffix}, or
5782 by |text_base+k| if it is of type \&{text}. (Here |0<=k<param_size|.)
5783 Actual values of these parameters are kept in a separate stack, as we will
5784 see later. The constants |expr_base|, |suffix_base|, and |text_base| are,
5785 of course, chosen so that there will be no confusion between symbolic
5786 tokens and parameters of various types.
5789 the `\\{type}' field of a node has nothing to do with ``type'' in a
5790 printer's sense. It's curious that the same word is used in such different ways.
5792 @d type(A) mp->mem[(A)].hh.b0 /* identifies what kind of value this is */
5793 @d name_type(A) mp->mem[(A)].hh.b1 /* a clue to the name of this value */
5794 @d token_node_size 2 /* the number of words in a large token node */
5795 @d value_loc(A) ((A)+1) /* the word that contains the |value| field */
5796 @d value(A) mp->mem[value_loc((A))].cint /* the value stored in a large token node */
5797 @d expr_base (hash_end+1) /* code for the zeroth \&{expr} parameter */
5798 @d suffix_base (expr_base+mp->param_size) /* code for the zeroth \&{suffix} parameter */
5799 @d text_base (suffix_base+mp->param_size) /* code for the zeroth \&{text} parameter */
5801 @<Check the ``constant''...@>=
5802 if ( text_base+mp->param_size>max_halfword ) mp->bad=18;
5804 @ We have set aside a two word node beginning at |null| so that we can have
5805 |value(null)=0|. We will make use of this coincidence later.
5807 @<Initialize table entries...@>=
5808 link(null)=null; value(null)=0;
5810 @ A numeric token is created by the following trivial routine.
5813 pointer mp_new_num_tok (MP mp,scaled v) {
5814 pointer p; /* the new node */
5815 p=mp_get_node(mp, token_node_size); value(p)=v;
5816 type(p)=mp_known; name_type(p)=mp_token;
5820 @ A token list is a singly linked list of nodes in |mem|, where
5821 each node contains a token and a link. Here's a subroutine that gets rid
5822 of a token list when it is no longer needed.
5824 @c void mp_flush_token_list (MP mp,pointer p) {
5825 pointer q; /* the node being recycled */
5828 if ( q>=mp->hi_mem_min ) {
5832 case mp_vacuous: case mp_boolean_type: case mp_known:
5834 case mp_string_type:
5835 delete_str_ref(value(q));
5837 case unknown_types: case mp_pen_type: case mp_path_type:
5838 case mp_picture_type: case mp_pair_type: case mp_color_type:
5839 case mp_cmykcolor_type: case mp_transform_type: case mp_dependent:
5840 case mp_proto_dependent: case mp_independent:
5841 mp_recycle_value(mp,q);
5843 default: mp_confusion(mp, "token");
5844 @:this can't happen token}{\quad token@>
5846 mp_free_node(mp, q,token_node_size);
5851 @ The procedure |show_token_list|, which prints a symbolic form of
5852 the token list that starts at a given node |p|, illustrates these
5853 conventions. The token list being displayed should not begin with a reference
5854 count. However, the procedure is intended to be fairly robust, so that if the
5855 memory links are awry or if |p| is not really a pointer to a token list,
5856 almost nothing catastrophic can happen.
5858 An additional parameter |q| is also given; this parameter is either null
5859 or it points to a node in the token list where a certain magic computation
5860 takes place that will be explained later. (Basically, |q| is non-null when
5861 we are printing the two-line context information at the time of an error
5862 message; |q| marks the place corresponding to where the second line
5865 The generation will stop, and `\.{\char`\ ETC.}' will be printed, if the length
5866 of printing exceeds a given limit~|l|; the length of printing upon entry is
5867 assumed to be a given amount called |null_tally|. (Note that
5868 |show_token_list| sometimes uses itself recursively to print
5869 variable names within a capsule.)
5872 Unusual entries are printed in the form of all-caps tokens
5873 preceded by a space, e.g., `\.{\char`\ BAD}'.
5875 @<Declare the procedure called |show_token_list|@>=
5876 void mp_show_token_list (MP mp, integer p, integer q, integer l,
5877 integer null_tally) ;
5880 void mp_show_token_list (MP mp, integer p, integer q, integer l,
5881 integer null_tally) {
5882 small_number class,c; /* the |char_class| of previous and new tokens */
5883 integer r,v; /* temporary registers */
5884 class=percent_class;
5885 mp->tally=null_tally;
5886 while ( (p!=null) && (mp->tally<l) ) {
5888 @<Do magic computation@>;
5889 @<Display token |p| and set |c| to its class;
5890 but |return| if there are problems@>;
5894 mp_print(mp, " ETC.");
5899 @ @<Display token |p| and set |c| to its class...@>=
5900 c=letter_class; /* the default */
5901 if ( (p<0)||(p>mp->mem_end) ) {
5902 mp_print(mp, " CLOBBERED"); return;
5905 if ( p<mp->hi_mem_min ) {
5906 @<Display two-word token@>;
5909 if ( r>=expr_base ) {
5910 @<Display a parameter token@>;
5914 @<Display a collective subscript@>
5916 mp_print(mp, " IMPOSSIBLE");
5921 if ( (r<0)||(r>mp->max_str_ptr) ) {
5922 mp_print(mp, " NONEXISTENT");
5925 @<Print string |r| as a symbolic token
5926 and set |c| to its class@>;
5932 @ @<Display two-word token@>=
5933 if ( name_type(p)==mp_token ) {
5934 if ( type(p)==mp_known ) {
5935 @<Display a numeric token@>;
5936 } else if ( type(p)!=mp_string_type ) {
5937 mp_print(mp, " BAD");
5940 mp_print_char(mp, '"'); mp_print_str(mp, value(p)); mp_print_char(mp, '"');
5943 } else if ((name_type(p)!=mp_capsule)||(type(p)<mp_vacuous)||(type(p)>mp_independent) ) {
5944 mp_print(mp, " BAD");
5946 mp_print_capsule(mp,p); c=right_paren_class;
5949 @ @<Display a numeric token@>=
5950 if ( class==digit_class )
5951 mp_print_char(mp, ' ');
5954 if ( class==left_bracket_class )
5955 mp_print_char(mp, ' ');
5956 mp_print_char(mp, '['); mp_print_scaled(mp, v); mp_print_char(mp, ']');
5957 c=right_bracket_class;
5959 mp_print_scaled(mp, v); c=digit_class;
5963 @ Strictly speaking, a genuine token will never have |info(p)=0|.
5964 But we will see later (in the |print_variable_name| routine) that
5965 it is convenient to let |info(p)=0| stand for `\.{[]}'.
5967 @<Display a collective subscript@>=
5969 if ( class==left_bracket_class )
5970 mp_print_char(mp, ' ');
5971 mp_print(mp, "[]"); c=right_bracket_class;
5974 @ @<Display a parameter token@>=
5976 if ( r<suffix_base ) {
5977 mp_print(mp, "(EXPR"); r=r-(expr_base);
5979 } else if ( r<text_base ) {
5980 mp_print(mp, "(SUFFIX"); r=r-(suffix_base);
5983 mp_print(mp, "(TEXT"); r=r-(text_base);
5986 mp_print_int(mp, r); mp_print_char(mp, ')'); c=right_paren_class;
5990 @ @<Print string |r| as a symbolic token...@>=
5992 c=mp->char_class[mp->str_pool[mp->str_start[r]]];
5995 case letter_class:mp_print_char(mp, '.'); break;
5996 case isolated_classes: break;
5997 default: mp_print_char(mp, ' '); break;
6000 mp_print_str(mp, r);
6004 void mp_print_capsule (MP mp, pointer p);
6006 @ @<Declare miscellaneous procedures that were declared |forward|@>=
6007 void mp_print_capsule (MP mp, pointer p) {
6008 mp_print_char(mp, '('); mp_print_exp(mp,p,0); mp_print_char(mp, ')');
6011 @ Macro definitions are kept in \MP's memory in the form of token lists
6012 that have a few extra one-word nodes at the beginning.
6014 The first node contains a reference count that is used to tell when the
6015 list is no longer needed. To emphasize the fact that a reference count is
6016 present, we shall refer to the |info| field of this special node as the
6018 @^reference counts@>
6020 The next node or nodes after the reference count serve to describe the
6021 formal parameters. They consist of zero or more parameter tokens followed
6022 by a code for the type of macro.
6025 /* reference count preceding a macro definition or picture header */
6026 @d add_mac_ref(A) incr(ref_count((A))) /* make a new reference to a macro list */
6027 @d general_macro 0 /* preface to a macro defined with a parameter list */
6028 @d primary_macro 1 /* preface to a macro with a \&{primary} parameter */
6029 @d secondary_macro 2 /* preface to a macro with a \&{secondary} parameter */
6030 @d tertiary_macro 3 /* preface to a macro with a \&{tertiary} parameter */
6031 @d expr_macro 4 /* preface to a macro with an undelimited \&{expr} parameter */
6032 @d of_macro 5 /* preface to a macro with
6033 undelimited `\&{expr} |x| \&{of}~|y|' parameters */
6034 @d suffix_macro 6 /* preface to a macro with an undelimited \&{suffix} parameter */
6035 @d text_macro 7 /* preface to a macro with an undelimited \&{text} parameter */
6038 void mp_delete_mac_ref (MP mp,pointer p) {
6039 /* |p| points to the reference count of a macro list that is
6040 losing one reference */
6041 if ( ref_count(p)==null ) mp_flush_token_list(mp, p);
6042 else decr(ref_count(p));
6045 @ The following subroutine displays a macro, given a pointer to its
6049 @<Declare the procedure called |print_cmd_mod|@>
6050 void mp_show_macro (MP mp, pointer p, integer q, integer l) {
6051 pointer r; /* temporary storage */
6052 p=link(p); /* bypass the reference count */
6053 while ( info(p)>text_macro ){
6054 r=link(p); link(p)=null;
6055 mp_show_token_list(mp, p,null,l,0); link(p)=r; p=r;
6056 if ( l>0 ) l=l-mp->tally; else return;
6057 } /* control printing of `\.{ETC.}' */
6061 case general_macro:mp_print(mp, "->"); break;
6063 case primary_macro: case secondary_macro: case tertiary_macro:
6064 mp_print_char(mp, '<');
6065 mp_print_cmd_mod(mp, param_type,info(p));
6066 mp_print(mp, ">->");
6068 case expr_macro:mp_print(mp, "<expr>->"); break;
6069 case of_macro:mp_print(mp, "<expr>of<primary>->"); break;
6070 case suffix_macro:mp_print(mp, "<suffix>->"); break;
6071 case text_macro:mp_print(mp, "<text>->"); break;
6072 } /* there are no other cases */
6073 mp_show_token_list(mp, link(p),q,l-mp->tally,0);
6076 @* \[15] Data structures for variables.
6077 The variables of \MP\ programs can be simple, like `\.x', or they can
6078 combine the structural properties of arrays and records, like `\.{x20a.b}'.
6079 A \MP\ user assigns a type to a variable like \.{x20a.b} by saying, for
6080 example, `\.{boolean} \.{x[]a.b}'. It's time for us to study how such
6081 things are represented inside of the computer.
6083 Each variable value occupies two consecutive words, either in a two-word
6084 node called a value node, or as a two-word subfield of a larger node. One
6085 of those two words is called the |value| field; it is an integer,
6086 containing either a |scaled| numeric value or the representation of some
6087 other type of quantity. (It might also be subdivided into halfwords, in
6088 which case it is referred to by other names instead of |value|.) The other
6089 word is broken into subfields called |type|, |name_type|, and |link|. The
6090 |type| field is a quarterword that specifies the variable's type, and
6091 |name_type| is a quarterword from which \MP\ can reconstruct the
6092 variable's name (sometimes by using the |link| field as well). Thus, only
6093 1.25 words are actually devoted to the value itself; the other
6094 three-quarters of a word are overhead, but they aren't wasted because they
6095 allow \MP\ to deal with sparse arrays and to provide meaningful diagnostics.
6097 In this section we shall be concerned only with the structural aspects of
6098 variables, not their values. Later parts of the program will change the
6099 |type| and |value| fields, but we shall treat those fields as black boxes
6100 whose contents should not be touched.
6102 However, if the |type| field is |mp_structured|, there is no |value| field,
6103 and the second word is broken into two pointer fields called |attr_head|
6104 and |subscr_head|. Those fields point to additional nodes that
6105 contain structural information, as we shall see.
6107 @d subscr_head_loc(A) (A)+1 /* where |value|, |subscr_head| and |attr_head| are */
6108 @d attr_head(A) info(subscr_head_loc((A))) /* pointer to attribute info */
6109 @d subscr_head(A) link(subscr_head_loc((A))) /* pointer to subscript info */
6110 @d value_node_size 2 /* the number of words in a value node */
6112 @ An attribute node is three words long. Two of these words contain |type|
6113 and |value| fields as described above, and the third word contains
6114 additional information: There is an |attr_loc| field, which contains the
6115 hash address of the token that names this attribute; and there's also a
6116 |parent| field, which points to the value node of |mp_structured| type at the
6117 next higher level (i.e., at the level to which this attribute is
6118 subsidiary). The |name_type| in an attribute node is `|attr|'. The
6119 |link| field points to the next attribute with the same parent; these are
6120 arranged in increasing order, so that |attr_loc(link(p))>attr_loc(p)|. The
6121 final attribute node links to the constant |end_attr|, whose |attr_loc|
6122 field is greater than any legal hash address. The |attr_head| in the
6123 parent points to a node whose |name_type| is |mp_structured_root|; this
6124 node represents the null attribute, i.e., the variable that is relevant
6125 when no attributes are attached to the parent. The |attr_head| node
6126 has the fields of either
6127 a value node, a subscript node, or an attribute node, depending on what
6128 the parent would be if it were not structured; but the subscript and
6129 attribute fields are ignored, so it effectively contains only the data of
6130 a value node. The |link| field in this special node points to an attribute
6131 node whose |attr_loc| field is zero; the latter node represents a collective
6132 subscript `\.{[]}' attached to the parent, and its |link| field points to
6133 the first non-special attribute node (or to |end_attr| if there are none).
6135 A subscript node likewise occupies three words, with |type| and |value| fields
6136 plus extra information; its |name_type| is |subscr|. In this case the
6137 third word is called the |subscript| field, which is a |scaled| integer.
6138 The |link| field points to the subscript node with the next larger
6139 subscript, if any; otherwise the |link| points to the attribute node
6140 for collective subscripts at this level. We have seen that the latter node
6141 contains an upward pointer, so that the parent can be deduced.
6143 The |name_type| in a parent-less value node is |root|, and the |link|
6144 is the hash address of the token that names this value.
6146 In other words, variables have a hierarchical structure that includes
6147 enough threads running around so that the program is able to move easily
6148 between siblings, parents, and children. An example should be helpful:
6149 (The reader is advised to draw a picture while reading the following
6150 description, since that will help to firm up the ideas.)
6151 Suppose that `\.x' and `\.{x.a}' and `\.{x[]b}' and `\.{x5}'
6152 and `\.{x20b}' have been mentioned in a user's program, where
6153 \.{x[]b} has been declared to be of \&{boolean} type. Let |h(x)|, |h(a)|,
6154 and |h(b)| be the hash addresses of \.x, \.a, and~\.b. Then
6155 |eq_type(h(x))=name| and |equiv(h(x))=p|, where |p|~is a two-word value
6156 node with |name_type(p)=root| and |link(p)=h(x)|. We have |type(p)=mp_structured|,
6157 |attr_head(p)=q|, and |subscr_head(p)=r|, where |q| points to a value
6158 node and |r| to a subscript node. (Are you still following this? Use
6159 a pencil to draw a diagram.) The lone variable `\.x' is represented by
6160 |type(q)| and |value(q)|; furthermore
6161 |name_type(q)=mp_structured_root| and |link(q)=q1|, where |q1| points
6162 to an attribute node representing `\.{x[]}'. Thus |name_type(q1)=attr|,
6163 |attr_loc(q1)=collective_subscript=0|, |parent(q1)=p|,
6164 |type(q1)=mp_structured|, |attr_head(q1)=qq|, and |subscr_head(q1)=qq1|;
6165 |qq| is a three-word ``attribute-as-value'' node with |type(qq)=numeric_type|
6166 (assuming that \.{x5} is numeric, because |qq| represents `\.{x[]}'
6167 with no further attributes), |name_type(qq)=structured_root|,
6168 |attr_loc(qq)=0|, |parent(qq)=p|, and
6169 |link(qq)=qq1|. (Now pay attention to the next part.) Node |qq1| is
6170 an attribute node representing `\.{x[][]}', which has never yet
6171 occurred; its |type| field is |undefined|, and its |value| field is
6172 undefined. We have |name_type(qq1)=attr|, |attr_loc(qq1)=collective_subscript|,
6173 |parent(qq1)=q1|, and |link(qq1)=qq2|. Since |qq2| represents
6174 `\.{x[]b}', |type(qq2)=mp_unknown_boolean|; also |attr_loc(qq2)=h(b)|,
6175 |parent(qq2)=q1|, |name_type(qq2)=attr|, |link(qq2)=end_attr|.
6176 (Maybe colored lines will help untangle your picture.)
6177 Node |r| is a subscript node with |type| and |value|
6178 representing `\.{x5}'; |name_type(r)=subscr|, |subscript(r)=5.0|,
6179 and |link(r)=r1| is another subscript node. To complete the picture,
6180 see if you can guess what |link(r1)| is; give up? It's~|q1|.
6181 Furthermore |subscript(r1)=20.0|, |name_type(r1)=subscr|,
6182 |type(r1)=mp_structured|, |attr_head(r1)=qqq|, |subscr_head(r1)=qqq1|,
6183 and we finish things off with three more nodes
6184 |qqq|, |qqq1|, and |qqq2| hung onto~|r1|. (Perhaps you should start again
6185 with a larger sheet of paper.) The value of variable \.{x20b}
6186 appears in node~|qqq2|, as you can well imagine.
6188 If the example in the previous paragraph doesn't make things crystal
6189 clear, a glance at some of the simpler subroutines below will reveal how
6190 things work out in practice.
6192 The only really unusual thing about these conventions is the use of
6193 collective subscript attributes. The idea is to avoid repeating a lot of
6194 type information when many elements of an array are identical macros
6195 (for which distinct values need not be stored) or when they don't have
6196 all of the possible attributes. Branches of the structure below collective
6197 subscript attributes do not carry actual values except for macro identifiers;
6198 branches of the structure below subscript nodes do not carry significant
6199 information in their collective subscript attributes.
6201 @d attr_loc_loc(A) ((A)+2) /* where the |attr_loc| and |parent| fields are */
6202 @d attr_loc(A) info(attr_loc_loc((A))) /* hash address of this attribute */
6203 @d parent(A) link(attr_loc_loc((A))) /* pointer to |mp_structured| variable */
6204 @d subscript_loc(A) ((A)+2) /* where the |subscript| field lives */
6205 @d subscript(A) mp->mem[subscript_loc((A))].sc /* subscript of this variable */
6206 @d attr_node_size 3 /* the number of words in an attribute node */
6207 @d subscr_node_size 3 /* the number of words in a subscript node */
6208 @d collective_subscript 0 /* code for the attribute `\.{[]}' */
6210 @<Initialize table...@>=
6211 attr_loc(end_attr)=hash_end+1; parent(end_attr)=null;
6213 @ Variables of type \&{pair} will have values that point to four-word
6214 nodes containing two numeric values. The first of these values has
6215 |name_type=mp_x_part_sector| and the second has |name_type=mp_y_part_sector|;
6216 the |link| in the first points back to the node whose |value| points
6217 to this four-word node.
6219 Variables of type \&{transform} are similar, but in this case their
6220 |value| points to a 12-word node containing six values, identified by
6221 |x_part_sector|, |y_part_sector|, |mp_xx_part_sector|, |mp_xy_part_sector|,
6222 |mp_yx_part_sector|, and |mp_yy_part_sector|.
6223 Finally, variables of type \&{color} have 3~values in 6~words
6224 identified by |mp_red_part_sector|, |mp_green_part_sector|, and |mp_blue_part_sector|.
6226 When an entire structured variable is saved, the |root| indication
6227 is temporarily replaced by |saved_root|.
6229 Some variables have no name; they just are used for temporary storage
6230 while expressions are being evaluated. We call them {\sl capsules}.
6232 @d x_part_loc(A) (A) /* where the \&{xpart} is found in a pair or transform node */
6233 @d y_part_loc(A) ((A)+2) /* where the \&{ypart} is found in a pair or transform node */
6234 @d xx_part_loc(A) ((A)+4) /* where the \&{xxpart} is found in a transform node */
6235 @d xy_part_loc(A) ((A)+6) /* where the \&{xypart} is found in a transform node */
6236 @d yx_part_loc(A) ((A)+8) /* where the \&{yxpart} is found in a transform node */
6237 @d yy_part_loc(A) ((A)+10) /* where the \&{yypart} is found in a transform node */
6238 @d red_part_loc(A) (A) /* where the \&{redpart} is found in a color node */
6239 @d green_part_loc(A) ((A)+2) /* where the \&{greenpart} is found in a color node */
6240 @d blue_part_loc(A) ((A)+4) /* where the \&{bluepart} is found in a color node */
6241 @d cyan_part_loc(A) (A) /* where the \&{cyanpart} is found in a color node */
6242 @d magenta_part_loc(A) ((A)+2) /* where the \&{magentapart} is found in a color node */
6243 @d yellow_part_loc(A) ((A)+4) /* where the \&{yellowpart} is found in a color node */
6244 @d black_part_loc(A) ((A)+6) /* where the \&{blackpart} is found in a color node */
6245 @d grey_part_loc(A) (A) /* where the \&{greypart} is found in a color node */
6247 @d pair_node_size 4 /* the number of words in a pair node */
6248 @d transform_node_size 12 /* the number of words in a transform node */
6249 @d color_node_size 6 /* the number of words in a color node */
6250 @d cmykcolor_node_size 8 /* the number of words in a color node */
6253 small_number big_node_size[mp_pair_type+1];
6254 small_number sector0[mp_pair_type+1];
6255 small_number sector_offset[mp_black_part_sector+1];
6257 @ The |sector0| array gives for each big node type, |name_type| values
6258 for its first subfield; the |sector_offset| array gives for each
6259 |name_type| value, the offset from the first subfield in words;
6260 and the |big_node_size| array gives the size in words for each type of
6264 mp->big_node_size[mp_transform_type]=transform_node_size;
6265 mp->big_node_size[mp_pair_type]=pair_node_size;
6266 mp->big_node_size[mp_color_type]=color_node_size;
6267 mp->big_node_size[mp_cmykcolor_type]=cmykcolor_node_size;
6268 mp->sector0[mp_transform_type]=mp_x_part_sector;
6269 mp->sector0[mp_pair_type]=mp_x_part_sector;
6270 mp->sector0[mp_color_type]=mp_red_part_sector;
6271 mp->sector0[mp_cmykcolor_type]=mp_cyan_part_sector;
6272 for (k=mp_x_part_sector;k<= mp_yy_part_sector;k++ ) {
6273 mp->sector_offset[k]=2*(k-mp_x_part_sector);
6275 for (k=mp_red_part_sector;k<= mp_blue_part_sector ; k++) {
6276 mp->sector_offset[k]=2*(k-mp_red_part_sector);
6278 for (k=mp_cyan_part_sector;k<= mp_black_part_sector;k++ ) {
6279 mp->sector_offset[k]=2*(k-mp_cyan_part_sector);
6282 @ If |type(p)=mp_pair_type| or |mp_transform_type| and if |value(p)=null|, the
6283 procedure call |init_big_node(p)| will allocate a pair or transform node
6284 for~|p|. The individual parts of such nodes are initially of type
6288 void mp_init_big_node (MP mp,pointer p) {
6289 pointer q; /* the new node */
6290 small_number s; /* its size */
6291 s=mp->big_node_size[type(p)]; q=mp_get_node(mp, s);
6294 @<Make variable |q+s| newly independent@>;
6295 name_type(q+s)=halfp(s)+mp->sector0[type(p)];
6298 link(q)=p; value(p)=q;
6301 @ The |id_transform| function creates a capsule for the
6302 identity transformation.
6305 pointer mp_id_transform (MP mp) {
6306 pointer p,q,r; /* list manipulation registers */
6307 p=mp_get_node(mp, value_node_size); type(p)=mp_transform_type;
6308 name_type(p)=mp_capsule; value(p)=null; mp_init_big_node(mp, p); q=value(p);
6309 r=q+transform_node_size;
6312 type(r)=mp_known; value(r)=0;
6314 value(xx_part_loc(q))=unity;
6315 value(yy_part_loc(q))=unity;
6319 @ Tokens are of type |tag_token| when they first appear, but they point
6320 to |null| until they are first used as the root of a variable.
6321 The following subroutine establishes the root node on such grand occasions.
6324 void mp_new_root (MP mp,pointer x) {
6325 pointer p; /* the new node */
6326 p=mp_get_node(mp, value_node_size); type(p)=undefined; name_type(p)=mp_root;
6327 link(p)=x; equiv(x)=p;
6330 @ These conventions for variable representation are illustrated by the
6331 |print_variable_name| routine, which displays the full name of a
6332 variable given only a pointer to its two-word value packet.
6335 void mp_print_variable_name (MP mp, pointer p);
6338 void mp_print_variable_name (MP mp, pointer p) {
6339 pointer q; /* a token list that will name the variable's suffix */
6340 pointer r; /* temporary for token list creation */
6341 while ( name_type(p)>=mp_x_part_sector ) {
6342 @<Preface the output with a part specifier; |return| in the
6343 case of a capsule@>;
6346 while ( name_type(p)>mp_saved_root ) {
6347 @<Ascend one level, pushing a token onto list |q|
6348 and replacing |p| by its parent@>;
6350 r=mp_get_avail(mp); info(r)=link(p); link(r)=q;
6351 if ( name_type(p)==mp_saved_root ) mp_print(mp, "(SAVED)");
6353 mp_show_token_list(mp, r,null,el_gordo,mp->tally);
6354 mp_flush_token_list(mp, r);
6357 @ @<Ascend one level, pushing a token onto list |q|...@>=
6359 if ( name_type(p)==mp_subscr ) {
6360 r=mp_new_num_tok(mp, subscript(p));
6363 } while (name_type(p)!=mp_attr);
6364 } else if ( name_type(p)==mp_structured_root ) {
6365 p=link(p); goto FOUND;
6367 if ( name_type(p)!=mp_attr ) mp_confusion(mp, "var");
6368 @:this can't happen var}{\quad var@>
6369 r=mp_get_avail(mp); info(r)=attr_loc(p);
6376 @ @<Preface the output with a part specifier...@>=
6377 { switch (name_type(p)) {
6378 case mp_x_part_sector: mp_print_char(mp, 'x'); break;
6379 case mp_y_part_sector: mp_print_char(mp, 'y'); break;
6380 case mp_xx_part_sector: mp_print(mp, "xx"); break;
6381 case mp_xy_part_sector: mp_print(mp, "xy"); break;
6382 case mp_yx_part_sector: mp_print(mp, "yx"); break;
6383 case mp_yy_part_sector: mp_print(mp, "yy"); break;
6384 case mp_red_part_sector: mp_print(mp, "red"); break;
6385 case mp_green_part_sector: mp_print(mp, "green"); break;
6386 case mp_blue_part_sector: mp_print(mp, "blue"); break;
6387 case mp_cyan_part_sector: mp_print(mp, "cyan"); break;
6388 case mp_magenta_part_sector: mp_print(mp, "magenta"); break;
6389 case mp_yellow_part_sector: mp_print(mp, "yellow"); break;
6390 case mp_black_part_sector: mp_print(mp, "black"); break;
6391 case mp_grey_part_sector: mp_print(mp, "grey"); break;
6393 mp_print(mp, "%CAPSULE"); mp_print_int(mp, p-null); return;
6396 } /* there are no other cases */
6397 mp_print(mp, "part ");
6398 p=link(p-mp->sector_offset[name_type(p)]);
6401 @ The |interesting| function returns |true| if a given variable is not
6402 in a capsule, or if the user wants to trace capsules.
6405 boolean mp_interesting (MP mp,pointer p) {
6406 small_number t; /* a |name_type| */
6407 if ( mp->internal[mp_tracing_capsules]>0 ) {
6411 if ( t>=mp_x_part_sector ) if ( t!=mp_capsule )
6412 t=name_type(link(p-mp->sector_offset[t]));
6413 return (t!=mp_capsule);
6417 @ Now here is a subroutine that converts an unstructured type into an
6418 equivalent structured type, by inserting a |mp_structured| node that is
6419 capable of growing. This operation is done only when |name_type(p)=root|,
6420 |subscr|, or |attr|.
6422 The procedure returns a pointer to the new node that has taken node~|p|'s
6423 place in the structure. Node~|p| itself does not move, nor are its
6424 |value| or |type| fields changed in any way.
6427 pointer mp_new_structure (MP mp,pointer p) {
6428 pointer q,r=0; /* list manipulation registers */
6429 switch (name_type(p)) {
6431 q=link(p); r=mp_get_node(mp, value_node_size); equiv(q)=r;
6434 @<Link a new subscript node |r| in place of node |p|@>;
6437 @<Link a new attribute node |r| in place of node |p|@>;
6440 mp_confusion(mp, "struct");
6441 @:this can't happen struct}{\quad struct@>
6444 link(r)=link(p); type(r)=mp_structured; name_type(r)=name_type(p);
6445 attr_head(r)=p; name_type(p)=mp_structured_root;
6446 q=mp_get_node(mp, attr_node_size); link(p)=q; subscr_head(r)=q;
6447 parent(q)=r; type(q)=undefined; name_type(q)=mp_attr; link(q)=end_attr;
6448 attr_loc(q)=collective_subscript;
6452 @ @<Link a new subscript node |r| in place of node |p|@>=
6457 } while (name_type(q)!=mp_attr);
6458 q=parent(q); r=subscr_head_loc(q); /* |link(r)=subscr_head(q)| */
6462 r=mp_get_node(mp, subscr_node_size);
6463 link(q)=r; subscript(r)=subscript(p);
6466 @ If the attribute is |collective_subscript|, there are two pointers to
6467 node~|p|, so we must change both of them.
6469 @<Link a new attribute node |r| in place of node |p|@>=
6471 q=parent(p); r=attr_head(q);
6475 r=mp_get_node(mp, attr_node_size); link(q)=r;
6476 mp->mem[attr_loc_loc(r)]=mp->mem[attr_loc_loc(p)]; /* copy |attr_loc| and |parent| */
6477 if ( attr_loc(p)==collective_subscript ) {
6478 q=subscr_head_loc(parent(p));
6479 while ( link(q)!=p ) q=link(q);
6484 @ The |find_variable| routine is given a pointer~|t| to a nonempty token
6485 list of suffixes; it returns a pointer to the corresponding two-word
6486 value. For example, if |t| points to token \.x followed by a numeric
6487 token containing the value~7, |find_variable| finds where the value of
6488 \.{x7} is stored in memory. This may seem a simple task, and it
6489 usually is, except when \.{x7} has never been referenced before.
6490 Indeed, \.x may never have even been subscripted before; complexities
6491 arise with respect to updating the collective subscript information.
6493 If a macro type is detected anywhere along path~|t|, or if the first
6494 item on |t| isn't a |tag_token|, the value |null| is returned.
6495 Otherwise |p| will be a non-null pointer to a node such that
6496 |undefined<type(p)<mp_structured|.
6498 @d abort_find { return null; }
6501 pointer mp_find_variable (MP mp,pointer t) {
6502 pointer p,q,r,s; /* nodes in the ``value'' line */
6503 pointer pp,qq,rr,ss; /* nodes in the ``collective'' line */
6504 integer n; /* subscript or attribute */
6505 memory_word save_word; /* temporary storage for a word of |mem| */
6507 p=info(t); t=link(t);
6508 if ( (eq_type(p) % outer_tag) != tag_token ) abort_find;
6509 if ( equiv(p)==null ) mp_new_root(mp, p);
6512 @<Make sure that both nodes |p| and |pp| are of |mp_structured| type@>;
6513 if ( t<mp->hi_mem_min ) {
6514 @<Descend one level for the subscript |value(t)|@>
6516 @<Descend one level for the attribute |info(t)|@>;
6520 if ( type(pp)>=mp_structured ) {
6521 if ( type(pp)==mp_structured ) pp=attr_head(pp); else abort_find;
6523 if ( type(p)==mp_structured ) p=attr_head(p);
6524 if ( type(p)==undefined ) {
6525 if ( type(pp)==undefined ) { type(pp)=mp_numeric_type; value(pp)=null; };
6526 type(p)=type(pp); value(p)=null;
6531 @ Although |pp| and |p| begin together, they diverge when a subscript occurs;
6532 |pp|~stays in the collective line while |p|~goes through actual subscript
6535 @<Make sure that both nodes |p| and |pp|...@>=
6536 if ( type(pp)!=mp_structured ) {
6537 if ( type(pp)>mp_structured ) abort_find;
6538 ss=mp_new_structure(mp, pp);
6541 }; /* now |type(pp)=mp_structured| */
6542 if ( type(p)!=mp_structured ) /* it cannot be |>mp_structured| */
6543 p=mp_new_structure(mp, p) /* now |type(p)=mp_structured| */
6545 @ We want this part of the program to be reasonably fast, in case there are
6547 lots of subscripts at the same level of the data structure. Therefore
6548 we store an ``infinite'' value in the word that appears at the end of the
6549 subscript list, even though that word isn't part of a subscript node.
6551 @<Descend one level for the subscript |value(t)|@>=
6554 pp=link(attr_head(pp)); /* now |attr_loc(pp)=collective_subscript| */
6555 q=link(attr_head(p)); save_word=mp->mem[subscript_loc(q)];
6556 subscript(q)=el_gordo; s=subscr_head_loc(p); /* |link(s)=subscr_head(p)| */
6559 } while (n>subscript(s));
6560 if ( n==subscript(s) ) {
6563 p=mp_get_node(mp, subscr_node_size); link(r)=p; link(p)=s;
6564 subscript(p)=n; name_type(p)=mp_subscr; type(p)=undefined;
6566 mp->mem[subscript_loc(q)]=save_word;
6569 @ @<Descend one level for the attribute |info(t)|@>=
6575 } while (n>attr_loc(ss));
6576 if ( n<attr_loc(ss) ) {
6577 qq=mp_get_node(mp, attr_node_size); link(rr)=qq; link(qq)=ss;
6578 attr_loc(qq)=n; name_type(qq)=mp_attr; type(qq)=undefined;
6579 parent(qq)=pp; ss=qq;
6584 pp=ss; s=attr_head(p);
6587 } while (n>attr_loc(s));
6588 if ( n==attr_loc(s) ) {
6591 q=mp_get_node(mp, attr_node_size); link(r)=q; link(q)=s;
6592 attr_loc(q)=n; name_type(q)=mp_attr; type(q)=undefined;
6598 @ Variables lose their former values when they appear in a type declaration,
6599 or when they are defined to be macros or \&{let} equal to something else.
6600 A subroutine will be defined later that recycles the storage associated
6601 with any particular |type| or |value|; our goal now is to study a higher
6602 level process called |flush_variable|, which selectively frees parts of a
6605 This routine has some complexity because of examples such as
6606 `\hbox{\tt numeric x[]a[]b}'
6607 which recycles all variables of the form \.{x[i]a[j]b} (and no others), while
6608 `\hbox{\tt vardef x[]a[]=...}'
6609 discards all variables of the form \.{x[i]a[j]} followed by an arbitrary
6610 suffix, except for the collective node \.{x[]a[]} itself. The obvious way
6611 to handle such examples is to use recursion; so that's what we~do.
6614 Parameter |p| points to the root information of the variable;
6615 parameter |t| points to a list of one-word nodes that represent
6616 suffixes, with |info=collective_subscript| for subscripts.
6619 @<Declare subroutines for printing expressions@>
6620 @<Declare basic dependency-list subroutines@>
6621 @<Declare the recycling subroutines@>
6622 void mp_flush_cur_exp (MP mp,scaled v) ;
6623 @<Declare the procedure called |flush_below_variable|@>
6626 void mp_flush_variable (MP mp,pointer p, pointer t, boolean discard_suffixes) {
6627 pointer q,r; /* list manipulation */
6628 halfword n; /* attribute to match */
6630 if ( type(p)!=mp_structured ) return;
6631 n=info(t); t=link(t);
6632 if ( n==collective_subscript ) {
6633 r=subscr_head_loc(p); q=link(r); /* |q=subscr_head(p)| */
6634 while ( name_type(q)==mp_subscr ){
6635 mp_flush_variable(mp, q,t,discard_suffixes);
6637 if ( type(q)==mp_structured ) r=q;
6638 else { link(r)=link(q); mp_free_node(mp, q,subscr_node_size); }
6648 } while (attr_loc(p)<n);
6649 if ( attr_loc(p)!=n ) return;
6651 if ( discard_suffixes ) {
6652 mp_flush_below_variable(mp, p);
6654 if ( type(p)==mp_structured ) p=attr_head(p);
6655 mp_recycle_value(mp, p);
6659 @ The next procedure is simpler; it wipes out everything but |p| itself,
6660 which becomes undefined.
6662 @<Declare the procedure called |flush_below_variable|@>=
6663 void mp_flush_below_variable (MP mp, pointer p);
6666 void mp_flush_below_variable (MP mp,pointer p) {
6667 pointer q,r; /* list manipulation registers */
6668 if ( type(p)!=mp_structured ) {
6669 mp_recycle_value(mp, p); /* this sets |type(p)=undefined| */
6672 while ( name_type(q)==mp_subscr ) {
6673 mp_flush_below_variable(mp, q); r=q; q=link(q);
6674 mp_free_node(mp, r,subscr_node_size);
6676 r=attr_head(p); q=link(r); mp_recycle_value(mp, r);
6677 if ( name_type(p)<=mp_saved_root ) mp_free_node(mp, r,value_node_size);
6678 else mp_free_node(mp, r,subscr_node_size);
6679 /* we assume that |subscr_node_size=attr_node_size| */
6681 mp_flush_below_variable(mp, q); r=q; q=link(q); mp_free_node(mp, r,attr_node_size);
6682 } while (q!=end_attr);
6687 @ Just before assigning a new value to a variable, we will recycle the
6688 old value and make the old value undefined. The |und_type| routine
6689 determines what type of undefined value should be given, based on
6690 the current type before recycling.
6693 small_number mp_und_type (MP mp,pointer p) {
6695 case undefined: case mp_vacuous:
6697 case mp_boolean_type: case mp_unknown_boolean:
6698 return mp_unknown_boolean;
6699 case mp_string_type: case mp_unknown_string:
6700 return mp_unknown_string;
6701 case mp_pen_type: case mp_unknown_pen:
6702 return mp_unknown_pen;
6703 case mp_path_type: case mp_unknown_path:
6704 return mp_unknown_path;
6705 case mp_picture_type: case mp_unknown_picture:
6706 return mp_unknown_picture;
6707 case mp_transform_type: case mp_color_type: case mp_cmykcolor_type:
6708 case mp_pair_type: case mp_numeric_type:
6710 case mp_known: case mp_dependent: case mp_proto_dependent: case mp_independent:
6711 return mp_numeric_type;
6712 } /* there are no other cases */
6716 @ The |clear_symbol| routine is used when we want to redefine the equivalent
6717 of a symbolic token. It must remove any variable structure or macro
6718 definition that is currently attached to that symbol. If the |saving|
6719 parameter is true, a subsidiary structure is saved instead of destroyed.
6722 void mp_clear_symbol (MP mp,pointer p, boolean saving) {
6723 pointer q; /* |equiv(p)| */
6725 switch (eq_type(p) % outer_tag) {
6727 case secondary_primary_macro:
6728 case tertiary_secondary_macro:
6729 case expression_tertiary_macro:
6730 if ( ! saving ) mp_delete_mac_ref(mp, q);
6735 name_type(q)=mp_saved_root;
6737 mp_flush_below_variable(mp, q);
6738 mp_free_node(mp,q,value_node_size);
6745 mp->eqtb[p]=mp->eqtb[frozen_undefined];
6748 @* \[16] Saving and restoring equivalents.
6749 The nested structure given by \&{begingroup} and \&{endgroup}
6750 allows |eqtb| entries to be saved and restored, so that temporary changes
6751 can be made without difficulty. When the user requests a current value to
6752 be saved, \MP\ puts that value into its ``save stack.'' An appearance of
6753 \&{endgroup} ultimately causes the old values to be removed from the save
6754 stack and put back in their former places.
6756 The save stack is a linked list containing three kinds of entries,
6757 distinguished by their |info| fields. If |p| points to a saved item,
6761 |info(p)=0| stands for a group boundary; each \&{begingroup} contributes
6762 such an item to the save stack and each \&{endgroup} cuts back the stack
6763 until the most recent such entry has been removed.
6766 |info(p)=q|, where |1<=q<=hash_end|, means that |mem[p+1]| holds the former
6767 contents of |eqtb[q]|. Such save stack entries are generated by \&{save}
6771 |info(p)=hash_end+q|, where |q>0|, means that |value(p)| is a |scaled|
6772 integer to be restored to internal parameter number~|q|. Such entries
6773 are generated by \&{interim} commands.
6776 The global variable |save_ptr| points to the top item on the save stack.
6778 @d save_node_size 2 /* number of words per non-boundary save-stack node */
6779 @d saved_equiv(A) mp->mem[(A)+1].hh /* where an |eqtb| entry gets saved */
6780 @d save_boundary_item(A) { (A)=mp_get_avail(mp); info((A))=0;
6781 link((A))=mp->save_ptr; mp->save_ptr=(A);
6785 pointer save_ptr; /* the most recently saved item */
6787 @ @<Set init...@>=mp->save_ptr=null;
6789 @ The |save_variable| routine is given a hash address |q|; it salts this
6790 address in the save stack, together with its current equivalent,
6791 then makes token~|q| behave as though it were brand new.
6793 Nothing is stacked when |save_ptr=null|, however; there's no way to remove
6794 things from the stack when the program is not inside a group, so there's
6795 no point in wasting the space.
6797 @c void mp_save_variable (MP mp,pointer q) {
6798 pointer p; /* temporary register */
6799 if ( mp->save_ptr!=null ){
6800 p=mp_get_node(mp, save_node_size); info(p)=q; link(p)=mp->save_ptr;
6801 saved_equiv(p)=mp->eqtb[q]; mp->save_ptr=p;
6803 mp_clear_symbol(mp, q,(mp->save_ptr!=null));
6806 @ Similarly, |save_internal| is given the location |q| of an internal
6807 quantity like |mp_tracing_pens|. It creates a save stack entry of the
6810 @c void mp_save_internal (MP mp,halfword q) {
6811 pointer p; /* new item for the save stack */
6812 if ( mp->save_ptr!=null ){
6813 p=mp_get_node(mp, save_node_size); info(p)=hash_end+q;
6814 link(p)=mp->save_ptr; value(p)=mp->internal[q]; mp->save_ptr=p;
6818 @ At the end of a group, the |unsave| routine restores all of the saved
6819 equivalents in reverse order. This routine will be called only when there
6820 is at least one boundary item on the save stack.
6823 void mp_unsave (MP mp) {
6824 pointer q; /* index to saved item */
6825 pointer p; /* temporary register */
6826 while ( info(mp->save_ptr)!=0 ) {
6827 q=info(mp->save_ptr);
6829 if ( mp->internal[mp_tracing_restores]>0 ) {
6830 mp_begin_diagnostic(mp); mp_print_nl(mp, "{restoring ");
6831 mp_print(mp, mp->int_name[q-(hash_end)]); mp_print_char(mp, '=');
6832 mp_print_scaled(mp, value(mp->save_ptr)); mp_print_char(mp, '}');
6833 mp_end_diagnostic(mp, false);
6835 mp->internal[q-(hash_end)]=value(mp->save_ptr);
6837 if ( mp->internal[mp_tracing_restores]>0 ) {
6838 mp_begin_diagnostic(mp); mp_print_nl(mp, "{restoring ");
6839 mp_print_text(q); mp_print_char(mp, '}');
6840 mp_end_diagnostic(mp, false);
6842 mp_clear_symbol(mp, q,false);
6843 mp->eqtb[q]=saved_equiv(mp->save_ptr);
6844 if ( eq_type(q) % outer_tag==tag_token ) {
6846 if ( p!=null ) name_type(p)=mp_root;
6849 p=link(mp->save_ptr);
6850 mp_free_node(mp, mp->save_ptr,save_node_size); mp->save_ptr=p;
6852 p=link(mp->save_ptr); free_avail(mp->save_ptr); mp->save_ptr=p;
6855 @* \[17] Data structures for paths.
6856 When a \MP\ user specifies a path, \MP\ will create a list of knots
6857 and control points for the associated cubic spline curves. If the
6858 knots are $z_0$, $z_1$, \dots, $z_n$, there are control points
6859 $z_k^+$ and $z_{k+1}^-$ such that the cubic splines between knots
6860 $z_k$ and $z_{k+1}$ are defined by B\'ezier's formula
6861 @:Bezier}{B\'ezier, Pierre Etienne@>
6862 $$\eqalign{z(t)&=B(z_k,z_k^+,z_{k+1}^-,z_{k+1};t)\cr
6863 &=(1-t)^3z_k+3(1-t)^2tz_k^++3(1-t)t^2z_{k+1}^-+t^3z_{k+1}\cr}$$
6866 There is a 8-word node for each knot $z_k$, containing one word of
6867 control information and six words for the |x| and |y| coordinates of
6868 $z_k^-$ and $z_k$ and~$z_k^+$. The control information appears in the
6869 |left_type| and |right_type| fields, which each occupy a quarter of
6870 the first word in the node; they specify properties of the curve as it
6871 enters and leaves the knot. There's also a halfword |link| field,
6872 which points to the following knot, and a final supplementary word (of
6873 which only a quarter is used).
6875 If the path is a closed contour, knots 0 and |n| are identical;
6876 i.e., the |link| in knot |n-1| points to knot~0. But if the path
6877 is not closed, the |left_type| of knot~0 and the |right_type| of knot~|n|
6878 are equal to |endpoint|. In the latter case the |link| in knot~|n| points
6879 to knot~0, and the control points $z_0^-$ and $z_n^+$ are not used.
6881 @d left_type(A) mp->mem[(A)].hh.b0 /* characterizes the path entering this knot */
6882 @d right_type(A) mp->mem[(A)].hh.b1 /* characterizes the path leaving this knot */
6883 @d x_coord(A) mp->mem[(A)+1].sc /* the |x| coordinate of this knot */
6884 @d y_coord(A) mp->mem[(A)+2].sc /* the |y| coordinate of this knot */
6885 @d left_x(A) mp->mem[(A)+3].sc /* the |x| coordinate of previous control point */
6886 @d left_y(A) mp->mem[(A)+4].sc /* the |y| coordinate of previous control point */
6887 @d right_x(A) mp->mem[(A)+5].sc /* the |x| coordinate of next control point */
6888 @d right_y(A) mp->mem[(A)+6].sc /* the |y| coordinate of next control point */
6889 @d x_loc(A) ((A)+1) /* where the |x| coordinate is stored in a knot */
6890 @d y_loc(A) ((A)+2) /* where the |y| coordinate is stored in a knot */
6891 @d knot_coord(A) mp->mem[(A)].sc /* |x| or |y| coordinate given |x_loc| or |y_loc| */
6892 @d left_coord(A) mp->mem[(A)+2].sc
6893 /* coordinate of previous control point given |x_loc| or |y_loc| */
6894 @d right_coord(A) mp->mem[(A)+4].sc
6895 /* coordinate of next control point given |x_loc| or |y_loc| */
6896 @d knot_node_size 8 /* number of words in a knot node */
6900 mp_endpoint=0, /* |left_type| at path beginning and |right_type| at path end */
6901 mp_explicit, /* |left_type| or |right_type| when control points are known */
6902 mp_given, /* |left_type| or |right_type| when a direction is given */
6903 mp_curl, /* |left_type| or |right_type| when a curl is desired */
6904 mp_open, /* |left_type| or |right_type| when \MP\ should choose the direction */
6908 @ Before the B\'ezier control points have been calculated, the memory
6909 space they will ultimately occupy is taken up by information that can be
6910 used to compute them. There are four cases:
6913 \textindent{$\bullet$} If |right_type=mp_open|, the curve should leave
6914 the knot in the same direction it entered; \MP\ will figure out a
6918 \textindent{$\bullet$} If |right_type=mp_curl|, the curve should leave the
6919 knot in a direction depending on the angle at which it enters the next
6920 knot and on the curl parameter stored in |right_curl|.
6923 \textindent{$\bullet$} If |right_type=mp_given|, the curve should leave the
6924 knot in a nonzero direction stored as an |angle| in |right_given|.
6927 \textindent{$\bullet$} If |right_type=mp_explicit|, the B\'ezier control
6928 point for leaving this knot has already been computed; it is in the
6929 |right_x| and |right_y| fields.
6932 The rules for |left_type| are similar, but they refer to the curve entering
6933 the knot, and to \\{left} fields instead of \\{right} fields.
6935 Non-|explicit| control points will be chosen based on ``tension'' parameters
6936 in the |left_tension| and |right_tension| fields. The
6937 `\&{atleast}' option is represented by negative tension values.
6938 @:at_least_}{\&{atleast} primitive@>
6940 For example, the \MP\ path specification
6941 $$\.{z0..z1..tension atleast 1..\{curl 2\}z2..z3\{-1,-2\}..tension
6943 where \.p is the path `\.{z4..controls z45 and z54..z5}', will be represented
6945 \def\lodash{\hbox to 1.1em{\thinspace\hrulefill\thinspace}}
6946 $$\vbox{\halign{#\hfil&&\qquad#\hfil\cr
6947 |left_type|&\\{left} info&|x_coord,y_coord|&|right_type|&\\{right} info\cr
6949 |endpoint|&\lodash$,\,$\lodash&$x_0,y_0$&|curl|&$1.0,1.0$\cr
6950 |open|&\lodash$,1.0$&$x_1,y_1$&|open|&\lodash$,-1.0$\cr
6951 |curl|&$2.0,-1.0$&$x_2,y_2$&|curl|&$2.0,1.0$\cr
6952 |given|&$d,1.0$&$x_3,y_3$&|given|&$d,3.0$\cr
6953 |open|&\lodash$,4.0$&$x_4,y_4$&|explicit|&$x_{45},y_{45}$\cr
6954 |explicit|&$x_{54},y_{54}$&$x_5,y_5$&|endpoint|&\lodash$,\,$\lodash\cr}}$$
6955 Here |d| is the |angle| obtained by calling |n_arg(-unity,-two)|.
6956 Of course, this example is more complicated than anything a normal user
6959 These types must satisfy certain restrictions because of the form of \MP's
6961 (i)~|open| type never appears in the same node together with |endpoint|,
6963 (ii)~The |right_type| of a node is |explicit| if and only if the
6964 |left_type| of the following node is |explicit|.
6965 (iii)~|endpoint| types occur only at the ends, as mentioned above.
6967 @d left_curl left_x /* curl information when entering this knot */
6968 @d left_given left_x /* given direction when entering this knot */
6969 @d left_tension left_y /* tension information when entering this knot */
6970 @d right_curl right_x /* curl information when leaving this knot */
6971 @d right_given right_x /* given direction when leaving this knot */
6972 @d right_tension right_y /* tension information when leaving this knot */
6974 @ Knots can be user-supplied, or they can be created by program code,
6975 like the |split_cubic| function, or |copy_path|. The distinction is
6976 needed for the cleanup routine that runs after |split_cubic|, because
6977 it should only delete knots it has previously inserted, and never
6978 anything that was user-supplied. In order to be able to differentiate
6979 one knot from another, we will set |originator(p):=mp_metapost_user| when
6980 it appeared in the actual metapost program, and
6981 |originator(p):=mp_program_code| in all other cases.
6983 @d originator(A) mp->mem[(A)+7].hh.b0 /* the creator of this knot */
6987 mp_program_code=0, /* not created by a user */
6988 mp_metapost_user /* created by a user */
6991 @ Here is a routine that prints a given knot list
6992 in symbolic form. It illustrates the conventions discussed above,
6993 and checks for anomalies that might arise while \MP\ is being debugged.
6995 @<Declare subroutines for printing expressions@>=
6996 void mp_pr_path (MP mp,pointer h);
6999 void mp_pr_path (MP mp,pointer h) {
7000 pointer p,q; /* for list traversal */
7004 if ( (p==null)||(q==null) ) {
7005 mp_print_nl(mp, "???"); return; /* this won't happen */
7008 @<Print information for adjacent knots |p| and |q|@>;
7011 if ( (p!=h)||(left_type(h)!=mp_endpoint) ) {
7012 @<Print two dots, followed by |given| or |curl| if present@>;
7015 if ( left_type(h)!=mp_endpoint )
7016 mp_print(mp, "cycle");
7019 @ @<Print information for adjacent knots...@>=
7020 mp_print_two(mp, x_coord(p),y_coord(p));
7021 switch (right_type(p)) {
7023 if ( left_type(p)==mp_open ) mp_print(mp, "{open?}"); /* can't happen */
7025 if ( (left_type(q)!=mp_endpoint)||(q!=h) ) q=null; /* force an error */
7029 @<Print control points between |p| and |q|, then |goto done1|@>;
7032 @<Print information for a curve that begins |open|@>;
7036 @<Print information for a curve that begins |curl| or |given|@>;
7039 mp_print(mp, "???"); /* can't happen */
7043 if ( left_type(q)<=mp_explicit ) {
7044 mp_print(mp, "..control?"); /* can't happen */
7046 } else if ( (right_tension(p)!=unity)||(left_tension(q)!=unity) ) {
7047 @<Print tension between |p| and |q|@>;
7050 @ Since |n_sin_cos| produces |fraction| results, which we will print as if they
7051 were |scaled|, the magnitude of a |given| direction vector will be~4096.
7053 @<Print two dots...@>=
7055 mp_print_nl(mp, " ..");
7056 if ( left_type(p)==mp_given ) {
7057 mp_n_sin_cos(mp, left_given(p)); mp_print_char(mp, '{');
7058 mp_print_scaled(mp, mp->n_cos); mp_print_char(mp, ',');
7059 mp_print_scaled(mp, mp->n_sin); mp_print_char(mp, '}');
7060 } else if ( left_type(p)==mp_curl ){
7061 mp_print(mp, "{curl ");
7062 mp_print_scaled(mp, left_curl(p)); mp_print_char(mp, '}');
7066 @ @<Print tension between |p| and |q|@>=
7068 mp_print(mp, "..tension ");
7069 if ( right_tension(p)<0 ) mp_print(mp, "atleast");
7070 mp_print_scaled(mp, abs(right_tension(p)));
7071 if ( right_tension(p)!=left_tension(q) ){
7072 mp_print(mp, " and ");
7073 if ( left_tension(q)<0 ) mp_print(mp, "atleast");
7074 mp_print_scaled(mp, abs(left_tension(q)));
7078 @ @<Print control points between |p| and |q|, then |goto done1|@>=
7080 mp_print(mp, "..controls ");
7081 mp_print_two(mp, right_x(p),right_y(p));
7082 mp_print(mp, " and ");
7083 if ( left_type(q)!=mp_explicit ) {
7084 mp_print(mp, "??"); /* can't happen */
7087 mp_print_two(mp, left_x(q),left_y(q));
7092 @ @<Print information for a curve that begins |open|@>=
7093 if ( (left_type(p)!=mp_explicit)&&(left_type(p)!=mp_open) ) {
7094 mp_print(mp, "{open?}"); /* can't happen */
7098 @ A curl of 1 is shown explicitly, so that the user sees clearly that
7099 \MP's default curl is present.
7101 @<Print information for a curve that begins |curl|...@>=
7103 if ( left_type(p)==mp_open )
7104 mp_print(mp, "??"); /* can't happen */
7106 if ( right_type(p)==mp_curl ) {
7107 mp_print(mp, "{curl "); mp_print_scaled(mp, right_curl(p));
7109 mp_n_sin_cos(mp, right_given(p)); mp_print_char(mp, '{');
7110 mp_print_scaled(mp, mp->n_cos); mp_print_char(mp, ',');
7111 mp_print_scaled(mp, mp->n_sin);
7113 mp_print_char(mp, '}');
7116 @ It is convenient to have another version of |pr_path| that prints the path
7117 as a diagnostic message.
7119 @<Declare subroutines for printing expressions@>=
7120 void mp_print_path (MP mp,pointer h, const char *s, boolean nuline) {
7121 mp_print_diagnostic(mp, "Path", s, nuline); mp_print_ln(mp);
7124 mp_end_diagnostic(mp, true);
7127 @ If we want to duplicate a knot node, we can say |copy_knot|:
7130 pointer mp_copy_knot (MP mp,pointer p) {
7131 pointer q; /* the copy */
7132 int k; /* runs through the words of a knot node */
7133 q=mp_get_node(mp, knot_node_size);
7134 for (k=0;k<knot_node_size;k++) {
7135 mp->mem[q+k]=mp->mem[p+k];
7137 originator(q)=originator(p);
7141 @ The |copy_path| routine makes a clone of a given path.
7144 pointer mp_copy_path (MP mp, pointer p) {
7145 pointer q,pp,qq; /* for list manipulation */
7146 q=mp_copy_knot(mp, p);
7149 link(qq)=mp_copy_knot(mp, pp);
7158 @ Just before |ship_out|, knot lists are exported for printing.
7160 The |gr_XXXX| macros are defined in |mppsout.h|.
7163 mp_knot *mp_export_knot (MP mp,pointer p) {
7164 mp_knot *q; /* the copy */
7167 q = mp_xmalloc(mp, 1, sizeof (mp_knot));
7168 memset(q,0,sizeof (mp_knot));
7169 gr_left_type(q) = left_type(p);
7170 gr_right_type(q) = right_type(p);
7171 gr_x_coord(q) = x_coord(p);
7172 gr_y_coord(q) = y_coord(p);
7173 gr_left_x(q) = left_x(p);
7174 gr_left_y(q) = left_y(p);
7175 gr_right_x(q) = right_x(p);
7176 gr_right_y(q) = right_y(p);
7177 gr_originator(q) = originator(p);
7181 @ The |export_knot_list| routine therefore also makes a clone
7185 mp_knot *mp_export_knot_list (MP mp, pointer p) {
7186 mp_knot *q, *qq; /* for list manipulation */
7187 pointer pp; /* for list manipulation */
7190 q=mp_export_knot(mp, p);
7193 gr_next_knot(qq)=mp_export_knot(mp, pp);
7194 qq=gr_next_knot(qq);
7202 @ Similarly, there's a way to copy the {\sl reverse\/} of a path. This procedure
7203 returns a pointer to the first node of the copy, if the path is a cycle,
7204 but to the final node of a non-cyclic copy. The global
7205 variable |path_tail| will point to the final node of the original path;
7206 this trick makes it easier to implement `\&{doublepath}'.
7208 All node types are assumed to be |endpoint| or |explicit| only.
7211 pointer mp_htap_ypoc (MP mp,pointer p) {
7212 pointer q,pp,qq,rr; /* for list manipulation */
7213 q=mp_get_node(mp, knot_node_size); /* this will correspond to |p| */
7216 right_type(qq)=left_type(pp); left_type(qq)=right_type(pp);
7217 x_coord(qq)=x_coord(pp); y_coord(qq)=y_coord(pp);
7218 right_x(qq)=left_x(pp); right_y(qq)=left_y(pp);
7219 left_x(qq)=right_x(pp); left_y(qq)=right_y(pp);
7220 originator(qq)=originator(pp);
7221 if ( link(pp)==p ) {
7222 link(q)=qq; mp->path_tail=pp; return q;
7224 rr=mp_get_node(mp, knot_node_size); link(rr)=qq; qq=rr; pp=link(pp);
7229 pointer path_tail; /* the node that links to the beginning of a path */
7231 @ When a cyclic list of knot nodes is no longer needed, it can be recycled by
7232 calling the following subroutine.
7234 @<Declare the recycling subroutines@>=
7235 void mp_toss_knot_list (MP mp,pointer p) ;
7238 void mp_toss_knot_list (MP mp,pointer p) {
7239 pointer q; /* the node being freed */
7240 pointer r; /* the next node */
7244 mp_free_node(mp, q,knot_node_size); q=r;
7248 @* \[18] Choosing control points.
7249 Now we must actually delve into one of \MP's more difficult routines,
7250 the |make_choices| procedure that chooses angles and control points for
7251 the splines of a curve when the user has not specified them explicitly.
7252 The parameter to |make_choices| points to a list of knots and
7253 path information, as described above.
7255 A path decomposes into independent segments at ``breakpoint'' knots,
7256 which are knots whose left and right angles are both prespecified in
7257 some way (i.e., their |left_type| and |right_type| aren't both open).
7260 @<Declare the procedure called |solve_choices|@>
7261 void mp_make_choices (MP mp,pointer knots) {
7262 pointer h; /* the first breakpoint */
7263 pointer p,q; /* consecutive breakpoints being processed */
7264 @<Other local variables for |make_choices|@>;
7265 check_arith; /* make sure that |arith_error=false| */
7266 if ( mp->internal[mp_tracing_choices]>0 )
7267 mp_print_path(mp, knots,", before choices",true);
7268 @<If consecutive knots are equal, join them explicitly@>;
7269 @<Find the first breakpoint, |h|, on the path;
7270 insert an artificial breakpoint if the path is an unbroken cycle@>;
7273 @<Fill in the control points between |p| and the next breakpoint,
7274 then advance |p| to that breakpoint@>;
7276 if ( mp->internal[mp_tracing_choices]>0 )
7277 mp_print_path(mp, knots,", after choices",true);
7278 if ( mp->arith_error ) {
7279 @<Report an unexpected problem during the choice-making@>;
7283 @ @<Report an unexpected problem during the choice...@>=
7285 print_err("Some number got too big");
7286 @.Some number got too big@>
7287 help2("The path that I just computed is out of range.")
7288 ("So it will probably look funny. Proceed, for a laugh.");
7289 mp_put_get_error(mp); mp->arith_error=false;
7292 @ Two knots in a row with the same coordinates will always be joined
7293 by an explicit ``curve'' whose control points are identical with the
7296 @<If consecutive knots are equal, join them explicitly@>=
7300 if ( x_coord(p)==x_coord(q) && y_coord(p)==y_coord(q) && right_type(p)>mp_explicit ) {
7301 right_type(p)=mp_explicit;
7302 if ( left_type(p)==mp_open ) {
7303 left_type(p)=mp_curl; left_curl(p)=unity;
7305 left_type(q)=mp_explicit;
7306 if ( right_type(q)==mp_open ) {
7307 right_type(q)=mp_curl; right_curl(q)=unity;
7309 right_x(p)=x_coord(p); left_x(q)=x_coord(p);
7310 right_y(p)=y_coord(p); left_y(q)=y_coord(p);
7315 @ If there are no breakpoints, it is necessary to compute the direction
7316 angles around an entire cycle. In this case the |left_type| of the first
7317 node is temporarily changed to |end_cycle|.
7319 @<Find the first breakpoint, |h|, on the path...@>=
7322 if ( left_type(h)!=mp_open ) break;
7323 if ( right_type(h)!=mp_open ) break;
7326 left_type(h)=mp_end_cycle; break;
7330 @ If |right_type(p)<given| and |q=link(p)|, we must have
7331 |right_type(p)=left_type(q)=mp_explicit| or |endpoint|.
7333 @<Fill in the control points between |p| and the next breakpoint...@>=
7335 if ( right_type(p)>=mp_given ) {
7336 while ( (left_type(q)==mp_open)&&(right_type(q)==mp_open) ) q=link(q);
7337 @<Fill in the control information between
7338 consecutive breakpoints |p| and |q|@>;
7339 } else if ( right_type(p)==mp_endpoint ) {
7340 @<Give reasonable values for the unused control points between |p| and~|q|@>;
7344 @ This step makes it possible to transform an explicitly computed path without
7345 checking the |left_type| and |right_type| fields.
7347 @<Give reasonable values for the unused control points between |p| and~|q|@>=
7349 right_x(p)=x_coord(p); right_y(p)=y_coord(p);
7350 left_x(q)=x_coord(q); left_y(q)=y_coord(q);
7353 @ Before we can go further into the way choices are made, we need to
7354 consider the underlying theory. The basic ideas implemented in |make_choices|
7355 are due to John Hobby, who introduced the notion of ``mock curvature''
7356 @^Hobby, John Douglas@>
7357 at a knot. Angles are chosen so that they preserve mock curvature when
7358 a knot is passed, and this has been found to produce excellent results.
7360 It is convenient to introduce some notations that simplify the necessary
7361 formulas. Let $d_{k,k+1}=\vert z\k-z_k\vert$ be the (nonzero) distance
7362 between knots |k| and |k+1|; and let
7363 $${z\k-z_k\over z_k-z_{k-1}}={d_{k,k+1}\over d_{k-1,k}}e^{i\psi_k}$$
7364 so that a polygonal line from $z_{k-1}$ to $z_k$ to $z\k$ turns left
7365 through an angle of~$\psi_k$. We assume that $\vert\psi_k\vert\L180^\circ$.
7366 The control points for the spline from $z_k$ to $z\k$ will be denoted by
7367 $$\eqalign{z_k^+&=z_k+
7368 \textstyle{1\over3}\rho_k e^{i\theta_k}(z\k-z_k),\cr
7370 \textstyle{1\over3}\sigma\k e^{-i\phi\k}(z\k-z_k),\cr}$$
7371 where $\rho_k$ and $\sigma\k$ are nonnegative ``velocity ratios'' at the
7372 beginning and end of the curve, while $\theta_k$ and $\phi\k$ are the
7373 corresponding ``offset angles.'' These angles satisfy the condition
7374 $$\theta_k+\phi_k+\psi_k=0,\eqno(*)$$
7375 whenever the curve leaves an intermediate knot~|k| in the direction that
7378 @ Let $\alpha_k$ and $\beta\k$ be the reciprocals of the ``tension'' of
7379 the curve at its beginning and ending points. This means that
7380 $\rho_k=\alpha_k f(\theta_k,\phi\k)$ and $\sigma\k=\beta\k f(\phi\k,\theta_k)$,
7381 where $f(\theta,\phi)$ is \MP's standard velocity function defined in
7382 the |velocity| subroutine. The cubic spline $B(z_k^{\phantom+},z_k^+,
7383 z\k^-,z\k^{\phantom+};t)$
7386 $${2\sigma\k\sin(\theta_k+\phi\k)-6\sin\theta_k\over\rho_k^2d_{k,k+1}}
7387 \qquad{\rm and}\qquad
7388 {2\rho_k\sin(\theta_k+\phi\k)-6\sin\phi\k\over\sigma\k^2d_{k,k+1}}$$
7389 at |t=0| and |t=1|, respectively. The mock curvature is the linear
7391 approximation to this true curvature that arises in the limit for
7392 small $\theta_k$ and~$\phi\k$, if second-order terms are discarded.
7393 The standard velocity function satisfies
7394 $$f(\theta,\phi)=1+O(\theta^2+\theta\phi+\phi^2);$$
7395 hence the mock curvatures are respectively
7396 $${2\beta\k(\theta_k+\phi\k)-6\theta_k\over\alpha_k^2d_{k,k+1}}
7397 \qquad{\rm and}\qquad
7398 {2\alpha_k(\theta_k+\phi\k)-6\phi\k\over\beta\k^2d_{k,k+1}}.\eqno(**)$$
7400 @ The turning angles $\psi_k$ are given, and equation $(*)$ above
7401 determines $\phi_k$ when $\theta_k$ is known, so the task of
7402 angle selection is essentially to choose appropriate values for each
7403 $\theta_k$. When equation~$(*)$ is used to eliminate $\phi$~variables
7404 from $(**)$, we obtain a system of linear equations of the form
7405 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
7407 $$A_k={\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
7408 \qquad B_k={3-\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
7409 \qquad C_k={3-\beta\k\over\alpha_k^2d_{k,k+1}},
7410 \qquad D_k={\beta\k\over\alpha_k^2d_{k,k+1}}.$$
7411 The tensions are always $3\over4$ or more, hence each $\alpha$ and~$\beta$
7412 will be at most $4\over3$. It follows that $B_k\G{5\over4}A_k$ and
7413 $C_k\G{5\over4}D_k$; hence the equations are diagonally dominant;
7414 hence they have a unique solution. Moreover, in most cases the tensions
7415 are equal to~1, so that $B_k=2A_k$ and $C_k=2D_k$. This makes the
7416 solution numerically stable, and there is an exponential damping
7417 effect: The data at knot $k\pm j$ affects the angle at knot~$k$ by
7418 a factor of~$O(2^{-j})$.
7420 @ However, we still must consider the angles at the starting and ending
7421 knots of a non-cyclic path. These angles might be given explicitly, or
7422 they might be specified implicitly in terms of an amount of ``curl.''
7424 Let's assume that angles need to be determined for a non-cyclic path
7425 starting at $z_0$ and ending at~$z_n$. Then equations of the form
7426 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta_{k+1}=R_k$$
7427 have been given for $0<k<n$, and it will be convenient to introduce
7428 equations of the same form for $k=0$ and $k=n$, where
7429 $$A_0=B_0=C_n=D_n=0.$$
7430 If $\theta_0$ is supposed to have a given value $E_0$, we simply
7431 define $C_0=1$, $D_0=0$, and $R_0=E_0$. Otherwise a curl
7432 parameter, $\gamma_0$, has been specified at~$z_0$; this means
7433 that the mock curvature at $z_0$ should be $\gamma_0$ times the
7434 mock curvature at $z_1$; i.e.,
7435 $${2\beta_1(\theta_0+\phi_1)-6\theta_0\over\alpha_0^2d_{01}}
7436 =\gamma_0{2\alpha_0(\theta_0+\phi_1)-6\phi_1\over\beta_1^2d_{01}}.$$
7437 This equation simplifies to
7438 $$(\alpha_0\chi_0+3-\beta_1)\theta_0+
7439 \bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\theta_1=
7440 -\bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\psi_1,$$
7441 where $\chi_0=\alpha_0^2\gamma_0/\beta_1^2$; so we can set $C_0=
7442 \chi_0\alpha_0+3-\beta_1$, $D_0=(3-\alpha_0)\chi_0+\beta_1$, $R_0=-D_0\psi_1$.
7443 It can be shown that $C_0>0$ and $C_0B_1-A_1D_0>0$ when $\gamma_0\G0$,
7444 hence the linear equations remain nonsingular.
7446 Similar considerations apply at the right end, when the final angle $\phi_n$
7447 may or may not need to be determined. It is convenient to let $\psi_n=0$,
7448 hence $\theta_n=-\phi_n$. We either have an explicit equation $\theta_n=E_n$,
7450 $$\bigl((3-\beta_n)\chi_n+\alpha_{n-1}\bigr)\theta_{n-1}+
7451 (\beta_n\chi_n+3-\alpha_{n-1})\theta_n=0,\qquad
7452 \chi_n={\beta_n^2\gamma_n\over\alpha_{n-1}^2}.$$
7454 When |make_choices| chooses angles, it must compute the coefficients of
7455 these linear equations, then solve the equations. To compute the coefficients,
7456 it is necessary to compute arctangents of the given turning angles~$\psi_k$.
7457 When the equations are solved, the chosen directions $\theta_k$ are put
7458 back into the form of control points by essentially computing sines and
7461 @ OK, we are ready to make the hard choices of |make_choices|.
7462 Most of the work is relegated to an auxiliary procedure
7463 called |solve_choices|, which has been introduced to keep
7464 |make_choices| from being extremely long.
7466 @<Fill in the control information between...@>=
7467 @<Calculate the turning angles $\psi_k$ and the distances $d_{k,k+1}$;
7468 set $n$ to the length of the path@>;
7469 @<Remove |open| types at the breakpoints@>;
7470 mp_solve_choices(mp, p,q,n)
7472 @ It's convenient to precompute quantities that will be needed several
7473 times later. The values of |delta_x[k]| and |delta_y[k]| will be the
7474 coordinates of $z\k-z_k$, and the magnitude of this vector will be
7475 |delta[k]=@t$d_{k,k+1}$@>|. The path angle $\psi_k$ between $z_k-z_{k-1}$
7476 and $z\k-z_k$ will be stored in |psi[k]|.
7479 int path_size; /* maximum number of knots between breakpoints of a path */
7482 scaled *delta; /* knot differences */
7483 angle *psi; /* turning angles */
7485 @ @<Allocate or initialize ...@>=
7491 @ @<Dealloc variables@>=
7497 @ @<Other local variables for |make_choices|@>=
7498 int k,n; /* current and final knot numbers */
7499 pointer s,t; /* registers for list traversal */
7500 scaled delx,dely; /* directions where |open| meets |explicit| */
7501 fraction sine,cosine; /* trig functions of various angles */
7503 @ @<Calculate the turning angles...@>=
7506 k=0; s=p; n=mp->path_size;
7509 mp->delta_x[k]=x_coord(t)-x_coord(s);
7510 mp->delta_y[k]=y_coord(t)-y_coord(s);
7511 mp->delta[k]=mp_pyth_add(mp, mp->delta_x[k],mp->delta_y[k]);
7513 sine=mp_make_fraction(mp, mp->delta_y[k-1],mp->delta[k-1]);
7514 cosine=mp_make_fraction(mp, mp->delta_x[k-1],mp->delta[k-1]);
7515 mp->psi[k]=mp_n_arg(mp, mp_take_fraction(mp, mp->delta_x[k],cosine)+
7516 mp_take_fraction(mp, mp->delta_y[k],sine),
7517 mp_take_fraction(mp, mp->delta_y[k],cosine)-
7518 mp_take_fraction(mp, mp->delta_x[k],sine));
7521 if ( k==mp->path_size ) {
7522 mp_reallocate_paths(mp, mp->path_size+(mp->path_size>>2));
7523 goto RESTART; /* retry, loop size has changed */
7526 } while (!((k>=n)&&(left_type(s)!=mp_end_cycle)));
7527 if ( k==n ) mp->psi[n]=0; else mp->psi[k]=mp->psi[1];
7530 @ When we get to this point of the code, |right_type(p)| is either
7531 |given| or |curl| or |open|. If it is |open|, we must have
7532 |left_type(p)=mp_end_cycle| or |left_type(p)=mp_explicit|. In the latter
7533 case, the |open| type is converted to |given|; however, if the
7534 velocity coming into this knot is zero, the |open| type is
7535 converted to a |curl|, since we don't know the incoming direction.
7537 Similarly, |left_type(q)| is either |given| or |curl| or |open| or
7538 |mp_end_cycle|. The |open| possibility is reduced either to |given| or to |curl|.
7540 @<Remove |open| types at the breakpoints@>=
7541 if ( left_type(q)==mp_open ) {
7542 delx=right_x(q)-x_coord(q); dely=right_y(q)-y_coord(q);
7543 if ( (delx==0)&&(dely==0) ) {
7544 left_type(q)=mp_curl; left_curl(q)=unity;
7546 left_type(q)=mp_given; left_given(q)=mp_n_arg(mp, delx,dely);
7549 if ( (right_type(p)==mp_open)&&(left_type(p)==mp_explicit) ) {
7550 delx=x_coord(p)-left_x(p); dely=y_coord(p)-left_y(p);
7551 if ( (delx==0)&&(dely==0) ) {
7552 right_type(p)=mp_curl; right_curl(p)=unity;
7554 right_type(p)=mp_given; right_given(p)=mp_n_arg(mp, delx,dely);
7558 @ Linear equations need to be solved whenever |n>1|; and also when |n=1|
7559 and exactly one of the breakpoints involves a curl. The simplest case occurs
7560 when |n=1| and there is a curl at both breakpoints; then we simply draw
7563 But before coding up the simple cases, we might as well face the general case,
7564 since we must deal with it sooner or later, and since the general case
7565 is likely to give some insight into the way simple cases can be handled best.
7567 When there is no cycle, the linear equations to be solved form a tridiagonal
7568 system, and we can apply the standard technique of Gaussian elimination
7569 to convert that system to a sequence of equations of the form
7570 $$\theta_0+u_0\theta_1=v_0,\quad
7571 \theta_1+u_1\theta_2=v_1,\quad\ldots,\quad
7572 \theta_{n-1}+u_{n-1}\theta_n=v_{n-1},\quad
7574 It is possible to do this diagonalization while generating the equations.
7575 Once $\theta_n$ is known, it is easy to determine $\theta_{n-1}$, \dots,
7576 $\theta_1$, $\theta_0$; thus, the equations will be solved.
7578 The procedure is slightly more complex when there is a cycle, but the
7579 basic idea will be nearly the same. In the cyclic case the right-hand
7580 sides will be $v_k+w_k\theta_0$ instead of simply $v_k$, and we will start
7581 the process off with $u_0=v_0=0$, $w_0=1$. The final equation will be not
7582 $\theta_n=v_n$ but $\theta_n+u_n\theta_1=v_n+w_n\theta_0$; an appropriate
7583 ending routine will take account of the fact that $\theta_n=\theta_0$ and
7584 eliminate the $w$'s from the system, after which the solution can be
7587 When $u_k$, $v_k$, and $w_k$ are being computed, the three pointer
7588 variables |r|, |s|,~|t| will point respectively to knots |k-1|, |k|,
7589 and~|k+1|. The $u$'s and $w$'s are scaled by $2^{28}$, i.e., they are
7590 of type |fraction|; the $\theta$'s and $v$'s are of type |angle|.
7593 angle *theta; /* values of $\theta_k$ */
7594 fraction *uu; /* values of $u_k$ */
7595 angle *vv; /* values of $v_k$ */
7596 fraction *ww; /* values of $w_k$ */
7598 @ @<Allocate or initialize ...@>=
7604 @ @<Dealloc variables@>=
7610 @ @<Declare |mp_reallocate| functions@>=
7611 void mp_reallocate_paths (MP mp, int l);
7614 void mp_reallocate_paths (MP mp, int l) {
7615 XREALLOC (mp->delta_x, l, scaled);
7616 XREALLOC (mp->delta_y, l, scaled);
7617 XREALLOC (mp->delta, l, scaled);
7618 XREALLOC (mp->psi, l, angle);
7619 XREALLOC (mp->theta, l, angle);
7620 XREALLOC (mp->uu, l, fraction);
7621 XREALLOC (mp->vv, l, angle);
7622 XREALLOC (mp->ww, l, fraction);
7626 @ Our immediate problem is to get the ball rolling by setting up the
7627 first equation or by realizing that no equations are needed, and to fit
7628 this initialization into a framework suitable for the overall computation.
7630 @<Declare the procedure called |solve_choices|@>=
7631 @<Declare subroutines needed by |solve_choices|@>
7632 void mp_solve_choices (MP mp,pointer p, pointer q, halfword n) {
7633 int k; /* current knot number */
7634 pointer r,s,t; /* registers for list traversal */
7635 @<Other local variables for |solve_choices|@>;
7640 @<Get the linear equations started; or |return|
7641 with the control points in place, if linear equations
7644 switch (left_type(s)) {
7645 case mp_end_cycle: case mp_open:
7646 @<Set up equation to match mock curvatures
7647 at $z_k$; then |goto found| with $\theta_n$
7648 adjusted to equal $\theta_0$, if a cycle has ended@>;
7651 @<Set up equation for a curl at $\theta_n$
7655 @<Calculate the given value of $\theta_n$
7658 } /* there are no other cases */
7663 @<Finish choosing angles and assigning control points@>;
7666 @ On the first time through the loop, we have |k=0| and |r| is not yet
7667 defined. The first linear equation, if any, will have $A_0=B_0=0$.
7669 @<Get the linear equations started...@>=
7670 switch (right_type(s)) {
7672 if ( left_type(t)==mp_given ) {
7673 @<Reduce to simple case of two givens and |return|@>
7675 @<Set up the equation for a given value of $\theta_0$@>;
7679 if ( left_type(t)==mp_curl ) {
7680 @<Reduce to simple case of straight line and |return|@>
7682 @<Set up the equation for a curl at $\theta_0$@>;
7686 mp->uu[0]=0; mp->vv[0]=0; mp->ww[0]=fraction_one;
7687 /* this begins a cycle */
7689 } /* there are no other cases */
7691 @ The general equation that specifies equality of mock curvature at $z_k$ is
7692 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
7693 as derived above. We want to combine this with the already-derived equation
7694 $\theta_{k-1}+u_{k-1}\theta_k=v_{k-1}+w_{k-1}\theta_0$ in order to obtain
7696 $\theta_k+u_k\theta\k=v_k+w_k\theta_0$. This can be done by dividing the
7698 $$(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}
7699 -A_kw_{k-1}\theta_0$$
7700 by $B_k-u_{k-1}A_k+C_k$. The trick is to do this carefully with
7701 fixed-point arithmetic, avoiding the chance of overflow while retaining
7704 The calculations will be performed in several registers that
7705 provide temporary storage for intermediate quantities.
7707 @<Other local variables for |solve_choices|@>=
7708 fraction aa,bb,cc,ff,acc; /* temporary registers */
7709 scaled dd,ee; /* likewise, but |scaled| */
7710 scaled lt,rt; /* tension values */
7712 @ @<Set up equation to match mock curvatures...@>=
7713 { @<Calculate the values $\\{aa}=A_k/B_k$, $\\{bb}=D_k/C_k$,
7714 $\\{dd}=(3-\alpha_{k-1})d_{k,k+1}$, $\\{ee}=(3-\beta\k)d_{k-1,k}$,
7715 and $\\{cc}=(B_k-u_{k-1}A_k)/B_k$@>;
7716 @<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>;
7717 mp->uu[k]=mp_take_fraction(mp, ff,bb);
7718 @<Calculate the values of $v_k$ and $w_k$@>;
7719 if ( left_type(s)==mp_end_cycle ) {
7720 @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>;
7724 @ Since tension values are never less than 3/4, the values |aa| and
7725 |bb| computed here are never more than 4/5.
7727 @<Calculate the values $\\{aa}=...@>=
7728 if ( abs(right_tension(r))==unity) {
7729 aa=fraction_half; dd=2*mp->delta[k];
7731 aa=mp_make_fraction(mp, unity,3*abs(right_tension(r))-unity);
7732 dd=mp_take_fraction(mp, mp->delta[k],
7733 fraction_three-mp_make_fraction(mp, unity,abs(right_tension(r))));
7735 if ( abs(left_tension(t))==unity ){
7736 bb=fraction_half; ee=2*mp->delta[k-1];
7738 bb=mp_make_fraction(mp, unity,3*abs(left_tension(t))-unity);
7739 ee=mp_take_fraction(mp, mp->delta[k-1],
7740 fraction_three-mp_make_fraction(mp, unity,abs(left_tension(t))));
7742 cc=fraction_one-mp_take_fraction(mp, mp->uu[k-1],aa)
7744 @ The ratio to be calculated in this step can be written in the form
7745 $$\beta_k^2\cdot\\{ee}\over\beta_k^2\cdot\\{ee}+\alpha_k^2\cdot
7746 \\{cc}\cdot\\{dd},$$
7747 because of the quantities just calculated. The values of |dd| and |ee|
7748 will not be needed after this step has been performed.
7750 @<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>=
7751 dd=mp_take_fraction(mp, dd,cc); lt=abs(left_tension(s)); rt=abs(right_tension(s));
7752 if ( lt!=rt ) { /* $\beta_k^{-1}\ne\alpha_k^{-1}$ */
7754 ff=mp_make_fraction(mp, lt,rt);
7755 ff=mp_take_fraction(mp, ff,ff); /* $\alpha_k^2/\beta_k^2$ */
7756 dd=mp_take_fraction(mp, dd,ff);
7758 ff=mp_make_fraction(mp, rt,lt);
7759 ff=mp_take_fraction(mp, ff,ff); /* $\beta_k^2/\alpha_k^2$ */
7760 ee=mp_take_fraction(mp, ee,ff);
7763 ff=mp_make_fraction(mp, ee,ee+dd)
7765 @ The value of $u_{k-1}$ will be |<=1| except when $k=1$ and the previous
7766 equation was specified by a curl. In that case we must use a special
7767 method of computation to prevent overflow.
7769 Fortunately, the calculations turn out to be even simpler in this ``hard''
7770 case. The curl equation makes $w_0=0$ and $v_0=-u_0\psi_1$, hence
7771 $-B_1\psi_1-A_1v_0=-(B_1-u_0A_1)\psi_1=-\\{cc}\cdot B_1\psi_1$.
7773 @<Calculate the values of $v_k$ and $w_k$@>=
7774 acc=-mp_take_fraction(mp, mp->psi[k+1],mp->uu[k]);
7775 if ( right_type(r)==mp_curl ) {
7777 mp->vv[k]=acc-mp_take_fraction(mp, mp->psi[1],fraction_one-ff);
7779 ff=mp_make_fraction(mp, fraction_one-ff,cc); /* this is
7780 $B_k/(C_k+B_k-u_{k-1}A_k)<5$ */
7781 acc=acc-mp_take_fraction(mp, mp->psi[k],ff);
7782 ff=mp_take_fraction(mp, ff,aa); /* this is $A_k/(C_k+B_k-u_{k-1}A_k)$ */
7783 mp->vv[k]=acc-mp_take_fraction(mp, mp->vv[k-1],ff);
7784 if ( mp->ww[k-1]==0 ) mp->ww[k]=0;
7785 else mp->ww[k]=-mp_take_fraction(mp, mp->ww[k-1],ff);
7788 @ When a complete cycle has been traversed, we have $\theta_k+u_k\theta\k=
7789 v_k+w_k\theta_0$, for |1<=k<=n|. We would like to determine the value of
7790 $\theta_n$ and reduce the system to the form $\theta_k+u_k\theta\k=v_k$
7791 for |0<=k<n|, so that the cyclic case can be finished up just as if there
7794 The idea in the following code is to observe that
7795 $$\eqalign{\theta_n&=v_n+w_n\theta_0-u_n\theta_1=\cdots\cr
7796 &=v_n+w_n\theta_0-u_n\bigl(v_1+w_1\theta_0-u_1(v_2+\cdots
7797 -u_{n-2}(v_{n-1}+w_{n-1}\theta_0-u_{n-1}\theta_0))\bigr),\cr}$$
7798 so we can solve for $\theta_n=\theta_0$.
7800 @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>=
7802 aa=0; bb=fraction_one; /* we have |k=n| */
7805 aa=mp->vv[k]-mp_take_fraction(mp, aa,mp->uu[k]);
7806 bb=mp->ww[k]-mp_take_fraction(mp, bb,mp->uu[k]);
7807 } while (k!=n); /* now $\theta_n=\\{aa}+\\{bb}\cdot\theta_n$ */
7808 aa=mp_make_fraction(mp, aa,fraction_one-bb);
7809 mp->theta[n]=aa; mp->vv[0]=aa;
7810 for (k=1;k<=n-1;k++) {
7811 mp->vv[k]=mp->vv[k]+mp_take_fraction(mp, aa,mp->ww[k]);
7816 @ @d reduce_angle(A) if ( abs((A))>one_eighty_deg ) {
7817 if ( (A)>0 ) (A)=(A)-three_sixty_deg; else (A)=(A)+three_sixty_deg; }
7819 @<Calculate the given value of $\theta_n$...@>=
7821 mp->theta[n]=left_given(s)-mp_n_arg(mp, mp->delta_x[n-1],mp->delta_y[n-1]);
7822 reduce_angle(mp->theta[n]);
7826 @ @<Set up the equation for a given value of $\theta_0$@>=
7828 mp->vv[0]=right_given(s)-mp_n_arg(mp, mp->delta_x[0],mp->delta_y[0]);
7829 reduce_angle(mp->vv[0]);
7830 mp->uu[0]=0; mp->ww[0]=0;
7833 @ @<Set up the equation for a curl at $\theta_0$@>=
7834 { cc=right_curl(s); lt=abs(left_tension(t)); rt=abs(right_tension(s));
7835 if ( (rt==unity)&&(lt==unity) )
7836 mp->uu[0]=mp_make_fraction(mp, cc+cc+unity,cc+two);
7838 mp->uu[0]=mp_curl_ratio(mp, cc,rt,lt);
7839 mp->vv[0]=-mp_take_fraction(mp, mp->psi[1],mp->uu[0]); mp->ww[0]=0;
7842 @ @<Set up equation for a curl at $\theta_n$...@>=
7843 { cc=left_curl(s); lt=abs(left_tension(s)); rt=abs(right_tension(r));
7844 if ( (rt==unity)&&(lt==unity) )
7845 ff=mp_make_fraction(mp, cc+cc+unity,cc+two);
7847 ff=mp_curl_ratio(mp, cc,lt,rt);
7848 mp->theta[n]=-mp_make_fraction(mp, mp_take_fraction(mp, mp->vv[n-1],ff),
7849 fraction_one-mp_take_fraction(mp, ff,mp->uu[n-1]));
7853 @ The |curl_ratio| subroutine has three arguments, which our previous notation
7854 encourages us to call $\gamma$, $\alpha^{-1}$, and $\beta^{-1}$. It is
7855 a somewhat tedious program to calculate
7856 $${(3-\alpha)\alpha^2\gamma+\beta^3\over
7857 \alpha^3\gamma+(3-\beta)\beta^2},$$
7858 with the result reduced to 4 if it exceeds 4. (This reduction of curl
7859 is necessary only if the curl and tension are both large.)
7860 The values of $\alpha$ and $\beta$ will be at most~4/3.
7862 @<Declare subroutines needed by |solve_choices|@>=
7863 fraction mp_curl_ratio (MP mp,scaled gamma, scaled a_tension,
7865 fraction alpha,beta,num,denom,ff; /* registers */
7866 alpha=mp_make_fraction(mp, unity,a_tension);
7867 beta=mp_make_fraction(mp, unity,b_tension);
7868 if ( alpha<=beta ) {
7869 ff=mp_make_fraction(mp, alpha,beta); ff=mp_take_fraction(mp, ff,ff);
7870 gamma=mp_take_fraction(mp, gamma,ff);
7871 beta=beta / 010000; /* convert |fraction| to |scaled| */
7872 denom=mp_take_fraction(mp, gamma,alpha)+three-beta;
7873 num=mp_take_fraction(mp, gamma,fraction_three-alpha)+beta;
7875 ff=mp_make_fraction(mp, beta,alpha); ff=mp_take_fraction(mp, ff,ff);
7876 beta=mp_take_fraction(mp, beta,ff) / 010000; /* convert |fraction| to |scaled| */
7877 denom=mp_take_fraction(mp, gamma,alpha)+(ff / 1365)-beta;
7878 /* $1365\approx 2^{12}/3$ */
7879 num=mp_take_fraction(mp, gamma,fraction_three-alpha)+beta;
7881 if ( num>=denom+denom+denom+denom ) return fraction_four;
7882 else return mp_make_fraction(mp, num,denom);
7885 @ We're in the home stretch now.
7887 @<Finish choosing angles and assigning control points@>=
7888 for (k=n-1;k>=0;k--) {
7889 mp->theta[k]=mp->vv[k]-mp_take_fraction(mp,mp->theta[k+1],mp->uu[k]);
7894 mp_n_sin_cos(mp, mp->theta[k]); mp->st=mp->n_sin; mp->ct=mp->n_cos;
7895 mp_n_sin_cos(mp, -mp->psi[k+1]-mp->theta[k+1]); mp->sf=mp->n_sin; mp->cf=mp->n_cos;
7896 mp_set_controls(mp, s,t,k);
7900 @ The |set_controls| routine actually puts the control points into
7901 a pair of consecutive nodes |p| and~|q|. Global variables are used to
7902 record the values of $\sin\theta$, $\cos\theta$, $\sin\phi$, and
7903 $\cos\phi$ needed in this calculation.
7909 fraction cf; /* sines and cosines */
7911 @ @<Declare subroutines needed by |solve_choices|@>=
7912 void mp_set_controls (MP mp,pointer p, pointer q, integer k) {
7913 fraction rr,ss; /* velocities, divided by thrice the tension */
7914 scaled lt,rt; /* tensions */
7915 fraction sine; /* $\sin(\theta+\phi)$ */
7916 lt=abs(left_tension(q)); rt=abs(right_tension(p));
7917 rr=mp_velocity(mp, mp->st,mp->ct,mp->sf,mp->cf,rt);
7918 ss=mp_velocity(mp, mp->sf,mp->cf,mp->st,mp->ct,lt);
7919 if ( (right_tension(p)<0)||(left_tension(q)<0) ) {
7920 @<Decrease the velocities,
7921 if necessary, to stay inside the bounding triangle@>;
7923 right_x(p)=x_coord(p)+mp_take_fraction(mp,
7924 mp_take_fraction(mp, mp->delta_x[k],mp->ct)-
7925 mp_take_fraction(mp, mp->delta_y[k],mp->st),rr);
7926 right_y(p)=y_coord(p)+mp_take_fraction(mp,
7927 mp_take_fraction(mp, mp->delta_y[k],mp->ct)+
7928 mp_take_fraction(mp, mp->delta_x[k],mp->st),rr);
7929 left_x(q)=x_coord(q)-mp_take_fraction(mp,
7930 mp_take_fraction(mp, mp->delta_x[k],mp->cf)+
7931 mp_take_fraction(mp, mp->delta_y[k],mp->sf),ss);
7932 left_y(q)=y_coord(q)-mp_take_fraction(mp,
7933 mp_take_fraction(mp, mp->delta_y[k],mp->cf)-
7934 mp_take_fraction(mp, mp->delta_x[k],mp->sf),ss);
7935 right_type(p)=mp_explicit; left_type(q)=mp_explicit;
7938 @ The boundedness conditions $\\{rr}\L\sin\phi\,/\sin(\theta+\phi)$ and
7939 $\\{ss}\L\sin\theta\,/\sin(\theta+\phi)$ are to be enforced if $\sin\theta$,
7940 $\sin\phi$, and $\sin(\theta+\phi)$ all have the same sign. Otherwise
7941 there is no ``bounding triangle.''
7943 @<Decrease the velocities, if necessary...@>=
7944 if (((mp->st>=0)&&(mp->sf>=0))||((mp->st<=0)&&(mp->sf<=0)) ) {
7945 sine=mp_take_fraction(mp, abs(mp->st),mp->cf)+
7946 mp_take_fraction(mp, abs(mp->sf),mp->ct);
7948 sine=mp_take_fraction(mp, sine,fraction_one+unity); /* safety factor */
7949 if ( right_tension(p)<0 )
7950 if ( mp_ab_vs_cd(mp, abs(mp->sf),fraction_one,rr,sine)<0 )
7951 rr=mp_make_fraction(mp, abs(mp->sf),sine);
7952 if ( left_tension(q)<0 )
7953 if ( mp_ab_vs_cd(mp, abs(mp->st),fraction_one,ss,sine)<0 )
7954 ss=mp_make_fraction(mp, abs(mp->st),sine);
7958 @ Only the simple cases remain to be handled.
7960 @<Reduce to simple case of two givens and |return|@>=
7962 aa=mp_n_arg(mp, mp->delta_x[0],mp->delta_y[0]);
7963 mp_n_sin_cos(mp, right_given(p)-aa); mp->ct=mp->n_cos; mp->st=mp->n_sin;
7964 mp_n_sin_cos(mp, left_given(q)-aa); mp->cf=mp->n_cos; mp->sf=-mp->n_sin;
7965 mp_set_controls(mp, p,q,0); return;
7968 @ @<Reduce to simple case of straight line and |return|@>=
7970 right_type(p)=mp_explicit; left_type(q)=mp_explicit;
7971 lt=abs(left_tension(q)); rt=abs(right_tension(p));
7973 if ( mp->delta_x[0]>=0 ) right_x(p)=x_coord(p)+((mp->delta_x[0]+1) / 3);
7974 else right_x(p)=x_coord(p)+((mp->delta_x[0]-1) / 3);
7975 if ( mp->delta_y[0]>=0 ) right_y(p)=y_coord(p)+((mp->delta_y[0]+1) / 3);
7976 else right_y(p)=y_coord(p)+((mp->delta_y[0]-1) / 3);
7978 ff=mp_make_fraction(mp, unity,3*rt); /* $\alpha/3$ */
7979 right_x(p)=x_coord(p)+mp_take_fraction(mp, mp->delta_x[0],ff);
7980 right_y(p)=y_coord(p)+mp_take_fraction(mp, mp->delta_y[0],ff);
7983 if ( mp->delta_x[0]>=0 ) left_x(q)=x_coord(q)-((mp->delta_x[0]+1) / 3);
7984 else left_x(q)=x_coord(q)-((mp->delta_x[0]-1) / 3);
7985 if ( mp->delta_y[0]>=0 ) left_y(q)=y_coord(q)-((mp->delta_y[0]+1) / 3);
7986 else left_y(q)=y_coord(q)-((mp->delta_y[0]-1) / 3);
7988 ff=mp_make_fraction(mp, unity,3*lt); /* $\beta/3$ */
7989 left_x(q)=x_coord(q)-mp_take_fraction(mp, mp->delta_x[0],ff);
7990 left_y(q)=y_coord(q)-mp_take_fraction(mp, mp->delta_y[0],ff);
7995 @* \[19] Measuring paths.
7996 \MP's \&{llcorner}, \&{lrcorner}, \&{ulcorner}, and \&{urcorner} operators
7997 allow the user to measure the bounding box of anything that can go into a
7998 picture. It's easy to get rough bounds on the $x$ and $y$ extent of a path
7999 by just finding the bounding box of the knots and the control points. We
8000 need a more accurate version of the bounding box, but we can still use the
8001 easy estimate to save time by focusing on the interesting parts of the path.
8003 @ Computing an accurate bounding box involves a theme that will come up again
8004 and again. Given a Bernshte{\u\i}n polynomial
8005 @^Bernshte{\u\i}n, Serge{\u\i} Natanovich@>
8006 $$B(z_0,z_1,\ldots,z_n;t)=\sum_k{n\choose k}t^k(1-t)^{n-k}z_k,$$
8007 we can conveniently bisect its range as follows:
8010 \textindent{1)} Let $z_k^{(0)}=z_k$, for |0<=k<=n|.
8013 \textindent{2)} Let $z_k^{(j+1)}={1\over2}(z_k^{(j)}+z\k^{(j)})$, for
8014 |0<=k<n-j|, for |0<=j<n|.
8018 $$B(z_0,z_1,\ldots,z_n;t)=B(z_0^{(0)},z_0^{(1)},\ldots,z_0^{(n)};2t)
8019 =B(z_0^{(n)},z_1^{(n-1)},\ldots,z_n^{(0)};2t-1).$$
8020 This formula gives us the coefficients of polynomials to use over the ranges
8021 $0\L t\L{1\over2}$ and ${1\over2}\L t\L1$.
8023 @ Now here's a subroutine that's handy for all sorts of path computations:
8024 Given a quadratic polynomial $B(a,b,c;t)$, the |crossing_point| function
8025 returns the unique |fraction| value |t| between 0 and~1 at which
8026 $B(a,b,c;t)$ changes from positive to negative, or returns
8027 |t=fraction_one+1| if no such value exists. If |a<0| (so that $B(a,b,c;t)$
8028 is already negative at |t=0|), |crossing_point| returns the value zero.
8030 @d no_crossing { return (fraction_one+1); }
8031 @d one_crossing { return fraction_one; }
8032 @d zero_crossing { return 0; }
8033 @d mp_crossing_point(M,A,B,C) mp_do_crossing_point(A,B,C)
8035 @c fraction mp_do_crossing_point (integer a, integer b, integer c) {
8036 integer d; /* recursive counter */
8037 integer x,xx,x0,x1,x2; /* temporary registers for bisection */
8038 if ( a<0 ) zero_crossing;
8041 if ( c>0 ) { no_crossing; }
8042 else if ( (a==0)&&(b==0) ) { no_crossing;}
8043 else { one_crossing; }
8045 if ( a==0 ) zero_crossing;
8046 } else if ( a==0 ) {
8047 if ( b<=0 ) zero_crossing;
8049 @<Use bisection to find the crossing point, if one exists@>;
8052 @ The general bisection method is quite simple when $n=2$, hence
8053 |crossing_point| does not take much time. At each stage in the
8054 recursion we have a subinterval defined by |l| and~|j| such that
8055 $B(a,b,c;2^{-l}(j+t))=B(x_0,x_1,x_2;t)$, and we want to ``zero in'' on
8056 the subinterval where $x_0\G0$ and $\min(x_1,x_2)<0$.
8058 It is convenient for purposes of calculation to combine the values
8059 of |l| and~|j| in a single variable $d=2^l+j$, because the operation
8060 of bisection then corresponds simply to doubling $d$ and possibly
8061 adding~1. Furthermore it proves to be convenient to modify
8062 our previous conventions for bisection slightly, maintaining the
8063 variables $X_0=2^lx_0$, $X_1=2^l(x_0-x_1)$, and $X_2=2^l(x_1-x_2)$.
8064 With these variables the conditions $x_0\ge0$ and $\min(x_1,x_2)<0$ are
8065 equivalent to $\max(X_1,X_1+X_2)>X_0\ge0$.
8067 The following code maintains the invariant relations
8068 $0\L|x0|<\max(|x1|,|x1|+|x2|)$,
8069 $\vert|x1|\vert<2^{30}$, $\vert|x2|\vert<2^{30}$;
8070 it has been constructed in such a way that no arithmetic overflow
8071 will occur if the inputs satisfy
8072 $a<2^{30}$, $\vert a-b\vert<2^{30}$, and $\vert b-c\vert<2^{30}$.
8074 @<Use bisection to find the crossing point...@>=
8075 d=1; x0=a; x1=a-b; x2=b-c;
8086 if ( x<=x0 ) { if ( x+x2<=x0 ) no_crossing; }
8090 } while (d<fraction_one);
8091 return (d-fraction_one)
8093 @ Here is a routine that computes the $x$ or $y$ coordinate of the point on
8094 a cubic corresponding to the |fraction| value~|t|.
8096 It is convenient to define a \.{WEB} macro |t_of_the_way| such that
8097 |t_of_the_way(a,b)| expands to |a-(a-b)*t|, i.e., to |t[a,b]|.
8099 @d t_of_the_way(A,B) ((A)-mp_take_fraction(mp,((A)-(B)),t))
8101 @c scaled mp_eval_cubic (MP mp,pointer p, pointer q, fraction t) {
8102 scaled x1,x2,x3; /* intermediate values */
8103 x1=t_of_the_way(knot_coord(p),right_coord(p));
8104 x2=t_of_the_way(right_coord(p),left_coord(q));
8105 x3=t_of_the_way(left_coord(q),knot_coord(q));
8106 x1=t_of_the_way(x1,x2);
8107 x2=t_of_the_way(x2,x3);
8108 return t_of_the_way(x1,x2);
8111 @ The actual bounding box information is stored in global variables.
8112 Since it is convenient to address the $x$ and $y$ information
8113 separately, we define arrays indexed by |x_code..y_code| and use
8114 macros to give them more convenient names.
8118 mp_x_code=0, /* index for |minx| and |maxx| */
8119 mp_y_code /* index for |miny| and |maxy| */
8123 @d minx mp->bbmin[mp_x_code]
8124 @d maxx mp->bbmax[mp_x_code]
8125 @d miny mp->bbmin[mp_y_code]
8126 @d maxy mp->bbmax[mp_y_code]
8129 scaled bbmin[mp_y_code+1];
8130 scaled bbmax[mp_y_code+1];
8131 /* the result of procedures that compute bounding box information */
8133 @ Now we're ready for the key part of the bounding box computation.
8134 The |bound_cubic| procedure updates |bbmin[c]| and |bbmax[c]| based on
8135 $$B(\hbox{|knot_coord(p)|}, \hbox{|right_coord(p)|},
8136 \hbox{|left_coord(q)|}, \hbox{|knot_coord(q)|};t)
8138 for $0<t\le1$. In other words, the procedure adjusts the bounds to
8139 accommodate |knot_coord(q)| and any extremes over the range $0<t<1$.
8140 The |c| parameter is |x_code| or |y_code|.
8142 @c void mp_bound_cubic (MP mp,pointer p, pointer q, small_number c) {
8143 boolean wavy; /* whether we need to look for extremes */
8144 scaled del1,del2,del3,del,dmax; /* proportional to the control
8145 points of a quadratic derived from a cubic */
8146 fraction t,tt; /* where a quadratic crosses zero */
8147 scaled x; /* a value that |bbmin[c]| and |bbmax[c]| must accommodate */
8149 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8150 @<Check the control points against the bounding box and set |wavy:=true|
8151 if any of them lie outside@>;
8153 del1=right_coord(p)-knot_coord(p);
8154 del2=left_coord(q)-right_coord(p);
8155 del3=knot_coord(q)-left_coord(q);
8156 @<Scale up |del1|, |del2|, and |del3| for greater accuracy;
8157 also set |del| to the first nonzero element of |(del1,del2,del3)|@>;
8159 negate(del1); negate(del2); negate(del3);
8161 t=mp_crossing_point(mp, del1,del2,del3);
8162 if ( t<fraction_one ) {
8163 @<Test the extremes of the cubic against the bounding box@>;
8168 @ @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>=
8169 if ( x<mp->bbmin[c] ) mp->bbmin[c]=x;
8170 if ( x>mp->bbmax[c] ) mp->bbmax[c]=x
8172 @ @<Check the control points against the bounding box and set...@>=
8174 if ( mp->bbmin[c]<=right_coord(p) )
8175 if ( right_coord(p)<=mp->bbmax[c] )
8176 if ( mp->bbmin[c]<=left_coord(q) )
8177 if ( left_coord(q)<=mp->bbmax[c] )
8180 @ If |del1=del2=del3=0|, it's impossible to obey the title of this
8181 section. We just set |del=0| in that case.
8183 @<Scale up |del1|, |del2|, and |del3| for greater accuracy...@>=
8184 if ( del1!=0 ) del=del1;
8185 else if ( del2!=0 ) del=del2;
8189 if ( abs(del2)>dmax ) dmax=abs(del2);
8190 if ( abs(del3)>dmax ) dmax=abs(del3);
8191 while ( dmax<fraction_half ) {
8192 dmax+=dmax; del1+=del1; del2+=del2; del3+=del3;
8196 @ Since |crossing_point| has tried to choose |t| so that
8197 $B(|del1|,|del2|,|del3|;\tau)$ crosses zero at $\tau=|t|$ with negative
8198 slope, the value of |del2| computed below should not be positive.
8199 But rounding error could make it slightly positive in which case we
8200 must cut it to zero to avoid confusion.
8202 @<Test the extremes of the cubic against the bounding box@>=
8204 x=mp_eval_cubic(mp, p,q,t);
8205 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8206 del2=t_of_the_way(del2,del3);
8207 /* now |0,del2,del3| represent the derivative on the remaining interval */
8208 if ( del2>0 ) del2=0;
8209 tt=mp_crossing_point(mp, 0,-del2,-del3);
8210 if ( tt<fraction_one ) {
8211 @<Test the second extreme against the bounding box@>;
8215 @ @<Test the second extreme against the bounding box@>=
8217 x=mp_eval_cubic(mp, p,q,t_of_the_way(tt,fraction_one));
8218 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8221 @ Finding the bounding box of a path is basically a matter of applying
8222 |bound_cubic| twice for each pair of adjacent knots.
8224 @c void mp_path_bbox (MP mp,pointer h) {
8225 pointer p,q; /* a pair of adjacent knots */
8226 minx=x_coord(h); miny=y_coord(h);
8227 maxx=minx; maxy=miny;
8230 if ( right_type(p)==mp_endpoint ) return;
8232 mp_bound_cubic(mp, x_loc(p),x_loc(q),mp_x_code);
8233 mp_bound_cubic(mp, y_loc(p),y_loc(q),mp_y_code);
8238 @ Another important way to measure a path is to find its arc length. This
8239 is best done by using the general bisection algorithm to subdivide the path
8240 until obtaining ``well behaved'' subpaths whose arc lengths can be approximated
8243 Since the arc length is the integral with respect to time of the magnitude of
8244 the velocity, it is natural to use Simpson's rule for the approximation.
8246 If $\dot B(t)$ is the spline velocity, Simpson's rule gives
8247 $$ \vb\dot B(0)\vb + 4\vb\dot B({1\over2})\vb + \vb\dot B(1)\vb \over 6 $$
8248 for the arc length of a path of length~1. For a cubic spline
8249 $B(z_0,z_1,z_2,z_3;t)$, the time derivative $\dot B(t)$ is
8250 $3B(dz_0,dz_1,dz_2;t)$, where $dz_i=z_{i+1}-z_i$. Hence the arc length
8252 $$ {\vb dz_0\vb \over 2} + 2\vb dz_{02}\vb + {\vb dz_2\vb \over 2}, $$
8254 $$ dz_{02}={1\over2}\left({dz_0+dz_1\over 2}+{dz_1+dz_2\over 2}\right)$$
8255 is the result of the bisection algorithm.
8257 @ The remaining problem is how to decide when a subpath is ``well behaved.''
8258 This could be done via the theoretical error bound for Simpson's rule,
8260 but this is impractical because it requires an estimate of the fourth
8261 derivative of the quantity being integrated. It is much easier to just perform
8262 a bisection step and see how much the arc length estimate changes. Since the
8263 error for Simpson's rule is proportional to the fourth power of the sample
8264 spacing, the remaining error is typically about $1\over16$ of the amount of
8265 the change. We say ``typically'' because the error has a pseudo-random behavior
8266 that could cause the two estimates to agree when each contain large errors.
8268 To protect against disasters such as undetected cusps, the bisection process
8269 should always continue until all the $dz_i$ vectors belong to a single
8270 $90^\circ$ sector. This ensures that no point on the spline can have velocity
8271 less than 70\% of the minimum of $\vb dz_0\vb$, $\vb dz_1\vb$ and $\vb dz_2\vb$.
8272 If such a spline happens to produce an erroneous arc length estimate that
8273 is little changed by bisection, the amount of the error is likely to be fairly
8274 small. We will try to arrange things so that freak accidents of this type do
8275 not destroy the inverse relationship between the \&{arclength} and
8276 \&{arctime} operations.
8277 @:arclength_}{\&{arclength} primitive@>
8278 @:arctime_}{\&{arctime} primitive@>
8280 @ The \&{arclength} and \&{arctime} operations are both based on a recursive
8282 function that finds the arc length of a cubic spline given $dz_0$, $dz_1$,
8283 $dz_2$. This |arc_test| routine also takes an arc length goal |a_goal| and
8284 returns the time when the arc length reaches |a_goal| if there is such a time.
8285 Thus the return value is either an arc length less than |a_goal| or, if the
8286 arc length would be at least |a_goal|, it returns a time value decreased by
8287 |two|. This allows the caller to use the sign of the result to distinguish
8288 between arc lengths and time values. On certain types of overflow, it is
8289 possible for |a_goal| and the result of |arc_test| both to be |el_gordo|.
8290 Otherwise, the result is always less than |a_goal|.
8292 Rather than halving the control point coordinates on each recursive call to
8293 |arc_test|, it is better to keep them proportional to velocity on the original
8294 curve and halve the results instead. This means that recursive calls can
8295 potentially use larger error tolerances in their arc length estimates. How
8296 much larger depends on to what extent the errors behave as though they are
8297 independent of each other. To save computing time, we use optimistic assumptions
8298 and increase the tolerance by a factor of about $\sqrt2$ for each recursive
8301 In addition to the tolerance parameter, |arc_test| should also have parameters
8302 for ${1\over3}\vb\dot B(0)\vb$, ${2\over3}\vb\dot B({1\over2})\vb$, and
8303 ${1\over3}\vb\dot B(1)\vb$. These quantities are relatively expensive to compute
8304 and they are needed in different instances of |arc_test|.
8306 @c @<Declare subroutines needed by |arc_test|@>
8307 scaled mp_arc_test (MP mp, scaled dx0, scaled dy0, scaled dx1, scaled dy1,
8308 scaled dx2, scaled dy2, scaled v0, scaled v02,
8309 scaled v2, scaled a_goal, scaled tol) {
8310 boolean simple; /* are the control points confined to a $90^\circ$ sector? */
8311 scaled dx01, dy01, dx12, dy12, dx02, dy02; /* bisection results */
8313 /* twice the velocity magnitudes at $t={1\over4}$ and $t={3\over4}$ */
8314 scaled arc; /* best arc length estimate before recursion */
8315 @<Other local variables in |arc_test|@>;
8316 @<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,
8318 @<Initialize |v002|, |v022|, and the arc length estimate |arc|; if it overflows
8319 set |arc_test| and |return|@>;
8320 @<Test if the control points are confined to one quadrant or rotating them
8321 $45^\circ$ would put them in one quadrant. Then set |simple| appropriately@>;
8322 if ( simple && (abs(arc-v02-halfp(v0+v2)) <= tol) ) {
8323 if ( arc < a_goal ) {
8326 @<Estimate when the arc length reaches |a_goal| and set |arc_test| to
8327 that time minus |two|@>;
8330 @<Use one or two recursive calls to compute the |arc_test| function@>;
8334 @ The |tol| value should by multiplied by $\sqrt 2$ before making recursive
8335 calls, but $1.5$ is an adequate approximation. It is best to avoid using
8336 |make_fraction| in this inner loop.
8339 @<Use one or two recursive calls to compute the |arc_test| function@>=
8341 @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is as
8342 large as possible@>;
8343 tol = tol + halfp(tol);
8344 a = mp_arc_test(mp, dx0,dy0, dx01,dy01, dx02,dy02, v0, v002,
8345 halfp(v02), a_new, tol);
8347 return (-halfp(two-a));
8349 @<Update |a_new| to reduce |a_new+a_aux| by |a|@>;
8350 b = mp_arc_test(mp, dx02,dy02, dx12,dy12, dx2,dy2,
8351 halfp(v02), v022, v2, a_new, tol);
8353 return (-halfp(-b) - half_unit);
8355 return (a + half(b-a));
8359 @ @<Other local variables in |arc_test|@>=
8360 scaled a,b; /* results of recursive calls */
8361 scaled a_new,a_aux; /* the sum of these gives the |a_goal| */
8363 @ @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is...@>=
8364 a_aux = el_gordo - a_goal;
8365 if ( a_goal > a_aux ) {
8366 a_aux = a_goal - a_aux;
8369 a_new = a_goal + a_goal;
8373 @ There is no need to maintain |a_aux| at this point so we use it as a temporary
8374 to force the additions and subtractions to be done in an order that avoids
8377 @<Update |a_new| to reduce |a_new+a_aux| by |a|@>=
8380 a_new = a_new + a_aux;
8383 @ This code assumes all {\it dx} and {\it dy} variables have magnitude less than
8384 |fraction_four|. To simplify the rest of the |arc_test| routine, we strengthen
8385 this assumption by requiring the norm of each $({\it dx},{\it dy})$ pair to obey
8386 this bound. Note that recursive calls will maintain this invariant.
8388 @<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,...@>=
8389 dx01 = half(dx0 + dx1);
8390 dx12 = half(dx1 + dx2);
8391 dx02 = half(dx01 + dx12);
8392 dy01 = half(dy0 + dy1);
8393 dy12 = half(dy1 + dy2);
8394 dy02 = half(dy01 + dy12)
8396 @ We should be careful to keep |arc<el_gordo| so that calling |arc_test| with
8397 |a_goal=el_gordo| is guaranteed to yield the arc length.
8399 @<Initialize |v002|, |v022|, and the arc length estimate |arc|;...@>=
8400 v002 = mp_pyth_add(mp, dx01+half(dx0+dx02), dy01+half(dy0+dy02));
8401 v022 = mp_pyth_add(mp, dx12+half(dx02+dx2), dy12+half(dy02+dy2));
8403 arc1 = v002 + half(halfp(v0+tmp) - v002);
8404 arc = v022 + half(halfp(v2+tmp) - v022);
8405 if ( (arc < el_gordo-arc1) ) {
8408 mp->arith_error = true;
8409 if ( a_goal==el_gordo ) return (el_gordo);
8413 @ @<Other local variables in |arc_test|@>=
8414 scaled tmp, tmp2; /* all purpose temporary registers */
8415 scaled arc1; /* arc length estimate for the first half */
8417 @ @<Test if the control points are confined to one quadrant or rotating...@>=
8418 simple = ((dx0>=0) && (dx1>=0) && (dx2>=0)) ||
8419 ((dx0<=0) && (dx1<=0) && (dx2<=0));
8421 simple = ((dy0>=0) && (dy1>=0) && (dy2>=0)) ||
8422 ((dy0<=0) && (dy1<=0) && (dy2<=0));
8424 simple = ((dx0>=dy0) && (dx1>=dy1) && (dx2>=dy2)) ||
8425 ((dx0<=dy0) && (dx1<=dy1) && (dx2<=dy2));
8427 simple = ((-dx0>=dy0) && (-dx1>=dy1) && (-dx2>=dy2)) ||
8428 ((-dx0<=dy0) && (-dx1<=dy1) && (-dx2<=dy2));
8431 @ Since Simpson's rule is based on approximating the integrand by a parabola,
8433 it is appropriate to use the same approximation to decide when the integral
8434 reaches the intermediate value |a_goal|. At this point
8436 {\vb\dot B(0)\vb\over 3} &= \hbox{|v0|}, \qquad
8437 {\vb\dot B({1\over4})\vb\over 3} = {\hbox{|v002|}\over 2}, \qquad
8438 {\vb\dot B({1\over2})\vb\over 3} = {\hbox{|v02|}\over 2}, \cr
8439 {\vb\dot B({3\over4})\vb\over 3} &= {\hbox{|v022|}\over 2}, \qquad
8440 {\vb\dot B(1)\vb\over 3} = \hbox{|v2|} \cr
8444 $$ {\vb\dot B(t)\vb\over 3} \approx
8445 \cases{B\left(\hbox{|v0|},
8446 \hbox{|v002|}-{1\over 2}\hbox{|v0|}-{1\over 4}\hbox{|v02|},
8447 {1\over 2}\hbox{|v02|}; 2t \right)&
8448 if $t\le{1\over 2}$\cr
8449 B\left({1\over 2}\hbox{|v02|},
8450 \hbox{|v022|}-{1\over 4}\hbox{|v02|}-{1\over 2}\hbox{|v2|},
8451 \hbox{|v2|}; 2t-1 \right)&
8452 if $t\ge{1\over 2}$.\cr}
8455 We can integrate $\vb\dot B(t)\vb$ by using
8456 $$\int 3B(a,b,c;\tau)\,dt =
8457 {B(0,a,a+b,a+b+c;\tau) + {\rm constant} \over {d\tau\over dt}}.
8460 This construction allows us to find the time when the arc length reaches
8461 |a_goal| by solving a cubic equation of the form
8462 $$ B(0,a,a+b,a+b+c;\tau) = x, $$
8463 where $\tau$ is $2t$ or $2t+1$, $x$ is |a_goal| or |a_goal-arc1|, and $a$, $b$,
8464 and $c$ are the Bernshte{\u\i}n coefficients from $(*)$ divided by
8465 @^Bernshte{\u\i}n, Serge{\u\i} Natanovich@>
8466 $d\tau\over dt$. We shall define a function |solve_rising_cubic| that finds
8467 $\tau$ given $a$, $b$, $c$, and $x$.
8469 @<Estimate when the arc length reaches |a_goal| and set |arc_test| to...@>=
8471 tmp = (v02 + 2) / 4;
8472 if ( a_goal<=arc1 ) {
8475 (halfp(mp_solve_rising_cubic(mp, tmp2, arc1-tmp2-tmp, tmp, a_goal))- two);
8478 return ((half_unit - two) +
8479 halfp(mp_solve_rising_cubic(mp, tmp, arc-arc1-tmp-tmp2, tmp2, a_goal-arc1)));
8483 @ Here is the |solve_rising_cubic| routine that finds the time~$t$ when
8484 $$ B(0, a, a+b, a+b+c; t) = x. $$
8485 This routine is based on |crossing_point| but is simplified by the
8486 assumptions that $B(a,b,c;t)\ge0$ for $0\le t\le1$ and that |0<=x<=a+b+c|.
8487 If rounding error causes this condition to be violated slightly, we just ignore
8488 it and proceed with binary search. This finds a time when the function value
8489 reaches |x| and the slope is positive.
8491 @<Declare subroutines needed by |arc_test|@>=
8492 scaled mp_solve_rising_cubic (MP mp,scaled a, scaled b, scaled c, scaled x) {
8493 scaled ab, bc, ac; /* bisection results */
8494 integer t; /* $2^k+q$ where unscaled answer is in $[q2^{-k},(q+1)2^{-k})$ */
8495 integer xx; /* temporary for updating |x| */
8496 if ( (a<0) || (c<0) ) mp_confusion(mp, "rising?");
8497 @:this can't happen rising?}{\quad rising?@>
8500 } else if ( x >= a+b+c ) {
8504 @<Rescale if necessary to make sure |a|, |b|, and |c| are all less than
8508 @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>;
8509 xx = x - a - ab - ac;
8510 if ( xx < -x ) { x+=x; b=ab; c=ac; }
8511 else { x = x + xx; a=ac; b=bc; t = t+1; };
8512 } while (t < unity);
8517 @ @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>=
8522 @ @d one_third_el_gordo 05252525252 /* upper bound on |a|, |b|, and |c| */
8524 @<Rescale if necessary to make sure |a|, |b|, and |c| are all less than...@>=
8525 while ((a>one_third_el_gordo)||(b>one_third_el_gordo)||(c>one_third_el_gordo)) {
8532 @ It is convenient to have a simpler interface to |arc_test| that requires no
8533 unnecessary arguments and ensures that each $({\it dx},{\it dy})$ pair has
8534 length less than |fraction_four|.
8536 @d arc_tol 16 /* quit when change in arc length estimate reaches this */
8538 @c scaled mp_do_arc_test (MP mp,scaled dx0, scaled dy0, scaled dx1,
8539 scaled dy1, scaled dx2, scaled dy2, scaled a_goal) {
8540 scaled v0,v1,v2; /* length of each $({\it dx},{\it dy})$ pair */
8541 scaled v02; /* twice the norm of the quadratic at $t={1\over2}$ */
8542 v0 = mp_pyth_add(mp, dx0,dy0);
8543 v1 = mp_pyth_add(mp, dx1,dy1);
8544 v2 = mp_pyth_add(mp, dx2,dy2);
8545 if ( (v0>=fraction_four) || (v1>=fraction_four) || (v2>=fraction_four) ) {
8546 mp->arith_error = true;
8547 if ( a_goal==el_gordo ) return el_gordo;
8550 v02 = mp_pyth_add(mp, dx1+half(dx0+dx2), dy1+half(dy0+dy2));
8551 return (mp_arc_test(mp, dx0,dy0, dx1,dy1, dx2,dy2,
8552 v0, v02, v2, a_goal, arc_tol));
8556 @ Now it is easy to find the arc length of an entire path.
8558 @c scaled mp_get_arc_length (MP mp,pointer h) {
8559 pointer p,q; /* for traversing the path */
8560 scaled a,a_tot; /* current and total arc lengths */
8563 while ( right_type(p)!=mp_endpoint ){
8565 a = mp_do_arc_test(mp, right_x(p)-x_coord(p), right_y(p)-y_coord(p),
8566 left_x(q)-right_x(p), left_y(q)-right_y(p),
8567 x_coord(q)-left_x(q), y_coord(q)-left_y(q), el_gordo);
8568 a_tot = mp_slow_add(mp, a, a_tot);
8569 if ( q==h ) break; else p=q;
8575 @ The inverse operation of finding the time on a path~|h| when the arc length
8576 reaches some value |arc0| can also be accomplished via |do_arc_test|. Some care
8577 is required to handle very large times or negative times on cyclic paths. For
8578 non-cyclic paths, |arc0| values that are negative or too large cause
8579 |get_arc_time| to return 0 or the length of path~|h|.
8581 If |arc0| is greater than the arc length of a cyclic path~|h|, the result is a
8582 time value greater than the length of the path. Since it could be much greater,
8583 we must be prepared to compute the arc length of path~|h| and divide this into
8584 |arc0| to find how many multiples of the length of path~|h| to add.
8586 @c scaled mp_get_arc_time (MP mp,pointer h, scaled arc0) {
8587 pointer p,q; /* for traversing the path */
8588 scaled t_tot; /* accumulator for the result */
8589 scaled t; /* the result of |do_arc_test| */
8590 scaled arc; /* portion of |arc0| not used up so far */
8591 integer n; /* number of extra times to go around the cycle */
8593 @<Deal with a negative |arc0| value and |return|@>;
8595 if ( arc0==el_gordo ) decr(arc0);
8599 while ( (right_type(p)!=mp_endpoint) && (arc>0) ) {
8601 t = mp_do_arc_test(mp, right_x(p)-x_coord(p), right_y(p)-y_coord(p),
8602 left_x(q)-right_x(p), left_y(q)-right_y(p),
8603 x_coord(q)-left_x(q), y_coord(q)-left_y(q), arc);
8604 @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>;
8606 @<Update |t_tot| and |arc| to avoid going around the cyclic
8607 path too many times but set |arith_error:=true| and |goto done| on
8616 @ @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>=
8617 if ( t<0 ) { t_tot = t_tot + t + two; arc = 0; }
8618 else { t_tot = t_tot + unity; arc = arc - t; }
8620 @ @<Deal with a negative |arc0| value and |return|@>=
8622 if ( left_type(h)==mp_endpoint ) {
8625 p = mp_htap_ypoc(mp, h);
8626 t_tot = -mp_get_arc_time(mp, p, -arc0);
8627 mp_toss_knot_list(mp, p);
8633 @ @<Update |t_tot| and |arc| to avoid going around the cyclic...@>=
8635 n = arc / (arc0 - arc);
8636 arc = arc - n*(arc0 - arc);
8637 if ( t_tot > (el_gordo / (n+1)) ) {
8640 t_tot = (n + 1)*t_tot;
8643 @* \[20] Data structures for pens.
8644 A Pen in \MP\ can be either elliptical or polygonal. Elliptical pens result
8645 in \ps\ \&{stroke} commands, while anything drawn with a polygonal pen is
8646 @:stroke}{\&{stroke} command@>
8647 converted into an area fill as described in the next part of this program.
8648 The mathematics behind this process is based on simple aspects of the theory
8649 of tracings developed by Leo Guibas, Lyle Ramshaw, and Jorge Stolfi
8650 [``A kinematic framework for computational geometry,'' Proc.\ IEEE Symp.\
8651 Foundations of Computer Science {\bf 24} (1983), 100--111].
8653 Polygonal pens are created from paths via \MP's \&{makepen} primitive.
8654 @:makepen_}{\&{makepen} primitive@>
8655 This path representation is almost sufficient for our purposes except that
8656 a pen path should always be a convex polygon with the vertices in
8657 counter-clockwise order.
8658 Since we will need to scan pen polygons both forward and backward, a pen
8659 should be represented as a doubly linked ring of knot nodes. There is
8660 room for the extra back pointer because we do not need the
8661 |left_type| or |right_type| fields. In fact, we don't need the |left_x|,
8662 |left_y|, |right_x|, or |right_y| fields either but we leave these alone
8663 so that certain procedures can operate on both pens and paths. In particular,
8664 pens can be copied using |copy_path| and recycled using |toss_knot_list|.
8667 /* this replaces the |left_type| and |right_type| fields in a pen knot */
8669 @ The |make_pen| procedure turns a path into a pen by initializing
8670 the |knil| pointers and making sure the knots form a convex polygon.
8671 Thus each cubic in the given path becomes a straight line and the control
8672 points are ignored. If the path is not cyclic, the ends are connected by a
8675 @d copy_pen(A) mp_make_pen(mp, mp_copy_path(mp, (A)),false)
8677 @c @<Declare a function called |convex_hull|@>
8678 pointer mp_make_pen (MP mp,pointer h, boolean need_hull) {
8679 pointer p,q; /* two consecutive knots */
8686 h=mp_convex_hull(mp, h);
8687 @<Make sure |h| isn't confused with an elliptical pen@>;
8692 @ The only information required about an elliptical pen is the overall
8693 transformation that has been applied to the original \&{pencircle}.
8694 @:pencircle_}{\&{pencircle} primitive@>
8695 Since it suffices to keep track of how the three points $(0,0)$, $(1,0)$,
8696 and $(0,1)$ are transformed, an elliptical pen can be stored in a single
8697 knot node and transformed as if it were a path.
8699 @d pen_is_elliptical(A) ((A)==link((A)))
8701 @c pointer mp_get_pen_circle (MP mp,scaled diam) {
8702 pointer h; /* the knot node to return */
8703 h=mp_get_node(mp, knot_node_size);
8704 link(h)=h; knil(h)=h;
8705 originator(h)=mp_program_code;
8706 x_coord(h)=0; y_coord(h)=0;
8707 left_x(h)=diam; left_y(h)=0;
8708 right_x(h)=0; right_y(h)=diam;
8712 @ If the polygon being returned by |make_pen| has only one vertex, it will
8713 be interpreted as an elliptical pen. This is no problem since a degenerate
8714 polygon can equally well be thought of as a degenerate ellipse. We need only
8715 initialize the |left_x|, |left_y|, |right_x|, and |right_y| fields.
8717 @<Make sure |h| isn't confused with an elliptical pen@>=
8718 if ( pen_is_elliptical( h) ){
8719 left_x(h)=x_coord(h); left_y(h)=y_coord(h);
8720 right_x(h)=x_coord(h); right_y(h)=y_coord(h);
8723 @ We have to cheat a little here but most operations on pens only use
8724 the first three words in each knot node.
8725 @^data structure assumptions@>
8727 @<Initialize a pen at |test_pen| so that it fits in nine words@>=
8728 x_coord(test_pen)=-half_unit;
8729 y_coord(test_pen)=0;
8730 x_coord(test_pen+3)=half_unit;
8731 y_coord(test_pen+3)=0;
8732 x_coord(test_pen+6)=0;
8733 y_coord(test_pen+6)=unity;
8734 link(test_pen)=test_pen+3;
8735 link(test_pen+3)=test_pen+6;
8736 link(test_pen+6)=test_pen;
8737 knil(test_pen)=test_pen+6;
8738 knil(test_pen+3)=test_pen;
8739 knil(test_pen+6)=test_pen+3
8741 @ Printing a polygonal pen is very much like printing a path
8743 @<Declare subroutines for printing expressions@>=
8744 void mp_pr_pen (MP mp,pointer h) {
8745 pointer p,q; /* for list traversal */
8746 if ( pen_is_elliptical(h) ) {
8747 @<Print the elliptical pen |h|@>;
8751 mp_print_two(mp, x_coord(p),y_coord(p));
8752 mp_print_nl(mp, " .. ");
8753 @<Advance |p| making sure the links are OK and |return| if there is
8756 mp_print(mp, "cycle");
8760 @ @<Advance |p| making sure the links are OK and |return| if there is...@>=
8762 if ( (q==null) || (knil(q)!=p) ) {
8763 mp_print_nl(mp, "???"); return; /* this won't happen */
8768 @ @<Print the elliptical pen |h|@>=
8770 mp_print(mp, "pencircle transformed (");
8771 mp_print_scaled(mp, x_coord(h));
8772 mp_print_char(mp, ',');
8773 mp_print_scaled(mp, y_coord(h));
8774 mp_print_char(mp, ',');
8775 mp_print_scaled(mp, left_x(h)-x_coord(h));
8776 mp_print_char(mp, ',');
8777 mp_print_scaled(mp, right_x(h)-x_coord(h));
8778 mp_print_char(mp, ',');
8779 mp_print_scaled(mp, left_y(h)-y_coord(h));
8780 mp_print_char(mp, ',');
8781 mp_print_scaled(mp, right_y(h)-y_coord(h));
8782 mp_print_char(mp, ')');
8785 @ Here us another version of |pr_pen| that prints the pen as a diagnostic
8788 @<Declare subroutines for printing expressions@>=
8789 void mp_print_pen (MP mp,pointer h, const char *s, boolean nuline) {
8790 mp_print_diagnostic(mp, "Pen",s,nuline); mp_print_ln(mp);
8793 mp_end_diagnostic(mp, true);
8796 @ Making a polygonal pen into a path involves restoring the |left_type| and
8797 |right_type| fields and setting the control points so as to make a polygonal
8801 void mp_make_path (MP mp,pointer h) {
8802 pointer p; /* for traversing the knot list */
8803 small_number k; /* a loop counter */
8804 @<Other local variables in |make_path|@>;
8805 if ( pen_is_elliptical(h) ) {
8806 @<Make the elliptical pen |h| into a path@>;
8810 left_type(p)=mp_explicit;
8811 right_type(p)=mp_explicit;
8812 @<copy the coordinates of knot |p| into its control points@>;
8818 @ @<copy the coordinates of knot |p| into its control points@>=
8819 left_x(p)=x_coord(p);
8820 left_y(p)=y_coord(p);
8821 right_x(p)=x_coord(p);
8822 right_y(p)=y_coord(p)
8824 @ We need an eight knot path to get a good approximation to an ellipse.
8826 @<Make the elliptical pen |h| into a path@>=
8828 @<Extract the transformation parameters from the elliptical pen~|h|@>;
8830 for (k=0;k<=7;k++ ) {
8831 @<Initialize |p| as the |k|th knot of a circle of unit diameter,
8832 transforming it appropriately@>;
8833 if ( k==7 ) link(p)=h; else link(p)=mp_get_node(mp, knot_node_size);
8838 @ @<Extract the transformation parameters from the elliptical pen~|h|@>=
8839 center_x=x_coord(h);
8840 center_y=y_coord(h);
8841 width_x=left_x(h)-center_x;
8842 width_y=left_y(h)-center_y;
8843 height_x=right_x(h)-center_x;
8844 height_y=right_y(h)-center_y
8846 @ @<Other local variables in |make_path|@>=
8847 scaled center_x,center_y; /* translation parameters for an elliptical pen */
8848 scaled width_x,width_y; /* the effect of a unit change in $x$ */
8849 scaled height_x,height_y; /* the effect of a unit change in $y$ */
8850 scaled dx,dy; /* the vector from knot |p| to its right control point */
8852 /* |k| advanced $270^\circ$ around the ring (cf. $\sin\theta=\cos(\theta+270)$) */
8854 @ The only tricky thing here are the tables |half_cos| and |d_cos| used to
8855 find the point $k/8$ of the way around the circle and the direction vector
8858 @<Initialize |p| as the |k|th knot of a circle of unit diameter,...@>=
8860 x_coord(p)=center_x+mp_take_fraction(mp, mp->half_cos[k],width_x)
8861 +mp_take_fraction(mp, mp->half_cos[kk],height_x);
8862 y_coord(p)=center_y+mp_take_fraction(mp, mp->half_cos[k],width_y)
8863 +mp_take_fraction(mp, mp->half_cos[kk],height_y);
8864 dx=-mp_take_fraction(mp, mp->d_cos[kk],width_x)
8865 +mp_take_fraction(mp, mp->d_cos[k],height_x);
8866 dy=-mp_take_fraction(mp, mp->d_cos[kk],width_y)
8867 +mp_take_fraction(mp, mp->d_cos[k],height_y);
8868 right_x(p)=x_coord(p)+dx;
8869 right_y(p)=y_coord(p)+dy;
8870 left_x(p)=x_coord(p)-dx;
8871 left_y(p)=y_coord(p)-dy;
8872 left_type(p)=mp_explicit;
8873 right_type(p)=mp_explicit;
8874 originator(p)=mp_program_code
8877 fraction half_cos[8]; /* ${1\over2}\cos(45k)$ */
8878 fraction d_cos[8]; /* a magic constant times $\cos(45k)$ */
8880 @ The magic constant for |d_cos| is the distance between $({1\over2},0)$ and
8881 $({1\over4}\sqrt2,{1\over4}\sqrt2)$ times the result of the |velocity|
8882 function for $\theta=\phi=22.5^\circ$. This comes out to be
8883 $$ d = {\sqrt{2-\sqrt2}\over 3+3\cos22.5^\circ}
8884 \approx 0.132608244919772.
8888 mp->half_cos[0]=fraction_half;
8889 mp->half_cos[1]=94906266; /* $2^{26}\sqrt2\approx94906265.62$ */
8891 mp->d_cos[0]=35596755; /* $2^{28}d\approx35596754.69$ */
8892 mp->d_cos[1]=25170707; /* $2^{27}\sqrt2\,d\approx25170706.63$ */
8894 for (k=3;k<= 4;k++ ) {
8895 mp->half_cos[k]=-mp->half_cos[4-k];
8896 mp->d_cos[k]=-mp->d_cos[4-k];
8898 for (k=5;k<= 7;k++ ) {
8899 mp->half_cos[k]=mp->half_cos[8-k];
8900 mp->d_cos[k]=mp->d_cos[8-k];
8903 @ The |convex_hull| function forces a pen polygon to be convex when it is
8904 returned by |make_pen| and after any subsequent transformation where rounding
8905 error might allow the convexity to be lost.
8906 The convex hull algorithm used here is described by F.~P. Preparata and
8907 M.~I. Shamos [{\sl Computational Geometry}, Springer-Verlag, 1985].
8909 @<Declare a function called |convex_hull|@>=
8910 @<Declare a procedure called |move_knot|@>
8911 pointer mp_convex_hull (MP mp,pointer h) { /* Make a polygonal pen convex */
8912 pointer l,r; /* the leftmost and rightmost knots */
8913 pointer p,q; /* knots being scanned */
8914 pointer s; /* the starting point for an upcoming scan */
8915 scaled dx,dy; /* a temporary pointer */
8916 if ( pen_is_elliptical(h) ) {
8919 @<Set |l| to the leftmost knot in polygon~|h|@>;
8920 @<Set |r| to the rightmost knot in polygon~|h|@>;
8923 @<Find any knots on the path from |l| to |r| above the |l|-|r| line and
8924 move them past~|r|@>;
8925 @<Find any knots on the path from |s| to |l| below the |l|-|r| line and
8926 move them past~|l|@>;
8927 @<Sort the path from |l| to |r| by increasing $x$@>;
8928 @<Sort the path from |r| to |l| by decreasing $x$@>;
8931 @<Do a Gramm scan and remove vertices where there is no left turn@>;
8937 @ All comparisons are done primarily on $x$ and secondarily on $y$.
8939 @<Set |l| to the leftmost knot in polygon~|h|@>=
8943 if ( x_coord(p)<=x_coord(l) )
8944 if ( (x_coord(p)<x_coord(l)) || (y_coord(p)<y_coord(l)) )
8949 @ @<Set |r| to the rightmost knot in polygon~|h|@>=
8953 if ( x_coord(p)>=x_coord(r) )
8954 if ( (x_coord(p)>x_coord(r)) || (y_coord(p)>y_coord(r)) )
8959 @ @<Find any knots on the path from |l| to |r| above the |l|-|r| line...@>=
8960 dx=x_coord(r)-x_coord(l);
8961 dy=y_coord(r)-y_coord(l);
8965 if ( mp_ab_vs_cd(mp, dx,y_coord(p)-y_coord(l),dy,x_coord(p)-x_coord(l))>0 )
8966 mp_move_knot(mp, p, r);
8970 @ The |move_knot| procedure removes |p| from a doubly linked list and inserts
8973 @ @<Declare a procedure called |move_knot|@>=
8974 void mp_move_knot (MP mp,pointer p, pointer q) {
8975 link(knil(p))=link(p);
8976 knil(link(p))=knil(p);
8983 @ @<Find any knots on the path from |s| to |l| below the |l|-|r| line...@>=
8987 if ( mp_ab_vs_cd(mp, dx,y_coord(p)-y_coord(l),dy,x_coord(p)-x_coord(l))<0 )
8988 mp_move_knot(mp, p,l);
8992 @ The list is likely to be in order already so we just do linear insertions.
8993 Secondary comparisons on $y$ ensure that the sort is consistent with the
8994 choice of |l| and |r|.
8996 @<Sort the path from |l| to |r| by increasing $x$@>=
9000 while ( x_coord(q)>x_coord(p) ) q=knil(q);
9001 while ( x_coord(q)==x_coord(p) ) {
9002 if ( y_coord(q)>y_coord(p) ) q=knil(q); else break;
9004 if ( q==knil(p) ) p=link(p);
9005 else { p=link(p); mp_move_knot(mp, knil(p),q); };
9008 @ @<Sort the path from |r| to |l| by decreasing $x$@>=
9012 while ( x_coord(q)<x_coord(p) ) q=knil(q);
9013 while ( x_coord(q)==x_coord(p) ) {
9014 if ( y_coord(q)<y_coord(p) ) q=knil(q); else break;
9016 if ( q==knil(p) ) p=link(p);
9017 else { p=link(p); mp_move_knot(mp, knil(p),q); };
9020 @ The condition involving |ab_vs_cd| tests if there is not a left turn
9021 at knot |q|. There usually will be a left turn so we streamline the case
9022 where the |then| clause is not executed.
9024 @<Do a Gramm scan and remove vertices where there...@>=
9028 dx=x_coord(q)-x_coord(p);
9029 dy=y_coord(q)-y_coord(p);
9033 if ( mp_ab_vs_cd(mp, dx,y_coord(q)-y_coord(p),dy,x_coord(q)-x_coord(p))<=0 ) {
9034 @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>;
9039 @ @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>=
9042 mp_free_node(mp, p,knot_node_size);
9043 link(s)=q; knil(q)=s;
9045 else { p=knil(s); q=s; };
9048 @ The |find_offset| procedure sets global variables |(cur_x,cur_y)| to the
9049 offset associated with the given direction |(x,y)|. If two different offsets
9050 apply, it chooses one of them.
9053 void mp_find_offset (MP mp,scaled x, scaled y, pointer h) {
9054 pointer p,q; /* consecutive knots */
9056 /* the transformation matrix for an elliptical pen */
9057 fraction xx,yy; /* untransformed offset for an elliptical pen */
9058 fraction d; /* a temporary register */
9059 if ( pen_is_elliptical(h) ) {
9060 @<Find the offset for |(x,y)| on the elliptical pen~|h|@>
9065 } while (!(mp_ab_vs_cd(mp, x_coord(q)-x_coord(p),y, y_coord(q)-y_coord(p),x)>=0));
9068 } while (!(mp_ab_vs_cd(mp, x_coord(q)-x_coord(p),y, y_coord(q)-y_coord(p),x)<=0));
9069 mp->cur_x=x_coord(p);
9070 mp->cur_y=y_coord(p);
9076 scaled cur_y; /* all-purpose return value registers */
9078 @ @<Find the offset for |(x,y)| on the elliptical pen~|h|@>=
9079 if ( (x==0) && (y==0) ) {
9080 mp->cur_x=x_coord(h); mp->cur_y=y_coord(h);
9082 @<Find the non-constant part of the transformation for |h|@>;
9083 while ( (abs(x)<fraction_half) && (abs(y)<fraction_half) ){
9086 @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the
9087 untransformed version of |(x,y)|@>;
9088 mp->cur_x=x_coord(h)+mp_take_fraction(mp, xx,wx)+mp_take_fraction(mp, yy,hx);
9089 mp->cur_y=y_coord(h)+mp_take_fraction(mp, xx,wy)+mp_take_fraction(mp, yy,hy);
9092 @ @<Find the non-constant part of the transformation for |h|@>=
9093 wx=left_x(h)-x_coord(h);
9094 wy=left_y(h)-y_coord(h);
9095 hx=right_x(h)-x_coord(h);
9096 hy=right_y(h)-y_coord(h)
9098 @ @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the...@>=
9099 yy=-(mp_take_fraction(mp, x,hy)+mp_take_fraction(mp, y,-hx));
9100 xx=mp_take_fraction(mp, x,-wy)+mp_take_fraction(mp, y,wx);
9101 d=mp_pyth_add(mp, xx,yy);
9103 xx=half(mp_make_fraction(mp, xx,d));
9104 yy=half(mp_make_fraction(mp, yy,d));
9107 @ Finding the bounding box of a pen is easy except if the pen is elliptical.
9108 But we can handle that case by just calling |find_offset| twice. The answer
9109 is stored in the global variables |minx|, |maxx|, |miny|, and |maxy|.
9112 void mp_pen_bbox (MP mp,pointer h) {
9113 pointer p; /* for scanning the knot list */
9114 if ( pen_is_elliptical(h) ) {
9115 @<Find the bounding box of an elliptical pen@>;
9117 minx=x_coord(h); maxx=minx;
9118 miny=y_coord(h); maxy=miny;
9121 if ( x_coord(p)<minx ) minx=x_coord(p);
9122 if ( y_coord(p)<miny ) miny=y_coord(p);
9123 if ( x_coord(p)>maxx ) maxx=x_coord(p);
9124 if ( y_coord(p)>maxy ) maxy=y_coord(p);
9130 @ @<Find the bounding box of an elliptical pen@>=
9132 mp_find_offset(mp, 0,fraction_one,h);
9134 minx=2*x_coord(h)-mp->cur_x;
9135 mp_find_offset(mp, -fraction_one,0,h);
9137 miny=2*y_coord(h)-mp->cur_y;
9140 @* \[21] Edge structures.
9141 Now we come to \MP's internal scheme for representing pictures.
9142 The representation is very different from \MF's edge structures
9143 because \MP\ pictures contain \ps\ graphics objects instead of pixel
9144 images. However, the basic idea is somewhat similar in that shapes
9145 are represented via their boundaries.
9147 The main purpose of edge structures is to keep track of graphical objects
9148 until it is time to translate them into \ps. Since \MP\ does not need to
9149 know anything about an edge structure other than how to translate it into
9150 \ps\ and how to find its bounding box, edge structures can be just linked
9151 lists of graphical objects. \MP\ has no easy way to determine whether
9152 two such objects overlap, but it suffices to draw the first one first and
9153 let the second one overwrite it if necessary.
9156 enum mp_graphical_object_code {
9157 @<Graphical object codes@>
9161 @ Let's consider the types of graphical objects one at a time.
9162 First of all, a filled contour is represented by a eight-word node. The first
9163 word contains |type| and |link| fields, and the next six words contain a
9164 pointer to a cyclic path and the value to use for \ps' \&{currentrgbcolor}
9165 parameter. If a pen is used for filling |pen_p|, |ljoin_val| and |miterlim_val|
9166 give the relevant information.
9168 @d path_p(A) link((A)+1)
9169 /* a pointer to the path that needs filling */
9170 @d pen_p(A) info((A)+1)
9171 /* a pointer to the pen to fill or stroke with */
9172 @d color_model(A) type((A)+2) /* the color model */
9173 @d obj_red_loc(A) ((A)+3) /* the first of three locations for the color */
9174 @d obj_cyan_loc obj_red_loc /* the first of four locations for the color */
9175 @d obj_grey_loc obj_red_loc /* the location for the color */
9176 @d red_val(A) mp->mem[(A)+3].sc
9177 /* the red component of the color in the range $0\ldots1$ */
9180 @d green_val(A) mp->mem[(A)+4].sc
9181 /* the green component of the color in the range $0\ldots1$ */
9182 @d magenta_val green_val
9183 @d blue_val(A) mp->mem[(A)+5].sc
9184 /* the blue component of the color in the range $0\ldots1$ */
9185 @d yellow_val blue_val
9186 @d black_val(A) mp->mem[(A)+6].sc
9187 /* the blue component of the color in the range $0\ldots1$ */
9188 @d ljoin_val(A) name_type((A)) /* the value of \&{linejoin} */
9189 @:mp_linejoin_}{\&{linejoin} primitive@>
9190 @d miterlim_val(A) mp->mem[(A)+7].sc /* the value of \&{miterlimit} */
9191 @:mp_miterlimit_}{\&{miterlimit} primitive@>
9192 @d obj_color_part(A) mp->mem[(A)+3-red_part].sc
9193 /* interpret an object pointer that has been offset by |red_part..blue_part| */
9194 @d pre_script(A) mp->mem[(A)+8].hh.lh
9195 @d post_script(A) mp->mem[(A)+8].hh.rh
9198 @ @<Graphical object codes@>=
9202 pointer mp_new_fill_node (MP mp,pointer p) {
9203 /* make a fill node for cyclic path |p| and color black */
9204 pointer t; /* the new node */
9205 t=mp_get_node(mp, fill_node_size);
9206 type(t)=mp_fill_code;
9208 pen_p(t)=null; /* |null| means don't use a pen */
9213 color_model(t)=mp_uninitialized_model;
9215 post_script(t)=null;
9216 @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>;
9220 @ @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>=
9221 if ( mp->internal[mp_linejoin]>unity ) ljoin_val(t)=2;
9222 else if ( mp->internal[mp_linejoin]>0 ) ljoin_val(t)=1;
9223 else ljoin_val(t)=0;
9224 if ( mp->internal[mp_miterlimit]<unity )
9225 miterlim_val(t)=unity;
9227 miterlim_val(t)=mp->internal[mp_miterlimit]
9229 @ A stroked path is represented by an eight-word node that is like a filled
9230 contour node except that it contains the current \&{linecap} value, a scale
9231 factor for the dash pattern, and a pointer that is non-null if the stroke
9232 is to be dashed. The purpose of the scale factor is to allow a picture to
9233 be transformed without touching the picture that |dash_p| points to.
9235 @d dash_p(A) link((A)+9)
9236 /* a pointer to the edge structure that gives the dash pattern */
9237 @d lcap_val(A) type((A)+9)
9238 /* the value of \&{linecap} */
9239 @:mp_linecap_}{\&{linecap} primitive@>
9240 @d dash_scale(A) mp->mem[(A)+10].sc /* dash lengths are scaled by this factor */
9241 @d stroked_node_size 11
9243 @ @<Graphical object codes@>=
9247 pointer mp_new_stroked_node (MP mp,pointer p) {
9248 /* make a stroked node for path |p| with |pen_p(p)| temporarily |null| */
9249 pointer t; /* the new node */
9250 t=mp_get_node(mp, stroked_node_size);
9251 type(t)=mp_stroked_code;
9252 path_p(t)=p; pen_p(t)=null;
9254 dash_scale(t)=unity;
9259 color_model(t)=mp_uninitialized_model;
9261 post_script(t)=null;
9262 @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>;
9263 if ( mp->internal[mp_linecap]>unity ) lcap_val(t)=2;
9264 else if ( mp->internal[mp_linecap]>0 ) lcap_val(t)=1;
9269 @ When a dashed line is computed in a transformed coordinate system, the dash
9270 lengths get scaled like the pen shape and we need to compensate for this. Since
9271 there is no unique scale factor for an arbitrary transformation, we use the
9272 the square root of the determinant. The properties of the determinant make it
9273 easier to maintain the |dash_scale|. The computation is fairly straight-forward
9274 except for the initialization of the scale factor |s|. The factor of 64 is
9275 needed because |square_rt| scales its result by $2^8$ while we need $2^{14}$
9276 to counteract the effect of |take_fraction|.
9278 @<Declare subroutines needed by |print_edges|@>=
9279 scaled mp_sqrt_det (MP mp,scaled a, scaled b, scaled c, scaled d) {
9280 scaled maxabs; /* $max(|a|,|b|,|c|,|d|)$ */
9281 integer s; /* amount by which the result of |square_rt| needs to be scaled */
9282 @<Initialize |maxabs|@>;
9284 while ( (maxabs<fraction_one) && (s>1) ){
9285 a+=a; b+=b; c+=c; d+=d;
9286 maxabs+=maxabs; s=halfp(s);
9288 return s*mp_square_rt(mp, abs(mp_take_fraction(mp, a,d)-mp_take_fraction(mp, b,c)));
9291 scaled mp_get_pen_scale (MP mp,pointer p) {
9292 return mp_sqrt_det(mp,
9293 left_x(p)-x_coord(p), right_x(p)-x_coord(p),
9294 left_y(p)-y_coord(p), right_y(p)-y_coord(p));
9297 @ @<Internal library ...@>=
9298 scaled mp_sqrt_det (MP mp,scaled a, scaled b, scaled c, scaled d) ;
9301 @ @<Initialize |maxabs|@>=
9303 if ( abs(b)>maxabs ) maxabs=abs(b);
9304 if ( abs(c)>maxabs ) maxabs=abs(c);
9305 if ( abs(d)>maxabs ) maxabs=abs(d)
9307 @ When a picture contains text, this is represented by a fourteen-word node
9308 where the color information and |type| and |link| fields are augmented by
9309 additional fields that describe the text and how it is transformed.
9310 The |path_p| and |pen_p| pointers are replaced by a number that identifies
9311 the font and a string number that gives the text to be displayed.
9312 The |width|, |height|, and |depth| fields
9313 give the dimensions of the text at its design size, and the remaining six
9314 words give a transformation to be applied to the text. The |new_text_node|
9315 function initializes everything to default values so that the text comes out
9316 black with its reference point at the origin.
9318 @d text_p(A) link((A)+1) /* a string pointer for the text to display */
9319 @d font_n(A) info((A)+1) /* the font number */
9320 @d width_val(A) mp->mem[(A)+7].sc /* unscaled width of the text */
9321 @d height_val(A) mp->mem[(A)+9].sc /* unscaled height of the text */
9322 @d depth_val(A) mp->mem[(A)+10].sc /* unscaled depth of the text */
9323 @d text_tx_loc(A) ((A)+11)
9324 /* the first of six locations for transformation parameters */
9325 @d tx_val(A) mp->mem[(A)+11].sc /* $x$ shift amount */
9326 @d ty_val(A) mp->mem[(A)+12].sc /* $y$ shift amount */
9327 @d txx_val(A) mp->mem[(A)+13].sc /* |txx| transformation parameter */
9328 @d txy_val(A) mp->mem[(A)+14].sc /* |txy| transformation parameter */
9329 @d tyx_val(A) mp->mem[(A)+15].sc /* |tyx| transformation parameter */
9330 @d tyy_val(A) mp->mem[(A)+16].sc /* |tyy| transformation parameter */
9331 @d text_trans_part(A) mp->mem[(A)+11-x_part].sc
9332 /* interpret a text node pointer that has been offset by |x_part..yy_part| */
9333 @d text_node_size 17
9335 @ @<Graphical object codes@>=
9338 @ @c @<Declare text measuring subroutines@>
9339 pointer mp_new_text_node (MP mp,char *f,str_number s) {
9340 /* make a text node for font |f| and text string |s| */
9341 pointer t; /* the new node */
9342 t=mp_get_node(mp, text_node_size);
9343 type(t)=mp_text_code;
9345 font_n(t)=mp_find_font(mp, f); /* this identifies the font */
9350 color_model(t)=mp_uninitialized_model;
9352 post_script(t)=null;
9353 tx_val(t)=0; ty_val(t)=0;
9354 txx_val(t)=unity; txy_val(t)=0;
9355 tyx_val(t)=0; tyy_val(t)=unity;
9356 mp_set_text_box(mp, t); /* this finds the bounding box */
9360 @ The last two types of graphical objects that can occur in an edge structure
9361 are clipping paths and \&{setbounds} paths. These are slightly more difficult
9362 @:set_bounds_}{\&{setbounds} primitive@>
9363 to implement because we must keep track of exactly what is being clipped or
9364 bounded when pictures get merged together. For this reason, each clipping or
9365 \&{setbounds} operation is represented by a pair of nodes: first comes a
9366 two-word node whose |path_p| gives the relevant path, then there is the list
9367 of objects to clip or bound followed by a two-word node whose second word is
9370 Using at least two words for each graphical object node allows them all to be
9371 allocated and deallocated similarly with a global array |gr_object_size| to
9372 give the size in words for each object type.
9374 @d start_clip_size 2
9375 @d start_bounds_size 2
9376 @d stop_clip_size 2 /* the second word is not used here */
9377 @d stop_bounds_size 2 /* the second word is not used here */
9379 @d stop_type(A) ((A)+2)
9380 /* matching |type| for |start_clip_code| or |start_bounds_code| */
9381 @d has_color(A) (type((A))<mp_start_clip_code)
9382 /* does a graphical object have color fields? */
9383 @d has_pen(A) (type((A))<mp_text_code)
9384 /* does a graphical object have a |pen_p| field? */
9385 @d is_start_or_stop(A) (type((A))>=mp_start_clip_code)
9386 @d is_stop(A) (type((A))>=mp_stop_clip_code)
9388 @ @<Graphical object codes@>=
9389 mp_start_clip_code=4, /* |type| of a node that starts clipping */
9390 mp_start_bounds_code=5, /* |type| of a node that gives a \&{setbounds} path */
9391 mp_stop_clip_code=6, /* |type| of a node that stops clipping */
9392 mp_stop_bounds_code=7, /* |type| of a node that stops \&{setbounds} */
9395 pointer mp_new_bounds_node (MP mp,pointer p, small_number c) {
9396 /* make a node of type |c| where |p| is the clipping or \&{setbounds} path */
9397 pointer t; /* the new node */
9398 t=mp_get_node(mp, mp->gr_object_size[c]);
9404 @ We need an array to keep track of the sizes of graphical objects.
9407 small_number gr_object_size[mp_stop_bounds_code+1];
9410 mp->gr_object_size[mp_fill_code]=fill_node_size;
9411 mp->gr_object_size[mp_stroked_code]=stroked_node_size;
9412 mp->gr_object_size[mp_text_code]=text_node_size;
9413 mp->gr_object_size[mp_start_clip_code]=start_clip_size;
9414 mp->gr_object_size[mp_stop_clip_code]=stop_clip_size;
9415 mp->gr_object_size[mp_start_bounds_code]=start_bounds_size;
9416 mp->gr_object_size[mp_stop_bounds_code]=stop_bounds_size;
9418 @ All the essential information in an edge structure is encoded as a linked list
9419 of graphical objects as we have just seen, but it is helpful to add some
9420 redundant information. A single edge structure might be used as a dash pattern
9421 many times, and it would be nice to avoid scanning the same structure
9422 repeatedly. Thus, an edge structure known to be a suitable dash pattern
9423 has a header that gives a list of dashes in a sorted order designed for rapid
9424 translation into \ps.
9426 Each dash is represented by a three-word node containing the initial and final
9427 $x$~coordinates as well as the usual |link| field. The |link| fields points to
9428 the dash node with the next higher $x$-coordinates and the final link points
9429 to a special location called |null_dash|. (There should be no overlap between
9430 dashes). Since the $y$~coordinate of the dash pattern is needed to determine
9431 the period of repetition, this needs to be stored in the edge header along
9432 with a pointer to the list of dash nodes.
9434 @d start_x(A) mp->mem[(A)+1].sc /* the starting $x$~coordinate in a dash node */
9435 @d stop_x(A) mp->mem[(A)+2].sc /* the ending $x$~coordinate in a dash node */
9438 /* in an edge header this points to the first dash node */
9439 @d dash_y(A) mp->mem[(A)+1].sc /* $y$ value for the dash list in an edge header */
9441 @ It is also convenient for an edge header to contain the bounding
9442 box information needed by the \&{llcorner} and \&{urcorner} operators
9443 so that this does not have to be recomputed unnecessarily. This is done by
9444 adding fields for the $x$~and $y$ extremes as well as a pointer that indicates
9445 how far the bounding box computation has gotten. Thus if the user asks for
9446 the bounding box and then adds some more text to the picture before asking
9447 for more bounding box information, the second computation need only look at
9448 the additional text.
9450 When the bounding box has not been computed, the |bblast| pointer points
9451 to a dummy link at the head of the graphical object list while the |minx_val|
9452 and |miny_val| fields contain |el_gordo| and the |maxx_val| and |maxy_val|
9453 fields contain |-el_gordo|.
9455 Since the bounding box of pictures containing objects of type
9456 |mp_start_bounds_code| depends on the value of \&{truecorners}, the bounding box
9457 @:mp_true_corners_}{\&{truecorners} primitive@>
9458 data might not be valid for all values of this parameter. Hence, the |bbtype|
9459 field is needed to keep track of this.
9461 @d minx_val(A) mp->mem[(A)+2].sc
9462 @d miny_val(A) mp->mem[(A)+3].sc
9463 @d maxx_val(A) mp->mem[(A)+4].sc
9464 @d maxy_val(A) mp->mem[(A)+5].sc
9465 @d bblast(A) link((A)+6) /* last item considered in bounding box computation */
9466 @d bbtype(A) info((A)+6) /* tells how bounding box data depends on \&{truecorners} */
9467 @d dummy_loc(A) ((A)+7) /* where the object list begins in an edge header */
9469 /* |bbtype| value when bounding box data is valid for all \&{truecorners} values */
9471 /* |bbtype| value when bounding box data is for \&{truecorners}${}\le 0$ */
9473 /* |bbtype| value when bounding box data is for \&{truecorners}${}>0$ */
9476 void mp_init_bbox (MP mp,pointer h) {
9477 /* Initialize the bounding box information in edge structure |h| */
9478 bblast(h)=dummy_loc(h);
9479 bbtype(h)=no_bounds;
9480 minx_val(h)=el_gordo;
9481 miny_val(h)=el_gordo;
9482 maxx_val(h)=-el_gordo;
9483 maxy_val(h)=-el_gordo;
9486 @ The only other entries in an edge header are a reference count in the first
9487 word and a pointer to the tail of the object list in the last word.
9489 @d obj_tail(A) info((A)+7) /* points to the last entry in the object list */
9490 @d edge_header_size 8
9493 void mp_init_edges (MP mp,pointer h) {
9494 /* initialize an edge header to null values */
9495 dash_list(h)=null_dash;
9496 obj_tail(h)=dummy_loc(h);
9497 link(dummy_loc(h))=null;
9499 mp_init_bbox(mp, h);
9502 @ Here is how edge structures are deleted. The process can be recursive because
9503 of the need to dereference edge structures that are used as dash patterns.
9506 @d add_edge_ref(A) incr(ref_count(A))
9507 @d delete_edge_ref(A) {
9508 if ( ref_count((A))==null )
9509 mp_toss_edges(mp, A);
9514 @<Declare the recycling subroutines@>=
9515 void mp_flush_dash_list (MP mp,pointer h);
9516 pointer mp_toss_gr_object (MP mp,pointer p) ;
9517 void mp_toss_edges (MP mp,pointer h) ;
9519 @ @c void mp_toss_edges (MP mp,pointer h) {
9520 pointer p,q; /* pointers that scan the list being recycled */
9521 pointer r; /* an edge structure that object |p| refers to */
9522 mp_flush_dash_list(mp, h);
9523 q=link(dummy_loc(h));
9524 while ( (q!=null) ) {
9526 r=mp_toss_gr_object(mp, p);
9527 if ( r!=null ) delete_edge_ref(r);
9529 mp_free_node(mp, h,edge_header_size);
9531 void mp_flush_dash_list (MP mp,pointer h) {
9532 pointer p,q; /* pointers that scan the list being recycled */
9534 while ( q!=null_dash ) {
9536 mp_free_node(mp, p,dash_node_size);
9538 dash_list(h)=null_dash;
9540 pointer mp_toss_gr_object (MP mp,pointer p) {
9541 /* returns an edge structure that needs to be dereferenced */
9542 pointer e; /* the edge structure to return */
9544 @<Prepare to recycle graphical object |p|@>;
9545 mp_free_node(mp, p,mp->gr_object_size[type(p)]);
9549 @ @<Prepare to recycle graphical object |p|@>=
9552 mp_toss_knot_list(mp, path_p(p));
9553 if ( pen_p(p)!=null ) mp_toss_knot_list(mp, pen_p(p));
9554 if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
9555 if ( post_script(p)!=null ) delete_str_ref(post_script(p));
9557 case mp_stroked_code:
9558 mp_toss_knot_list(mp, path_p(p));
9559 if ( pen_p(p)!=null ) mp_toss_knot_list(mp, pen_p(p));
9560 if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
9561 if ( post_script(p)!=null ) delete_str_ref(post_script(p));
9565 delete_str_ref(text_p(p));
9566 if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
9567 if ( post_script(p)!=null ) delete_str_ref(post_script(p));
9569 case mp_start_clip_code:
9570 case mp_start_bounds_code:
9571 mp_toss_knot_list(mp, path_p(p));
9573 case mp_stop_clip_code:
9574 case mp_stop_bounds_code:
9576 } /* there are no other cases */
9578 @ If we use |add_edge_ref| to ``copy'' edge structures, the real copying needs
9579 to be done before making a significant change to an edge structure. Much of
9580 the work is done in a separate routine |copy_objects| that copies a list of
9581 graphical objects into a new edge header.
9583 @c @<Declare a function called |copy_objects|@>
9584 pointer mp_private_edges (MP mp,pointer h) {
9585 /* make a private copy of the edge structure headed by |h| */
9586 pointer hh; /* the edge header for the new copy */
9587 pointer p,pp; /* pointers for copying the dash list */
9588 if ( ref_count(h)==null ) {
9592 hh=mp_copy_objects(mp, link(dummy_loc(h)),null);
9593 @<Copy the dash list from |h| to |hh|@>;
9594 @<Copy the bounding box information from |h| to |hh| and make |bblast(hh)|
9595 point into the new object list@>;
9600 @ Here we use the fact that |dash_list(hh)=link(hh)|.
9601 @^data structure assumptions@>
9603 @<Copy the dash list from |h| to |hh|@>=
9604 pp=hh; p=dash_list(h);
9605 while ( (p!=null_dash) ) {
9606 link(pp)=mp_get_node(mp, dash_node_size);
9608 start_x(pp)=start_x(p);
9609 stop_x(pp)=stop_x(p);
9613 dash_y(hh)=dash_y(h)
9616 @ |h| is an edge structure
9619 mp_dash_object *mp_export_dashes (MP mp, pointer q, scaled *w) {
9622 scaled scf; /* scale factor */
9626 if (h==null || dash_list(h)==null_dash)
9629 scf=mp_get_pen_scale(mp, pen_p(q));
9631 if (*w==0) scf = dash_scale(q); else return NULL;
9633 scf=mp_make_scaled(mp, *w,scf);
9634 scf=mp_take_scaled(mp, scf,dash_scale(q));
9637 d = mp_xmalloc(mp,1,sizeof(mp_dash_object));
9638 start_x(null_dash)=start_x(p)+dash_y(h);
9639 while (p != null_dash) {
9640 dashes = mp_xrealloc(mp, dashes, num_dashes+2, sizeof(scaled));
9641 dashes[(num_dashes-1)] =
9642 mp_take_scaled(mp,(stop_x(p)-start_x(p)),scf);
9643 dashes[(num_dashes)] =
9644 mp_take_scaled(mp,(start_x(link(p))-stop_x(p)),scf);
9645 dashes[(num_dashes+1)] = -1; /* terminus */
9649 d->array_field = dashes;
9651 mp_take_scaled(mp,mp_dash_offset(mp, h),scf);
9657 @ @<Copy the bounding box information from |h| to |hh|...@>=
9658 minx_val(hh)=minx_val(h);
9659 miny_val(hh)=miny_val(h);
9660 maxx_val(hh)=maxx_val(h);
9661 maxy_val(hh)=maxy_val(h);
9662 bbtype(hh)=bbtype(h);
9663 p=dummy_loc(h); pp=dummy_loc(hh);
9664 while ((p!=bblast(h)) ) {
9665 if ( p==null ) mp_confusion(mp, "bblast");
9666 @:this can't happen bblast}{\quad bblast@>
9667 p=link(p); pp=link(pp);
9671 @ Here is the promised routine for copying graphical objects into a new edge
9672 structure. It starts copying at object~|p| and stops just before object~|q|.
9673 If |q| is null, it copies the entire sublist headed at |p|. The resulting edge
9674 structure requires further initialization by |init_bbox|.
9676 @<Declare a function called |copy_objects|@>=
9677 pointer mp_copy_objects (MP mp, pointer p, pointer q) {
9678 pointer hh; /* the new edge header */
9679 pointer pp; /* the last newly copied object */
9680 small_number k; /* temporary register */
9681 hh=mp_get_node(mp, edge_header_size);
9682 dash_list(hh)=null_dash;
9686 @<Make |link(pp)| point to a copy of object |p|, and update |p| and |pp|@>;
9693 @ @<Make |link(pp)| point to a copy of object |p|, and update |p| and |pp|@>=
9694 { k=mp->gr_object_size[type(p)];
9695 link(pp)=mp_get_node(mp, k);
9697 while ( (k>0) ) { decr(k); mp->mem[pp+k]=mp->mem[p+k]; };
9698 @<Fix anything in graphical object |pp| that should differ from the
9699 corresponding field in |p|@>;
9703 @ @<Fix anything in graphical object |pp| that should differ from the...@>=
9705 case mp_start_clip_code:
9706 case mp_start_bounds_code:
9707 path_p(pp)=mp_copy_path(mp, path_p(p));
9710 path_p(pp)=mp_copy_path(mp, path_p(p));
9711 if ( pre_script(p)!=null ) add_str_ref(pre_script(p));
9712 if ( post_script(p)!=null ) add_str_ref(post_script(p));
9713 if ( pen_p(p)!=null ) pen_p(pp)=copy_pen(pen_p(p));
9715 case mp_stroked_code:
9716 if ( pre_script(p)!=null ) add_str_ref(pre_script(p));
9717 if ( post_script(p)!=null ) add_str_ref(post_script(p));
9718 path_p(pp)=mp_copy_path(mp, path_p(p));
9719 pen_p(pp)=copy_pen(pen_p(p));
9720 if ( dash_p(p)!=null ) add_edge_ref(dash_p(pp));
9723 if ( pre_script(p)!=null ) add_str_ref(pre_script(p));
9724 if ( post_script(p)!=null ) add_str_ref(post_script(p));
9725 add_str_ref(text_p(pp));
9727 case mp_stop_clip_code:
9728 case mp_stop_bounds_code:
9730 } /* there are no other cases */
9732 @ Here is one way to find an acceptable value for the second argument to
9733 |copy_objects|. Given a non-null graphical object list, |skip_1component|
9734 skips past one picture component, where a ``picture component'' is a single
9735 graphical object, or a start bounds or start clip object and everything up
9736 through the matching stop bounds or stop clip object. The macro version avoids
9737 procedure call overhead and error handling: |skip_component(p)(e)| advances |p|
9738 unless |p| points to a stop bounds or stop clip node, in which case it executes
9741 @d skip_component(A)
9742 if ( ! is_start_or_stop((A)) ) (A)=link((A));
9743 else if ( ! is_stop((A)) ) (A)=mp_skip_1component(mp, (A));
9747 pointer mp_skip_1component (MP mp,pointer p) {
9748 integer lev; /* current nesting level */
9751 if ( is_start_or_stop(p) ) {
9752 if ( is_stop(p) ) decr(lev); else incr(lev);
9759 @ Here is a diagnostic routine for printing an edge structure in symbolic form.
9761 @<Declare subroutines for printing expressions@>=
9762 @<Declare subroutines needed by |print_edges|@>
9763 void mp_print_edges (MP mp,pointer h, const char *s, boolean nuline) {
9764 pointer p; /* a graphical object to be printed */
9765 pointer hh,pp; /* temporary pointers */
9766 scaled scf; /* a scale factor for the dash pattern */
9767 boolean ok_to_dash; /* |false| for polygonal pen strokes */
9768 mp_print_diagnostic(mp, "Edge structure",s,nuline);
9770 while ( link(p)!=null ) {
9774 @<Cases for printing graphical object node |p|@>;
9776 mp_print(mp, "[unknown object type!]");
9780 mp_print_nl(mp, "End edges");
9781 if ( p!=obj_tail(h) ) mp_print(mp, "?");
9783 mp_end_diagnostic(mp, true);
9786 @ @<Cases for printing graphical object node |p|@>=
9788 mp_print(mp, "Filled contour ");
9789 mp_print_obj_color(mp, p);
9790 mp_print_char(mp, ':'); mp_print_ln(mp);
9791 mp_pr_path(mp, path_p(p)); mp_print_ln(mp);
9792 if ( (pen_p(p)!=null) ) {
9793 @<Print join type for graphical object |p|@>;
9794 mp_print(mp, " with pen"); mp_print_ln(mp);
9795 mp_pr_pen(mp, pen_p(p));
9799 @ @<Print join type for graphical object |p|@>=
9800 switch (ljoin_val(p)) {
9802 mp_print(mp, "mitered joins limited ");
9803 mp_print_scaled(mp, miterlim_val(p));
9806 mp_print(mp, "round joins");
9809 mp_print(mp, "beveled joins");
9812 mp_print(mp, "?? joins");
9817 @ For stroked nodes, we need to print |lcap_val(p)| as well.
9819 @<Print join and cap types for stroked node |p|@>=
9820 switch (lcap_val(p)) {
9821 case 0:mp_print(mp, "butt"); break;
9822 case 1:mp_print(mp, "round"); break;
9823 case 2:mp_print(mp, "square"); break;
9824 default: mp_print(mp, "??"); break;
9827 mp_print(mp, " ends, ");
9828 @<Print join type for graphical object |p|@>
9830 @ Here is a routine that prints the color of a graphical object if it isn't
9831 black (the default color).
9833 @<Declare subroutines needed by |print_edges|@>=
9834 @<Declare a procedure called |print_compact_node|@>
9835 void mp_print_obj_color (MP mp,pointer p) {
9836 if ( color_model(p)==mp_grey_model ) {
9837 if ( grey_val(p)>0 ) {
9838 mp_print(mp, "greyed ");
9839 mp_print_compact_node(mp, obj_grey_loc(p),1);
9841 } else if ( color_model(p)==mp_cmyk_model ) {
9842 if ( (cyan_val(p)>0) || (magenta_val(p)>0) ||
9843 (yellow_val(p)>0) || (black_val(p)>0) ) {
9844 mp_print(mp, "processcolored ");
9845 mp_print_compact_node(mp, obj_cyan_loc(p),4);
9847 } else if ( color_model(p)==mp_rgb_model ) {
9848 if ( (red_val(p)>0) || (green_val(p)>0) || (blue_val(p)>0) ) {
9849 mp_print(mp, "colored ");
9850 mp_print_compact_node(mp, obj_red_loc(p),3);
9855 @ We also need a procedure for printing consecutive scaled values as if they
9856 were a known big node.
9858 @<Declare a procedure called |print_compact_node|@>=
9859 void mp_print_compact_node (MP mp,pointer p, small_number k) {
9860 pointer q; /* last location to print */
9862 mp_print_char(mp, '(');
9864 mp_print_scaled(mp, mp->mem[p].sc);
9865 if ( p<q ) mp_print_char(mp, ',');
9868 mp_print_char(mp, ')');
9871 @ @<Cases for printing graphical object node |p|@>=
9872 case mp_stroked_code:
9873 mp_print(mp, "Filled pen stroke ");
9874 mp_print_obj_color(mp, p);
9875 mp_print_char(mp, ':'); mp_print_ln(mp);
9876 mp_pr_path(mp, path_p(p));
9877 if ( dash_p(p)!=null ) {
9878 mp_print_nl(mp, "dashed (");
9879 @<Finish printing the dash pattern that |p| refers to@>;
9882 @<Print join and cap types for stroked node |p|@>;
9883 mp_print(mp, " with pen"); mp_print_ln(mp);
9884 if ( pen_p(p)==null ) mp_print(mp, "???"); /* shouldn't happen */
9886 else mp_pr_pen(mp, pen_p(p));
9889 @ Normally, the |dash_list| field in an edge header is set to |null_dash|
9890 when it is not known to define a suitable dash pattern. This is disallowed
9891 here because the |dash_p| field should never point to such an edge header.
9892 Note that memory is allocated for |start_x(null_dash)| and we are free to
9893 give it any convenient value.
9895 @<Finish printing the dash pattern that |p| refers to@>=
9896 ok_to_dash=pen_is_elliptical(pen_p(p));
9897 if ( ! ok_to_dash ) scf=unity; else scf=dash_scale(p);
9900 if ( (pp==null_dash) || (dash_y(hh)<0) ) {
9901 mp_print(mp, " ??");
9902 } else { start_x(null_dash)=start_x(pp)+dash_y(hh);
9903 while ( pp!=null_dash ) {
9904 mp_print(mp, "on ");
9905 mp_print_scaled(mp, mp_take_scaled(mp, stop_x(pp)-start_x(pp),scf));
9906 mp_print(mp, " off ");
9907 mp_print_scaled(mp, mp_take_scaled(mp, start_x(link(pp))-stop_x(pp),scf));
9909 if ( pp!=null_dash ) mp_print_char(mp, ' ');
9911 mp_print(mp, ") shifted ");
9912 mp_print_scaled(mp, -mp_take_scaled(mp, mp_dash_offset(mp, hh),scf));
9913 if ( ! ok_to_dash || (dash_y(hh)==0) ) mp_print(mp, " (this will be ignored)");
9916 @ @<Declare subroutines needed by |print_edges|@>=
9917 scaled mp_dash_offset (MP mp,pointer h) {
9918 scaled x; /* the answer */
9919 if (dash_list(h)==null_dash || dash_y(h)<0) mp_confusion(mp, "dash0");
9920 @:this can't happen dash0}{\quad dash0@>
9921 if ( dash_y(h)==0 ) {
9924 x=-(start_x(dash_list(h)) % dash_y(h));
9925 if ( x<0 ) x=x+dash_y(h);
9930 @ @<Cases for printing graphical object node |p|@>=
9932 mp_print_char(mp, '"'); mp_print_str(mp,text_p(p));
9933 mp_print(mp, "\" infont \""); mp_print(mp, mp->font_name[font_n(p)]);
9934 mp_print_char(mp, '"'); mp_print_ln(mp);
9935 mp_print_obj_color(mp, p);
9936 mp_print(mp, "transformed ");
9937 mp_print_compact_node(mp, text_tx_loc(p),6);
9940 @ @<Cases for printing graphical object node |p|@>=
9941 case mp_start_clip_code:
9942 mp_print(mp, "clipping path:");
9944 mp_pr_path(mp, path_p(p));
9946 case mp_stop_clip_code:
9947 mp_print(mp, "stop clipping");
9950 @ @<Cases for printing graphical object node |p|@>=
9951 case mp_start_bounds_code:
9952 mp_print(mp, "setbounds path:");
9954 mp_pr_path(mp, path_p(p));
9956 case mp_stop_bounds_code:
9957 mp_print(mp, "end of setbounds");
9960 @ To initialize the |dash_list| field in an edge header~|h|, we need a
9961 subroutine that scans an edge structure and tries to interpret it as a dash
9962 pattern. This can only be done when there are no filled regions or clipping
9963 paths and all the pen strokes have the same color. The first step is to let
9964 $y_0$ be the initial $y$~coordinate of the first pen stroke. Then we implicitly
9965 project all the pen stroke paths onto the line $y=y_0$ and require that there
9966 be no retracing. If the resulting paths cover a range of $x$~coordinates of
9967 length $\Delta x$, we set |dash_y(h)| to the length of the dash pattern by
9968 finding the maximum of $\Delta x$ and the absolute value of~$y_0$.
9970 @c @<Declare a procedure called |x_retrace_error|@>
9971 pointer mp_make_dashes (MP mp,pointer h) { /* returns |h| or |null| */
9972 pointer p; /* this scans the stroked nodes in the object list */
9973 pointer p0; /* if not |null| this points to the first stroked node */
9974 pointer pp,qq,rr; /* pointers into |path_p(p)| */
9975 pointer d,dd; /* pointers used to create the dash list */
9977 @<Other local variables in |make_dashes|@>;
9978 y0=0; /* the initial $y$ coordinate */
9979 if ( dash_list(h)!=null_dash )
9982 p=link(dummy_loc(h));
9984 if ( type(p)!=mp_stroked_code ) {
9985 @<Compain that the edge structure contains a node of the wrong type
9986 and |goto not_found|@>;
9989 if ( p0==null ){ p0=p; y0=y_coord(pp); };
9990 @<Make |d| point to a new dash node created from stroke |p| and path |pp|
9991 or |goto not_found| if there is an error@>;
9992 @<Insert |d| into the dash list and |goto not_found| if there is an error@>;
9995 if ( dash_list(h)==null_dash )
9996 goto NOT_FOUND; /* No error message */
9997 @<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>;
9998 @<Set |dash_y(h)| and merge the first and last dashes if necessary@>;
10001 @<Flush the dash list, recycle |h| and return |null|@>;
10004 @ @<Compain that the edge structure contains a node of the wrong type...@>=
10006 print_err("Picture is too complicated to use as a dash pattern");
10007 help3("When you say `dashed p', picture p should not contain any")
10008 ("text, filled regions, or clipping paths. This time it did")
10009 ("so I'll just make it a solid line instead.");
10010 mp_put_get_error(mp);
10014 @ A similar error occurs when monotonicity fails.
10016 @<Declare a procedure called |x_retrace_error|@>=
10017 void mp_x_retrace_error (MP mp) {
10018 print_err("Picture is too complicated to use as a dash pattern");
10019 help3("When you say `dashed p', every path in p should be monotone")
10020 ("in x and there must be no overlapping. This failed")
10021 ("so I'll just make it a solid line instead.");
10022 mp_put_get_error(mp);
10025 @ We stash |p| in |info(d)| if |dash_p(p)<>0| so that subsequent processing can
10026 handle the case where the pen stroke |p| is itself dashed.
10028 @<Make |d| point to a new dash node created from stroke |p| and path...@>=
10029 @<Make sure |p| and |p0| are the same color and |goto not_found| if there is
10032 if ( link(pp)!=pp ) {
10034 qq=rr; rr=link(rr);
10035 @<Check for retracing between knots |qq| and |rr| and |goto not_found|
10036 if there is a problem@>;
10037 } while (right_type(rr)!=mp_endpoint);
10039 d=mp_get_node(mp, dash_node_size);
10040 if ( dash_p(p)==0 ) info(d)=0; else info(d)=p;
10041 if ( x_coord(pp)<x_coord(rr) ) {
10042 start_x(d)=x_coord(pp);
10043 stop_x(d)=x_coord(rr);
10045 start_x(d)=x_coord(rr);
10046 stop_x(d)=x_coord(pp);
10049 @ We also need to check for the case where the segment from |qq| to |rr| is
10050 monotone in $x$ but is reversed relative to the path from |pp| to |qq|.
10052 @<Check for retracing between knots |qq| and |rr| and |goto not_found|...@>=
10057 if ( (x0>x1) || (x1>x2) || (x2>x3) ) {
10058 if ( (x0<x1) || (x1<x2) || (x2<x3) ) {
10059 if ( mp_ab_vs_cd(mp, x2-x1,x2-x1,x1-x0,x3-x2)>0 ) {
10060 mp_x_retrace_error(mp); goto NOT_FOUND;
10064 if ( (x_coord(pp)>x0) || (x0>x3) ) {
10065 if ( (x_coord(pp)<x0) || (x0<x3) ) {
10066 mp_x_retrace_error(mp); goto NOT_FOUND;
10070 @ @<Other local variables in |make_dashes|@>=
10071 scaled x0,x1,x2,x3; /* $x$ coordinates of the segment from |qq| to |rr| */
10073 @ @<Make sure |p| and |p0| are the same color and |goto not_found|...@>=
10074 if ( (red_val(p)!=red_val(p0)) || (black_val(p)!=black_val(p0)) ||
10075 (green_val(p)!=green_val(p0)) || (blue_val(p)!=blue_val(p0)) ) {
10076 print_err("Picture is too complicated to use as a dash pattern");
10077 help3("When you say `dashed p', everything in picture p should")
10078 ("be the same color. I can\'t handle your color changes")
10079 ("so I'll just make it a solid line instead.");
10080 mp_put_get_error(mp);
10084 @ @<Insert |d| into the dash list and |goto not_found| if there is an error@>=
10085 start_x(null_dash)=stop_x(d);
10086 dd=h; /* this makes |link(dd)=dash_list(h)| */
10087 while ( start_x(link(dd))<stop_x(d) )
10090 if ( (stop_x(dd)>start_x(d)) )
10091 { mp_x_retrace_error(mp); goto NOT_FOUND; };
10096 @ @<Set |dash_y(h)| and merge the first and last dashes if necessary@>=
10098 while ( (link(d)!=null_dash) )
10101 dash_y(h)=stop_x(d)-start_x(dd);
10102 if ( abs(y0)>dash_y(h) ) {
10104 } else if ( d!=dd ) {
10105 dash_list(h)=link(dd);
10106 stop_x(d)=stop_x(dd)+dash_y(h);
10107 mp_free_node(mp, dd,dash_node_size);
10110 @ We get here when the argument is a null picture or when there is an error.
10111 Recovering from an error involves making |dash_list(h)| empty to indicate
10112 that |h| is not known to be a valid dash pattern. We also dereference |h|
10113 since it is not being used for the return value.
10115 @<Flush the dash list, recycle |h| and return |null|@>=
10116 mp_flush_dash_list(mp, h);
10117 delete_edge_ref(h);
10120 @ Having carefully saved the dashed stroked nodes in the
10121 corresponding dash nodes, we must be prepared to break up these dashes into
10124 @<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>=
10125 d=h; /* now |link(d)=dash_list(h)| */
10126 while ( link(d)!=null_dash ) {
10132 hsf=dash_scale(ds);
10133 if ( (hh==null) ) mp_confusion(mp, "dash1");
10134 @:this can't happen dash0}{\quad dash1@>
10135 if ( dash_y(hh)==0 ) {
10138 if ( dash_list(hh)==null ) mp_confusion(mp, "dash1");
10139 @:this can't happen dash0}{\quad dash1@>
10140 @<Replace |link(d)| by a dashed version as determined by edge header
10141 |hh| and scale factor |ds|@>;
10146 @ @<Other local variables in |make_dashes|@>=
10147 pointer dln; /* |link(d)| */
10148 pointer hh; /* an edge header that tells how to break up |dln| */
10149 scaled hsf; /* the dash pattern from |hh| gets scaled by this */
10150 pointer ds; /* the stroked node from which |hh| and |hsf| are derived */
10151 scaled xoff; /* added to $x$ values in |dash_list(hh)| to match |dln| */
10153 @ @<Replace |link(d)| by a dashed version as determined by edge header...@>=
10156 xoff=start_x(dln)-mp_take_scaled(mp, hsf,start_x(dd))-
10157 mp_take_scaled(mp, hsf,mp_dash_offset(mp, hh));
10158 start_x(null_dash)=mp_take_scaled(mp, hsf,start_x(dd))
10159 +mp_take_scaled(mp, hsf,dash_y(hh));
10160 stop_x(null_dash)=start_x(null_dash);
10161 @<Advance |dd| until finding the first dash that overlaps |dln| when
10162 offset by |xoff|@>;
10163 while ( start_x(dln)<=stop_x(dln) ) {
10164 @<If |dd| has `fallen off the end', back up to the beginning and fix |xoff|@>;
10165 @<Insert a dash between |d| and |dln| for the overlap with the offset version
10168 start_x(dln)=xoff+mp_take_scaled(mp, hsf,start_x(dd));
10171 mp_free_node(mp, dln,dash_node_size)
10173 @ The name of this module is a bit of a lie because we just find the
10174 first |dd| where |take_scaled (hsf, stop_x(dd))| is large enough to make an
10175 overlap possible. It could be that the unoffset version of dash |dln| falls
10176 in the gap between |dd| and its predecessor.
10178 @<Advance |dd| until finding the first dash that overlaps |dln| when...@>=
10179 while ( xoff+mp_take_scaled(mp, hsf,stop_x(dd))<start_x(dln) ) {
10183 @ @<If |dd| has `fallen off the end', back up to the beginning and fix...@>=
10184 if ( dd==null_dash ) {
10186 xoff=xoff+mp_take_scaled(mp, hsf,dash_y(hh));
10189 @ At this point we already know that
10190 |start_x(dln)<=xoff+take_scaled(hsf,stop_x(dd))|.
10192 @<Insert a dash between |d| and |dln| for the overlap with the offset...@>=
10193 if ( (xoff+mp_take_scaled(mp, hsf,start_x(dd)))<=stop_x(dln) ) {
10194 link(d)=mp_get_node(mp, dash_node_size);
10197 if ( start_x(dln)>(xoff+mp_take_scaled(mp, hsf,start_x(dd))))
10198 start_x(d)=start_x(dln);
10200 start_x(d)=xoff+mp_take_scaled(mp, hsf,start_x(dd));
10201 if ( stop_x(dln)<(xoff+mp_take_scaled(mp, hsf,stop_x(dd))))
10202 stop_x(d)=stop_x(dln);
10204 stop_x(d)=xoff+mp_take_scaled(mp, hsf,stop_x(dd));
10207 @ The next major task is to update the bounding box information in an edge
10208 header~|h|. This is done via a procedure |adjust_bbox| that enlarges an edge
10209 header's bounding box to accommodate the box computed by |path_bbox| or
10210 |pen_bbox|. (This is stored in global variables |minx|, |miny|, |maxx|, and
10213 @c void mp_adjust_bbox (MP mp,pointer h) {
10214 if ( minx<minx_val(h) ) minx_val(h)=minx;
10215 if ( miny<miny_val(h) ) miny_val(h)=miny;
10216 if ( maxx>maxx_val(h) ) maxx_val(h)=maxx;
10217 if ( maxy>maxy_val(h) ) maxy_val(h)=maxy;
10220 @ Here is a special routine for updating the bounding box information in
10221 edge header~|h| to account for the squared-off ends of a non-cyclic path~|p|
10222 that is to be stroked with the pen~|pp|.
10224 @c void mp_box_ends (MP mp, pointer p, pointer pp, pointer h) {
10225 pointer q; /* a knot node adjacent to knot |p| */
10226 fraction dx,dy; /* a unit vector in the direction out of the path at~|p| */
10227 scaled d; /* a factor for adjusting the length of |(dx,dy)| */
10228 scaled z; /* a coordinate being tested against the bounding box */
10229 scaled xx,yy; /* the extreme pen vertex in the |(dx,dy)| direction */
10230 integer i; /* a loop counter */
10231 if ( right_type(p)!=mp_endpoint ) {
10234 @<Make |(dx,dy)| the final direction for the path segment from
10235 |q| to~|p|; set~|d|@>;
10236 d=mp_pyth_add(mp, dx,dy);
10238 @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>;
10239 for (i=1;i<= 2;i++) {
10240 @<Use |(dx,dy)| to generate a vertex of the square end cap and
10241 update the bounding box to accommodate it@>;
10245 if ( right_type(p)==mp_endpoint ) {
10248 @<Advance |p| to the end of the path and make |q| the previous knot@>;
10254 @ @<Make |(dx,dy)| the final direction for the path segment from...@>=
10255 if ( q==link(p) ) {
10256 dx=x_coord(p)-right_x(p);
10257 dy=y_coord(p)-right_y(p);
10258 if ( (dx==0)&&(dy==0) ) {
10259 dx=x_coord(p)-left_x(q);
10260 dy=y_coord(p)-left_y(q);
10263 dx=x_coord(p)-left_x(p);
10264 dy=y_coord(p)-left_y(p);
10265 if ( (dx==0)&&(dy==0) ) {
10266 dx=x_coord(p)-right_x(q);
10267 dy=y_coord(p)-right_y(q);
10270 dx=x_coord(p)-x_coord(q);
10271 dy=y_coord(p)-y_coord(q)
10273 @ @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>=
10274 dx=mp_make_fraction(mp, dx,d);
10275 dy=mp_make_fraction(mp, dy,d);
10276 mp_find_offset(mp, -dy,dx,pp);
10277 xx=mp->cur_x; yy=mp->cur_y
10279 @ @<Use |(dx,dy)| to generate a vertex of the square end cap and...@>=
10280 mp_find_offset(mp, dx,dy,pp);
10281 d=mp_take_fraction(mp, xx-mp->cur_x,dx)+mp_take_fraction(mp, yy-mp->cur_y,dy);
10282 if ( ((d<0)&&(i==1)) || ((d>0)&&(i==2)))
10283 mp_confusion(mp, "box_ends");
10284 @:this can't happen box ends}{\quad\\{box\_ends}@>
10285 z=x_coord(p)+mp->cur_x+mp_take_fraction(mp, d,dx);
10286 if ( z<minx_val(h) ) minx_val(h)=z;
10287 if ( z>maxx_val(h) ) maxx_val(h)=z;
10288 z=y_coord(p)+mp->cur_y+mp_take_fraction(mp, d,dy);
10289 if ( z<miny_val(h) ) miny_val(h)=z;
10290 if ( z>maxy_val(h) ) maxy_val(h)=z
10292 @ @<Advance |p| to the end of the path and make |q| the previous knot@>=
10296 } while (right_type(p)!=mp_endpoint)
10298 @ The major difficulty in finding the bounding box of an edge structure is the
10299 effect of clipping paths. We treat them conservatively by only clipping to the
10300 clipping path's bounding box, but this still
10301 requires recursive calls to |set_bbox| in order to find the bounding box of
10303 the objects to be clipped. Such calls are distinguished by the fact that the
10304 boolean parameter |top_level| is false.
10306 @c void mp_set_bbox (MP mp,pointer h, boolean top_level) {
10307 pointer p; /* a graphical object being considered */
10308 scaled sminx,sminy,smaxx,smaxy;
10309 /* for saving the bounding box during recursive calls */
10310 scaled x0,x1,y0,y1; /* temporary registers */
10311 integer lev; /* nesting level for |mp_start_bounds_code| nodes */
10312 @<Wipe out any existing bounding box information if |bbtype(h)| is
10313 incompatible with |internal[mp_true_corners]|@>;
10314 while ( link(bblast(h))!=null ) {
10318 case mp_stop_clip_code:
10319 if ( top_level ) mp_confusion(mp, "bbox"); else return;
10320 @:this can't happen bbox}{\quad bbox@>
10322 @<Other cases for updating the bounding box based on the type of object |p|@>;
10323 } /* all cases are enumerated above */
10325 if ( ! top_level ) mp_confusion(mp, "bbox");
10328 @ @<Internal library declarations@>=
10329 void mp_set_bbox (MP mp,pointer h, boolean top_level);
10331 @ @<Wipe out any existing bounding box information if |bbtype(h)| is...@>=
10332 switch (bbtype(h)) {
10336 if ( mp->internal[mp_true_corners]>0 ) mp_init_bbox(mp, h);
10339 if ( mp->internal[mp_true_corners]<=0 ) mp_init_bbox(mp, h);
10341 } /* there are no other cases */
10343 @ @<Other cases for updating the bounding box...@>=
10345 mp_path_bbox(mp, path_p(p));
10346 if ( pen_p(p)!=null ) {
10349 mp_pen_bbox(mp, pen_p(p));
10355 mp_adjust_bbox(mp, h);
10358 @ @<Other cases for updating the bounding box...@>=
10359 case mp_start_bounds_code:
10360 if ( mp->internal[mp_true_corners]>0 ) {
10361 bbtype(h)=bounds_unset;
10363 bbtype(h)=bounds_set;
10364 mp_path_bbox(mp, path_p(p));
10365 mp_adjust_bbox(mp, h);
10366 @<Scan to the matching |mp_stop_bounds_code| node and update |p| and
10370 case mp_stop_bounds_code:
10371 if ( mp->internal[mp_true_corners]<=0 ) mp_confusion(mp, "bbox2");
10372 @:this can't happen bbox2}{\quad bbox2@>
10375 @ @<Scan to the matching |mp_stop_bounds_code| node and update |p| and...@>=
10378 if ( link(p)==null ) mp_confusion(mp, "bbox2");
10379 @:this can't happen bbox2}{\quad bbox2@>
10381 if ( type(p)==mp_start_bounds_code ) incr(lev);
10382 else if ( type(p)==mp_stop_bounds_code ) decr(lev);
10386 @ It saves a lot of grief here to be slightly conservative and not account for
10387 omitted parts of dashed lines. We also don't worry about the material omitted
10388 when using butt end caps. The basic computation is for round end caps and
10389 |box_ends| augments it for square end caps.
10391 @<Other cases for updating the bounding box...@>=
10392 case mp_stroked_code:
10393 mp_path_bbox(mp, path_p(p));
10396 mp_pen_bbox(mp, pen_p(p));
10401 mp_adjust_bbox(mp, h);
10402 if ( (left_type(path_p(p))==mp_endpoint)&&(lcap_val(p)==2) )
10403 mp_box_ends(mp, path_p(p), pen_p(p), h);
10406 @ The height width and depth information stored in a text node determines a
10407 rectangle that needs to be transformed according to the transformation
10408 parameters stored in the text node.
10410 @<Other cases for updating the bounding box...@>=
10412 x1=mp_take_scaled(mp, txx_val(p),width_val(p));
10413 y0=mp_take_scaled(mp, txy_val(p),-depth_val(p));
10414 y1=mp_take_scaled(mp, txy_val(p),height_val(p));
10417 if ( y0<y1 ) { minx=minx+y0; maxx=maxx+y1; }
10418 else { minx=minx+y1; maxx=maxx+y0; }
10419 if ( x1<0 ) minx=minx+x1; else maxx=maxx+x1;
10420 x1=mp_take_scaled(mp, tyx_val(p),width_val(p));
10421 y0=mp_take_scaled(mp, tyy_val(p),-depth_val(p));
10422 y1=mp_take_scaled(mp, tyy_val(p),height_val(p));
10425 if ( y0<y1 ) { miny=miny+y0; maxy=maxy+y1; }
10426 else { miny=miny+y1; maxy=maxy+y0; }
10427 if ( x1<0 ) miny=miny+x1; else maxy=maxy+x1;
10428 mp_adjust_bbox(mp, h);
10431 @ This case involves a recursive call that advances |bblast(h)| to the node of
10432 type |mp_stop_clip_code| that matches |p|.
10434 @<Other cases for updating the bounding box...@>=
10435 case mp_start_clip_code:
10436 mp_path_bbox(mp, path_p(p));
10439 sminx=minx_val(h); sminy=miny_val(h);
10440 smaxx=maxx_val(h); smaxy=maxy_val(h);
10441 @<Reinitialize the bounding box in header |h| and call |set_bbox| recursively
10442 starting at |link(p)|@>;
10443 @<Clip the bounding box in |h| to the rectangle given by |x0|, |x1|,
10445 minx=sminx; miny=sminy;
10446 maxx=smaxx; maxy=smaxy;
10447 mp_adjust_bbox(mp, h);
10450 @ @<Reinitialize the bounding box in header |h| and call |set_bbox|...@>=
10451 minx_val(h)=el_gordo;
10452 miny_val(h)=el_gordo;
10453 maxx_val(h)=-el_gordo;
10454 maxy_val(h)=-el_gordo;
10455 mp_set_bbox(mp, h,false)
10457 @ @<Clip the bounding box in |h| to the rectangle given by |x0|, |x1|,...@>=
10458 if ( minx_val(h)<x0 ) minx_val(h)=x0;
10459 if ( miny_val(h)<y0 ) miny_val(h)=y0;
10460 if ( maxx_val(h)>x1 ) maxx_val(h)=x1;
10461 if ( maxy_val(h)>y1 ) maxy_val(h)=y1
10463 @* \[22] Finding an envelope.
10464 When \MP\ has a path and a polygonal pen, it needs to express the desired
10465 shape in terms of things \ps\ can understand. The present task is to compute
10466 a new path that describes the region to be filled. It is convenient to
10467 define this as a two step process where the first step is determining what
10468 offset to use for each segment of the path.
10470 @ Given a pointer |c| to a cyclic path,
10471 and a pointer~|h| to the first knot of a pen polygon,
10472 the |offset_prep| routine changes the path into cubics that are
10473 associated with particular pen offsets. Thus if the cubic between |p|
10474 and~|q| is associated with the |k|th offset and the cubic between |q| and~|r|
10475 has offset |l| then |info(q)=zero_off+l-k|. (The constant |zero_off| is added
10476 to because |l-k| could be negative.)
10478 After overwriting the type information with offset differences, we no longer
10479 have a true path so we refer to the knot list returned by |offset_prep| as an
10482 Since an envelope spec only determines relative changes in pen offsets,
10483 |offset_prep| sets a global variable |spec_offset| to the relative change from
10484 |h| to the first offset.
10486 @d zero_off 16384 /* added to offset changes to make them positive */
10489 integer spec_offset; /* number of pen edges between |h| and the initial offset */
10491 @ @c @<Declare subroutines needed by |offset_prep|@>
10492 pointer mp_offset_prep (MP mp,pointer c, pointer h) {
10493 halfword n; /* the number of vertices in the pen polygon */
10494 pointer c0,p,q,q0,r,w, ww; /* for list manipulation */
10495 integer k_needed; /* amount to be added to |info(p)| when it is computed */
10496 pointer w0; /* a pointer to pen offset to use just before |p| */
10497 scaled dxin,dyin; /* the direction into knot |p| */
10498 integer turn_amt; /* change in pen offsets for the current cubic */
10499 @<Other local variables for |offset_prep|@>;
10501 @<Initialize the pen size~|n|@>;
10502 @<Initialize the incoming direction and pen offset at |c|@>;
10503 p=c; c0=c; k_needed=0;
10506 @<Split the cubic between |p| and |q|, if necessary, into cubics
10507 associated with single offsets, after which |q| should
10508 point to the end of the final such cubic@>;
10510 @<Advance |p| to node |q|, removing any ``dead'' cubics that
10511 might have been introduced by the splitting process@>;
10513 @<Fix the offset change in |info(c)| and set |c| to the return value of
10518 @ We shall want to keep track of where certain knots on the cyclic path
10519 wind up in the envelope spec. It doesn't suffice just to keep pointers to
10520 knot nodes because some nodes are deleted while removing dead cubics. Thus
10521 |offset_prep| updates the following pointers
10525 pointer spec_p2; /* pointers to distinguished knots */
10528 mp->spec_p1=null; mp->spec_p2=null;
10530 @ @<Initialize the pen size~|n|@>=
10537 @ Since the true incoming direction isn't known yet, we just pick a direction
10538 consistent with the pen offset~|h|. If this is wrong, it can be corrected
10541 @<Initialize the incoming direction and pen offset at |c|@>=
10542 dxin=x_coord(link(h))-x_coord(knil(h));
10543 dyin=y_coord(link(h))-y_coord(knil(h));
10544 if ( (dxin==0)&&(dyin==0) ) {
10545 dxin=y_coord(knil(h))-y_coord(h);
10546 dyin=x_coord(h)-x_coord(knil(h));
10550 @ We must be careful not to remove the only cubic in a cycle.
10552 But we must also be careful for another reason. If the user-supplied
10553 path starts with a set of degenerate cubics, the target node |q| can
10554 be collapsed to the initial node |p| which might be the same as the
10555 initial node |c| of the curve. This would cause the |offset_prep| routine
10556 to bail out too early, causing distress later on. (See for example
10557 the testcase reported by Bogus\l{}aw Jackowski in tracker id 267, case 52c
10560 @<Advance |p| to node |q|, removing any ``dead'' cubics...@>=
10564 if ( x_coord(p)==right_x(p) && y_coord(p)==right_y(p) &&
10565 x_coord(p)==left_x(r) && y_coord(p)==left_y(r) &&
10566 x_coord(p)==x_coord(r) && y_coord(p)==y_coord(r) &&
10568 @<Remove the cubic following |p| and update the data structures
10569 to merge |r| into |p|@>;
10573 /* Check if we removed too much */
10574 if ((q!=q0)&&(q!=c||c==c0))
10577 @ @<Remove the cubic following |p| and update the data structures...@>=
10578 { k_needed=info(p)-zero_off;
10582 info(p)=k_needed+info(r);
10585 if ( r==c ) { info(p)=info(c); c=p; };
10586 if ( r==mp->spec_p1 ) mp->spec_p1=p;
10587 if ( r==mp->spec_p2 ) mp->spec_p2=p;
10588 r=p; mp_remove_cubic(mp, p);
10591 @ Not setting the |info| field of the newly created knot allows the splitting
10592 routine to work for paths.
10594 @<Declare subroutines needed by |offset_prep|@>=
10595 void mp_split_cubic (MP mp,pointer p, fraction t) { /* splits the cubic after |p| */
10596 scaled v; /* an intermediate value */
10597 pointer q,r; /* for list manipulation */
10598 q=link(p); r=mp_get_node(mp, knot_node_size); link(p)=r; link(r)=q;
10599 originator(r)=mp_program_code;
10600 left_type(r)=mp_explicit; right_type(r)=mp_explicit;
10601 v=t_of_the_way(right_x(p),left_x(q));
10602 right_x(p)=t_of_the_way(x_coord(p),right_x(p));
10603 left_x(q)=t_of_the_way(left_x(q),x_coord(q));
10604 left_x(r)=t_of_the_way(right_x(p),v);
10605 right_x(r)=t_of_the_way(v,left_x(q));
10606 x_coord(r)=t_of_the_way(left_x(r),right_x(r));
10607 v=t_of_the_way(right_y(p),left_y(q));
10608 right_y(p)=t_of_the_way(y_coord(p),right_y(p));
10609 left_y(q)=t_of_the_way(left_y(q),y_coord(q));
10610 left_y(r)=t_of_the_way(right_y(p),v);
10611 right_y(r)=t_of_the_way(v,left_y(q));
10612 y_coord(r)=t_of_the_way(left_y(r),right_y(r));
10615 @ This does not set |info(p)| or |right_type(p)|.
10617 @<Declare subroutines needed by |offset_prep|@>=
10618 void mp_remove_cubic (MP mp,pointer p) { /* removes the dead cubic following~|p| */
10619 pointer q; /* the node that disappears */
10620 q=link(p); link(p)=link(q);
10621 right_x(p)=right_x(q); right_y(p)=right_y(q);
10622 mp_free_node(mp, q,knot_node_size);
10625 @ Let $d\prec d'$ mean that the counter-clockwise angle from $d$ to~$d'$ is
10626 strictly between zero and $180^\circ$. Then we can define $d\preceq d'$ to
10627 mean that the angle could be zero or $180^\circ$. If $w_k=(u_k,v_k)$ is the
10628 $k$th pen offset, the $k$th pen edge direction is defined by the formula
10629 $$d_k=(u\k-u_k,\,v\k-v_k).$$
10630 When listed by increasing $k$, these directions occur in counter-clockwise
10631 order so that $d_k\preceq d\k$ for all~$k$.
10632 The goal of |offset_prep| is to find an offset index~|k| to associate with
10633 each cubic, such that the direction $d(t)$ of the cubic satisfies
10634 $$d_{k-1}\preceq d(t)\preceq d_k\qquad\hbox{for $0\le t\le 1$.}\eqno(*)$$
10635 We may have to split a cubic into many pieces before each
10636 piece corresponds to a unique offset.
10638 @<Split the cubic between |p| and |q|, if necessary, into cubics...@>=
10639 info(p)=zero_off+k_needed;
10641 @<Prepare for derivative computations;
10642 |goto not_found| if the current cubic is dead@>;
10643 @<Find the initial direction |(dx,dy)|@>;
10644 @<Update |info(p)| and find the offset $w_k$ such that
10645 $d_{k-1}\preceq(\\{dx},\\{dy})\prec d_k$; also advance |w0| for
10646 the direction change at |p|@>;
10647 @<Find the final direction |(dxin,dyin)|@>;
10648 @<Decide on the net change in pen offsets and set |turn_amt|@>;
10649 @<Complete the offset splitting process@>;
10650 w0=mp_pen_walk(mp, w0,turn_amt)
10652 @ @<Declare subroutines needed by |offset_prep|@>=
10653 pointer mp_pen_walk (MP mp,pointer w, integer k) {
10654 /* walk |k| steps around a pen from |w| */
10655 while ( k>0 ) { w=link(w); decr(k); };
10656 while ( k<0 ) { w=knil(w); incr(k); };
10660 @ The direction of a cubic $B(z_0,z_1,z_2,z_3;t)=\bigl(x(t),y(t)\bigr)$ can be
10661 calculated from the quadratic polynomials
10662 ${1\over3}x'(t)=B(x_1-x_0,x_2-x_1,x_3-x_2;t)$ and
10663 ${1\over3}y'(t)=B(y_1-y_0,y_2-y_1,y_3-y_2;t)$.
10664 Since we may be calculating directions from several cubics
10665 split from the current one, it is desirable to do these calculations
10666 without losing too much precision. ``Scaled up'' values of the
10667 derivatives, which will be less tainted by accumulated errors than
10668 derivatives found from the cubics themselves, are maintained in
10669 local variables |x0|, |x1|, and |x2|, representing $X_0=2^l(x_1-x_0)$,
10670 $X_1=2^l(x_2-x_1)$, and $X_2=2^l(x_3-x_2)$; similarly |y0|, |y1|, and~|y2|
10671 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)$.
10673 @<Other local variables for |offset_prep|@>=
10674 integer x0,x1,x2,y0,y1,y2; /* representatives of derivatives */
10675 integer t0,t1,t2; /* coefficients of polynomial for slope testing */
10676 integer du,dv,dx,dy; /* for directions of the pen and the curve */
10677 integer dx0,dy0; /* initial direction for the first cubic in the curve */
10678 integer max_coef; /* used while scaling */
10679 integer x0a,x1a,x2a,y0a,y1a,y2a; /* intermediate values */
10680 fraction t; /* where the derivative passes through zero */
10681 fraction s; /* a temporary value */
10683 @ @<Prepare for derivative computations...@>=
10684 x0=right_x(p)-x_coord(p);
10685 x2=x_coord(q)-left_x(q);
10686 x1=left_x(q)-right_x(p);
10687 y0=right_y(p)-y_coord(p); y2=y_coord(q)-left_y(q);
10688 y1=left_y(q)-right_y(p);
10690 if ( abs(x1)>max_coef ) max_coef=abs(x1);
10691 if ( abs(x2)>max_coef ) max_coef=abs(x2);
10692 if ( abs(y0)>max_coef ) max_coef=abs(y0);
10693 if ( abs(y1)>max_coef ) max_coef=abs(y1);
10694 if ( abs(y2)>max_coef ) max_coef=abs(y2);
10695 if ( max_coef==0 ) goto NOT_FOUND;
10696 while ( max_coef<fraction_half ) {
10698 double(x0); double(x1); double(x2);
10699 double(y0); double(y1); double(y2);
10702 @ Let us first solve a special case of the problem: Suppose we
10703 know an index~$k$ such that either (i)~$d(t)\succeq d_{k-1}$ for all~$t$
10704 and $d(0)\prec d_k$, or (ii)~$d(t)\preceq d_k$ for all~$t$ and
10705 $d(0)\succ d_{k-1}$.
10706 Then, in a sense, we're halfway done, since one of the two relations
10707 in $(*)$ is satisfied, and the other couldn't be satisfied for
10708 any other value of~|k|.
10710 Actually, the conditions can be relaxed somewhat since a relation such as
10711 $d(t)\succeq d_{k-1}$ restricts $d(t)$ to a half plane when all that really
10712 matters is whether $d(t)$ crosses the ray in the $d_{k-1}$ direction from
10713 the origin. The condition for case~(i) becomes $d_{k-1}\preceq d(0)\prec d_k$
10714 and $d(t)$ never crosses the $d_{k-1}$ ray in the clockwise direction.
10715 Case~(ii) is similar except $d(t)$ cannot cross the $d_k$ ray in the
10716 counterclockwise direction.
10718 The |fin_offset_prep| subroutine solves the stated subproblem.
10719 It has a parameter called |rise| that is |1| in
10720 case~(i), |-1| in case~(ii). Parameters |x0| through |y2| represent
10721 the derivative of the cubic following |p|.
10722 The |w| parameter should point to offset~$w_k$ and |info(p)| should already
10723 be set properly. The |turn_amt| parameter gives the absolute value of the
10724 overall net change in pen offsets.
10726 @<Declare subroutines needed by |offset_prep|@>=
10727 void mp_fin_offset_prep (MP mp,pointer p, pointer w, integer
10728 x0,integer x1, integer x2, integer y0, integer y1, integer y2,
10729 integer rise, integer turn_amt) {
10730 pointer ww; /* for list manipulation */
10731 scaled du,dv; /* for slope calculation */
10732 integer t0,t1,t2; /* test coefficients */
10733 fraction t; /* place where the derivative passes a critical slope */
10734 fraction s; /* slope or reciprocal slope */
10735 integer v; /* intermediate value for updating |x0..y2| */
10736 pointer q; /* original |link(p)| */
10739 if ( rise>0 ) ww=link(w); /* a pointer to $w\k$ */
10740 else ww=knil(w); /* a pointer to $w_{k-1}$ */
10741 @<Compute test coefficients |(t0,t1,t2)|
10742 for $d(t)$ versus $d_k$ or $d_{k-1}$@>;
10743 t=mp_crossing_point(mp, t0,t1,t2);
10744 if ( t>=fraction_one ) {
10745 if ( turn_amt>0 ) t=fraction_one; else return;
10747 @<Split the cubic at $t$,
10748 and split off another cubic if the derivative crosses back@>;
10753 @ We want $B(\\{t0},\\{t1},\\{t2};t)$ to be the dot product of $d(t)$ with a
10754 $-90^\circ$ rotation of the vector from |w| to |ww|. This makes the resulting
10755 function cross from positive to negative when $d_{k-1}\preceq d(t)\preceq d_k$
10758 @<Compute test coefficients |(t0,t1,t2)| for $d(t)$ versus...@>=
10759 du=x_coord(ww)-x_coord(w); dv=y_coord(ww)-y_coord(w);
10760 if ( abs(du)>=abs(dv) ) {
10761 s=mp_make_fraction(mp, dv,du);
10762 t0=mp_take_fraction(mp, x0,s)-y0;
10763 t1=mp_take_fraction(mp, x1,s)-y1;
10764 t2=mp_take_fraction(mp, x2,s)-y2;
10765 if ( du<0 ) { negate(t0); negate(t1); negate(t2); }
10767 s=mp_make_fraction(mp, du,dv);
10768 t0=x0-mp_take_fraction(mp, y0,s);
10769 t1=x1-mp_take_fraction(mp, y1,s);
10770 t2=x2-mp_take_fraction(mp, y2,s);
10771 if ( dv<0 ) { negate(t0); negate(t1); negate(t2); }
10773 if ( t0<0 ) t0=0 /* should be positive without rounding error */
10775 @ The curve has crossed $d_k$ or $d_{k-1}$; its initial segment satisfies
10776 $(*)$, and it might cross again and return towards $s_{k-1}$ or $s_k$,
10777 respectively, yielding another solution of $(*)$.
10779 @<Split the cubic at $t$, and split off another...@>=
10781 mp_split_cubic(mp, p,t); p=link(p); info(p)=zero_off+rise;
10783 v=t_of_the_way(x0,x1); x1=t_of_the_way(x1,x2);
10784 x0=t_of_the_way(v,x1);
10785 v=t_of_the_way(y0,y1); y1=t_of_the_way(y1,y2);
10786 y0=t_of_the_way(v,y1);
10787 if ( turn_amt<0 ) {
10788 t1=t_of_the_way(t1,t2);
10789 if ( t1>0 ) t1=0; /* without rounding error, |t1| would be |<=0| */
10790 t=mp_crossing_point(mp, 0,-t1,-t2);
10791 if ( t>fraction_one ) t=fraction_one;
10793 if ( (t==fraction_one)&&(link(p)!=q) ) {
10794 info(link(p))=info(link(p))-rise;
10796 mp_split_cubic(mp, p,t); info(link(p))=zero_off-rise;
10797 v=t_of_the_way(x1,x2); x1=t_of_the_way(x0,x1);
10798 x2=t_of_the_way(x1,v);
10799 v=t_of_the_way(y1,y2); y1=t_of_the_way(y0,y1);
10800 y2=t_of_the_way(y1,v);
10805 @ Now we must consider the general problem of |offset_prep|, when
10806 nothing is known about a given cubic. We start by finding its
10807 direction in the vicinity of |t=0|.
10809 If $z'(t)=0$, the given cubic is numerically unstable but |offset_prep|
10810 has not yet introduced any more numerical errors. Thus we can compute
10811 the true initial direction for the given cubic, even if it is almost
10814 @<Find the initial direction |(dx,dy)|@>=
10816 if ( dx==0 && dy==0 ) {
10818 if ( dx==0 && dy==0 ) {
10822 if ( p==c ) { dx0=dx; dy0=dy; }
10824 @ @<Find the final direction |(dxin,dyin)|@>=
10826 if ( dxin==0 && dyin==0 ) {
10828 if ( dxin==0 && dyin==0 ) {
10833 @ The next step is to bracket the initial direction between consecutive
10834 edges of the pen polygon. We must be careful to turn clockwise only if
10835 this makes the turn less than $180^\circ$. (A $180^\circ$ turn must be
10836 counter-clockwise in order to make \&{doublepath} envelopes come out
10837 @:double_path_}{\&{doublepath} primitive@>
10838 right.) This code depends on |w0| being the offset for |(dxin,dyin)|.
10840 @<Update |info(p)| and find the offset $w_k$ such that...@>=
10841 turn_amt=mp_get_turn_amt(mp,w0,dx,dy,(mp_ab_vs_cd(mp, dy,dxin,dx,dyin)>=0));
10842 w=mp_pen_walk(mp, w0, turn_amt);
10844 info(p)=info(p)+turn_amt
10846 @ Decide how many pen offsets to go away from |w| in order to find the offset
10847 for |(dx,dy)|, going counterclockwise if |ccw| is |true|. This assumes that
10848 |w| is the offset for some direction $(x',y')$ from which the angle to |(dx,dy)|
10849 in the sense determined by |ccw| is less than or equal to $180^\circ$.
10851 If the pen polygon has only two edges, they could both be parallel
10852 to |(dx,dy)|. In this case, we must be careful to stop after crossing the first
10853 such edge in order to avoid an infinite loop.
10855 @<Declare subroutines needed by |offset_prep|@>=
10856 integer mp_get_turn_amt (MP mp,pointer w, scaled dx,
10857 scaled dy, boolean ccw) {
10858 pointer ww; /* a neighbor of knot~|w| */
10859 integer s; /* turn amount so far */
10860 integer t; /* |ab_vs_cd| result */
10865 t=mp_ab_vs_cd(mp, dy,(x_coord(ww)-x_coord(w)),
10866 dx,(y_coord(ww)-y_coord(w)));
10873 while ( mp_ab_vs_cd(mp, dy,(x_coord(w)-x_coord(ww)),
10874 dx,(y_coord(w)-y_coord(ww))) < 0) {
10882 @ When we're all done, the final offset is |w0| and the final curve direction
10883 is |(dxin,dyin)|. With this knowledge of the incoming direction at |c|, we
10884 can correct |info(c)| which was erroneously based on an incoming offset
10887 @d fix_by(A) info(c)=info(c)+(A)
10889 @<Fix the offset change in |info(c)| and set |c| to the return value of...@>=
10890 mp->spec_offset=info(c)-zero_off;
10891 if ( link(c)==c ) {
10892 info(c)=zero_off+n;
10895 while ( w0!=h ) { fix_by(1); w0=link(w0); };
10896 while ( info(c)<=zero_off-n ) fix_by(n);
10897 while ( info(c)>zero_off ) fix_by(-n);
10898 if ( (info(c)!=zero_off)&&(mp_ab_vs_cd(mp, dy0,dxin,dx0,dyin)>=0) ) fix_by(n);
10901 @ Finally we want to reduce the general problem to situations that
10902 |fin_offset_prep| can handle. We split the cubic into at most three parts
10903 with respect to $d_{k-1}$, and apply |fin_offset_prep| to each part.
10905 @<Complete the offset splitting process@>=
10907 @<Compute test coeff...@>;
10908 @<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set
10909 |t:=fraction_one+1|@>;
10910 if ( t>fraction_one ) {
10911 mp_fin_offset_prep(mp, p,w,x0,x1,x2,y0,y1,y2,1,turn_amt);
10913 mp_split_cubic(mp, p,t); r=link(p);
10914 x1a=t_of_the_way(x0,x1); x1=t_of_the_way(x1,x2);
10915 x2a=t_of_the_way(x1a,x1);
10916 y1a=t_of_the_way(y0,y1); y1=t_of_the_way(y1,y2);
10917 y2a=t_of_the_way(y1a,y1);
10918 mp_fin_offset_prep(mp, p,w,x0,x1a,x2a,y0,y1a,y2a,1,0); x0=x2a; y0=y2a;
10919 info(r)=zero_off-1;
10920 if ( turn_amt>=0 ) {
10921 t1=t_of_the_way(t1,t2);
10923 t=mp_crossing_point(mp, 0,-t1,-t2);
10924 if ( t>fraction_one ) t=fraction_one;
10925 @<Split off another rising cubic for |fin_offset_prep|@>;
10926 mp_fin_offset_prep(mp, r,ww,x0,x1,x2,y0,y1,y2,-1,0);
10928 mp_fin_offset_prep(mp, r,ww,x0,x1,x2,y0,y1,y2,-1,(-1-turn_amt));
10932 @ @<Split off another rising cubic for |fin_offset_prep|@>=
10933 mp_split_cubic(mp, r,t); info(link(r))=zero_off+1;
10934 x1a=t_of_the_way(x1,x2); x1=t_of_the_way(x0,x1);
10935 x0a=t_of_the_way(x1,x1a);
10936 y1a=t_of_the_way(y1,y2); y1=t_of_the_way(y0,y1);
10937 y0a=t_of_the_way(y1,y1a);
10938 mp_fin_offset_prep(mp, link(r),w,x0a,x1a,x2,y0a,y1a,y2,1,turn_amt);
10941 @ At this point, the direction of the incoming pen edge is |(-du,-dv)|.
10942 When the component of $d(t)$ perpendicular to |(-du,-dv)| crosses zero, we
10943 need to decide whether the directions are parallel or antiparallel. We
10944 can test this by finding the dot product of $d(t)$ and |(-du,-dv)|, but this
10945 should be avoided when the value of |turn_amt| already determines the
10946 answer. If |t2<0|, there is one crossing and it is antiparallel only if
10947 |turn_amt>=0|. If |turn_amt<0|, there should always be at least one
10948 crossing and the first crossing cannot be antiparallel.
10950 @<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set...@>=
10951 t=mp_crossing_point(mp, t0,t1,t2);
10952 if ( turn_amt>=0 ) {
10956 u0=t_of_the_way(x0,x1);
10957 u1=t_of_the_way(x1,x2);
10958 ss=mp_take_fraction(mp, -du,t_of_the_way(u0,u1));
10959 v0=t_of_the_way(y0,y1);
10960 v1=t_of_the_way(y1,y2);
10961 ss=ss+mp_take_fraction(mp, -dv,t_of_the_way(v0,v1));
10962 if ( ss<0 ) t=fraction_one+1;
10964 } else if ( t>fraction_one ) {
10968 @ @<Other local variables for |offset_prep|@>=
10969 integer u0,u1,v0,v1; /* intermediate values for $d(t)$ calculation */
10970 integer ss = 0; /* the part of the dot product computed so far */
10971 int d_sign; /* sign of overall change in direction for this cubic */
10973 @ If the cubic almost has a cusp, it is a numerically ill-conditioned
10974 problem to decide which way it loops around but that's OK as long we're
10975 consistent. To make \&{doublepath} envelopes work properly, reversing
10976 the path should always change the sign of |turn_amt|.
10978 @<Decide on the net change in pen offsets and set |turn_amt|@>=
10979 d_sign=mp_ab_vs_cd(mp, dx,dyin, dxin,dy);
10981 @<Check rotation direction based on node position@>
10985 if ( dy>0 ) d_sign=1; else d_sign=-1;
10987 if ( dx>0 ) d_sign=1; else d_sign=-1;
10990 @<Make |ss| negative if and only if the total change in direction is
10991 more than $180^\circ$@>;
10992 turn_amt=mp_get_turn_amt(mp, w, dxin, dyin, (d_sign>0));
10993 if ( ss<0 ) turn_amt=turn_amt-d_sign*n
10995 @ We check rotation direction by looking at the vector connecting the current
10996 node with the next. If its angle with incoming and outgoing tangents has the
10997 same sign, we pick this as |d_sign|, since it means we have a flex, not a cusp.
10998 Otherwise we proceed to the cusp code.
11000 @<Check rotation direction based on node position@>=
11001 u0=x_coord(q)-x_coord(p);
11002 u1=y_coord(q)-y_coord(p);
11003 d_sign = half(mp_ab_vs_cd(mp, dx, u1, u0, dy)+
11004 mp_ab_vs_cd(mp, u0, dyin, dxin, u1));
11006 @ In order to be invariant under path reversal, the result of this computation
11007 should not change when |x0|, |y0|, $\ldots$ are all negated and |(x0,y0)| is
11008 then swapped with |(x2,y2)|. We make use of the identities
11009 |take_fraction(-a,-b)=take_fraction(a,b)| and
11010 |t_of_the_way(-a,-b)=-(t_of_the_way(a,b))|.
11012 @<Make |ss| negative if and only if the total change in direction is...@>=
11013 t0=half(mp_take_fraction(mp, x0,y2))-half(mp_take_fraction(mp, x2,y0));
11014 t1=half(mp_take_fraction(mp, x1,(y0+y2)))-half(mp_take_fraction(mp, y1,(x0+x2)));
11015 if ( t0==0 ) t0=d_sign; /* path reversal always negates |d_sign| */
11017 t=mp_crossing_point(mp, t0,t1,-t0);
11018 u0=t_of_the_way(x0,x1);
11019 u1=t_of_the_way(x1,x2);
11020 v0=t_of_the_way(y0,y1);
11021 v1=t_of_the_way(y1,y2);
11023 t=mp_crossing_point(mp, -t0,t1,t0);
11024 u0=t_of_the_way(x2,x1);
11025 u1=t_of_the_way(x1,x0);
11026 v0=t_of_the_way(y2,y1);
11027 v1=t_of_the_way(y1,y0);
11029 ss=mp_take_fraction(mp, (x0+x2),t_of_the_way(u0,u1))+
11030 mp_take_fraction(mp, (y0+y2),t_of_the_way(v0,v1))
11032 @ Here's a routine that prints an envelope spec in symbolic form. It assumes
11033 that the |cur_pen| has not been walked around to the first offset.
11036 void mp_print_spec (MP mp,pointer cur_spec, pointer cur_pen, const char *s) {
11037 pointer p,q; /* list traversal */
11038 pointer w; /* the current pen offset */
11039 mp_print_diagnostic(mp, "Envelope spec",s,true);
11040 p=cur_spec; w=mp_pen_walk(mp, cur_pen,mp->spec_offset);
11042 mp_print_two(mp, x_coord(cur_spec),y_coord(cur_spec));
11043 mp_print(mp, " % beginning with offset ");
11044 mp_print_two(mp, x_coord(w),y_coord(w));
11048 @<Print the cubic between |p| and |q|@>;
11050 if ((p==cur_spec) || (info(p)!=zero_off))
11053 if ( info(p)!=zero_off ) {
11054 @<Update |w| as indicated by |info(p)| and print an explanation@>;
11056 } while (p!=cur_spec);
11057 mp_print_nl(mp, " & cycle");
11058 mp_end_diagnostic(mp, true);
11061 @ @<Update |w| as indicated by |info(p)| and print an explanation@>=
11063 w=mp_pen_walk(mp, w, (info(p)-zero_off));
11064 mp_print(mp, " % ");
11065 if ( info(p)>zero_off ) mp_print(mp, "counter");
11066 mp_print(mp, "clockwise to offset ");
11067 mp_print_two(mp, x_coord(w),y_coord(w));
11070 @ @<Print the cubic between |p| and |q|@>=
11072 mp_print_nl(mp, " ..controls ");
11073 mp_print_two(mp, right_x(p),right_y(p));
11074 mp_print(mp, " and ");
11075 mp_print_two(mp, left_x(q),left_y(q));
11076 mp_print_nl(mp, " ..");
11077 mp_print_two(mp, x_coord(q),y_coord(q));
11080 @ Once we have an envelope spec, the remaining task to construct the actual
11081 envelope by offsetting each cubic as determined by the |info| fields in
11082 the knots. First we use |offset_prep| to convert the |c| into an envelope
11083 spec. Then we add the offsets so that |c| becomes a cyclic path that represents
11086 The |ljoin| and |miterlim| parameters control the treatment of points where the
11087 pen offset changes, and |lcap| controls the endpoints of a \&{doublepath}.
11088 The endpoints are easily located because |c| is given in undoubled form
11089 and then doubled in this procedure. We use |spec_p1| and |spec_p2| to keep
11090 track of the endpoints and treat them like very sharp corners.
11091 Butt end caps are treated like beveled joins; round end caps are treated like
11092 round joins; and square end caps are achieved by setting |join_type:=3|.
11094 None of these parameters apply to inside joins where the convolution tracing
11095 has retrograde lines. In such cases we use a simple connect-the-endpoints
11096 approach that is achieved by setting |join_type:=2|.
11098 @c @<Declare a function called |insert_knot|@>
11099 pointer mp_make_envelope (MP mp,pointer c, pointer h, small_number ljoin,
11100 small_number lcap, scaled miterlim) {
11101 pointer p,q,r,q0; /* for manipulating the path */
11102 int join_type=0; /* codes |0..3| for mitered, round, beveled, or square */
11103 pointer w,w0; /* the pen knot for the current offset */
11104 scaled qx,qy; /* unshifted coordinates of |q| */
11105 halfword k,k0; /* controls pen edge insertion */
11106 @<Other local variables for |make_envelope|@>;
11107 dxin=0; dyin=0; dxout=0; dyout=0;
11108 mp->spec_p1=null; mp->spec_p2=null;
11109 @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>;
11110 @<Use |offset_prep| to compute the envelope spec then walk |h| around to
11111 the initial offset@>;
11116 qx=x_coord(q); qy=y_coord(q);
11119 if ( k!=zero_off ) {
11120 @<Set |join_type| to indicate how to handle offset changes at~|q|@>;
11122 @<Add offset |w| to the cubic from |p| to |q|@>;
11123 while ( k!=zero_off ) {
11124 @<Step |w| and move |k| one step closer to |zero_off|@>;
11125 if ( (join_type==1)||(k==zero_off) )
11126 q=mp_insert_knot(mp, q,qx+x_coord(w),qy+y_coord(w));
11128 if ( q!=link(p) ) {
11129 @<Set |p=link(p)| and add knots between |p| and |q| as
11130 required by |join_type|@>;
11137 @ @<Use |offset_prep| to compute the envelope spec then walk |h| around to...@>=
11138 c=mp_offset_prep(mp, c,h);
11139 if ( mp->internal[mp_tracing_specs]>0 )
11140 mp_print_spec(mp, c,h,"");
11141 h=mp_pen_walk(mp, h,mp->spec_offset)
11143 @ Mitered and squared-off joins depend on path directions that are difficult to
11144 compute for degenerate cubics. The envelope spec computed by |offset_prep| can
11145 have degenerate cubics only if the entire cycle collapses to a single
11146 degenerate cubic. Setting |join_type:=2| in this case makes the computed
11147 envelope degenerate as well.
11149 @<Set |join_type| to indicate how to handle offset changes at~|q|@>=
11150 if ( k<zero_off ) {
11153 if ( (q!=mp->spec_p1)&&(q!=mp->spec_p2) ) join_type=ljoin;
11154 else if ( lcap==2 ) join_type=3;
11155 else join_type=2-lcap;
11156 if ( (join_type==0)||(join_type==3) ) {
11157 @<Set the incoming and outgoing directions at |q|; in case of
11158 degeneracy set |join_type:=2|@>;
11159 if ( join_type==0 ) {
11160 @<If |miterlim| is less than the secant of half the angle at |q|
11161 then set |join_type:=2|@>;
11166 @ @<If |miterlim| is less than the secant of half the angle at |q|...@>=
11168 tmp=mp_take_fraction(mp, miterlim,fraction_half+
11169 half(mp_take_fraction(mp, dxin,dxout)+mp_take_fraction(mp, dyin,dyout)));
11171 if ( mp_take_scaled(mp, miterlim,tmp)<unity ) join_type=2;
11174 @ @<Other local variables for |make_envelope|@>=
11175 fraction dxin,dyin,dxout,dyout; /* directions at |q| when square or mitered */
11176 scaled tmp; /* a temporary value */
11178 @ The coordinates of |p| have already been shifted unless |p| is the first
11179 knot in which case they get shifted at the very end.
11181 @<Add offset |w| to the cubic from |p| to |q|@>=
11182 right_x(p)=right_x(p)+x_coord(w);
11183 right_y(p)=right_y(p)+y_coord(w);
11184 left_x(q)=left_x(q)+x_coord(w);
11185 left_y(q)=left_y(q)+y_coord(w);
11186 x_coord(q)=x_coord(q)+x_coord(w);
11187 y_coord(q)=y_coord(q)+y_coord(w);
11188 left_type(q)=mp_explicit;
11189 right_type(q)=mp_explicit
11191 @ @<Step |w| and move |k| one step closer to |zero_off|@>=
11192 if ( k>zero_off ){ w=link(w); decr(k); }
11193 else { w=knil(w); incr(k); }
11195 @ The cubic from |q| to the new knot at |(x,y)| becomes a line segment and
11196 the |right_x| and |right_y| fields of |r| are set from |q|. This is done in
11197 case the cubic containing these control points is ``yet to be examined.''
11199 @<Declare a function called |insert_knot|@>=
11200 pointer mp_insert_knot (MP mp,pointer q, scaled x, scaled y) {
11201 /* returns the inserted knot */
11202 pointer r; /* the new knot */
11203 r=mp_get_node(mp, knot_node_size);
11204 link(r)=link(q); link(q)=r;
11205 right_x(r)=right_x(q);
11206 right_y(r)=right_y(q);
11209 right_x(q)=x_coord(q);
11210 right_y(q)=y_coord(q);
11211 left_x(r)=x_coord(r);
11212 left_y(r)=y_coord(r);
11213 left_type(r)=mp_explicit;
11214 right_type(r)=mp_explicit;
11215 originator(r)=mp_program_code;
11219 @ After setting |p:=link(p)|, either |join_type=1| or |q=link(p)|.
11221 @<Set |p=link(p)| and add knots between |p| and |q| as...@>=
11224 if ( (join_type==0)||(join_type==3) ) {
11225 if ( join_type==0 ) {
11226 @<Insert a new knot |r| between |p| and |q| as required for a mitered join@>
11228 @<Make |r| the last of two knots inserted between |p| and |q| to form a
11232 right_x(r)=x_coord(r);
11233 right_y(r)=y_coord(r);
11238 @ For very small angles, adding a knot is unnecessary and would cause numerical
11239 problems, so we just set |r:=null| in that case.
11241 @<Insert a new knot |r| between |p| and |q| as required for a mitered join@>=
11243 det=mp_take_fraction(mp, dyout,dxin)-mp_take_fraction(mp, dxout,dyin);
11244 if ( abs(det)<26844 ) {
11245 r=null; /* sine $<10^{-4}$ */
11247 tmp=mp_take_fraction(mp, x_coord(q)-x_coord(p),dyout)-
11248 mp_take_fraction(mp, y_coord(q)-y_coord(p),dxout);
11249 tmp=mp_make_fraction(mp, tmp,det);
11250 r=mp_insert_knot(mp, p,x_coord(p)+mp_take_fraction(mp, tmp,dxin),
11251 y_coord(p)+mp_take_fraction(mp, tmp,dyin));
11255 @ @<Other local variables for |make_envelope|@>=
11256 fraction det; /* a determinant used for mitered join calculations */
11258 @ @<Make |r| the last of two knots inserted between |p| and |q| to form a...@>=
11260 ht_x=y_coord(w)-y_coord(w0);
11261 ht_y=x_coord(w0)-x_coord(w);
11262 while ( (abs(ht_x)<fraction_half)&&(abs(ht_y)<fraction_half) ) {
11263 ht_x+=ht_x; ht_y+=ht_y;
11265 @<Scan the pen polygon between |w0| and |w| and make |max_ht| the range dot
11266 product with |(ht_x,ht_y)|@>;
11267 tmp=mp_make_fraction(mp, max_ht,mp_take_fraction(mp, dxin,ht_x)+
11268 mp_take_fraction(mp, dyin,ht_y));
11269 r=mp_insert_knot(mp, p,x_coord(p)+mp_take_fraction(mp, tmp,dxin),
11270 y_coord(p)+mp_take_fraction(mp, tmp,dyin));
11271 tmp=mp_make_fraction(mp, max_ht,mp_take_fraction(mp, dxout,ht_x)+
11272 mp_take_fraction(mp, dyout,ht_y));
11273 r=mp_insert_knot(mp, r,x_coord(q)+mp_take_fraction(mp, tmp,dxout),
11274 y_coord(q)+mp_take_fraction(mp, tmp,dyout));
11277 @ @<Other local variables for |make_envelope|@>=
11278 fraction ht_x,ht_y; /* perpendicular to the segment from |p| to |q| */
11279 scaled max_ht; /* maximum height of the pen polygon above the |w0|-|w| line */
11280 halfword kk; /* keeps track of the pen vertices being scanned */
11281 pointer ww; /* the pen vertex being tested */
11283 @ The dot product of the vector from |w0| to |ww| with |(ht_x,ht_y)| ranges
11284 from zero to |max_ht|.
11286 @<Scan the pen polygon between |w0| and |w| and make |max_ht| the range...@>=
11291 @<Step |ww| and move |kk| one step closer to |k0|@>;
11292 if ( kk==k0 ) break;
11293 tmp=mp_take_fraction(mp, (x_coord(ww)-x_coord(w0)),ht_x)+
11294 mp_take_fraction(mp, (y_coord(ww)-y_coord(w0)),ht_y);
11295 if ( tmp>max_ht ) max_ht=tmp;
11299 @ @<Step |ww| and move |kk| one step closer to |k0|@>=
11300 if ( kk>k0 ) { ww=link(ww); decr(kk); }
11301 else { ww=knil(ww); incr(kk); }
11303 @ @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>=
11304 if ( left_type(c)==mp_endpoint ) {
11305 mp->spec_p1=mp_htap_ypoc(mp, c);
11306 mp->spec_p2=mp->path_tail;
11307 originator(mp->spec_p1)=mp_program_code;
11308 link(mp->spec_p2)=link(mp->spec_p1);
11309 link(mp->spec_p1)=c;
11310 mp_remove_cubic(mp, mp->spec_p1);
11312 if ( c!=link(c) ) {
11313 originator(mp->spec_p2)=mp_program_code;
11314 mp_remove_cubic(mp, mp->spec_p2);
11316 @<Make |c| look like a cycle of length one@>;
11320 @ @<Make |c| look like a cycle of length one@>=
11322 left_type(c)=mp_explicit; right_type(c)=mp_explicit;
11323 left_x(c)=x_coord(c); left_y(c)=y_coord(c);
11324 right_x(c)=x_coord(c); right_y(c)=y_coord(c);
11327 @ In degenerate situations we might have to look at the knot preceding~|q|.
11328 That knot is |p| but if |p<>c|, its coordinates have already been offset by |w|.
11330 @<Set the incoming and outgoing directions at |q|; in case of...@>=
11331 dxin=x_coord(q)-left_x(q);
11332 dyin=y_coord(q)-left_y(q);
11333 if ( (dxin==0)&&(dyin==0) ) {
11334 dxin=x_coord(q)-right_x(p);
11335 dyin=y_coord(q)-right_y(p);
11336 if ( (dxin==0)&&(dyin==0) ) {
11337 dxin=x_coord(q)-x_coord(p);
11338 dyin=y_coord(q)-y_coord(p);
11339 if ( p!=c ) { /* the coordinates of |p| have been offset by |w| */
11340 dxin=dxin+x_coord(w);
11341 dyin=dyin+y_coord(w);
11345 tmp=mp_pyth_add(mp, dxin,dyin);
11349 dxin=mp_make_fraction(mp, dxin,tmp);
11350 dyin=mp_make_fraction(mp, dyin,tmp);
11351 @<Set the outgoing direction at |q|@>;
11354 @ If |q=c| then the coordinates of |r| and the control points between |q|
11355 and~|r| have already been offset by |h|.
11357 @<Set the outgoing direction at |q|@>=
11358 dxout=right_x(q)-x_coord(q);
11359 dyout=right_y(q)-y_coord(q);
11360 if ( (dxout==0)&&(dyout==0) ) {
11362 dxout=left_x(r)-x_coord(q);
11363 dyout=left_y(r)-y_coord(q);
11364 if ( (dxout==0)&&(dyout==0) ) {
11365 dxout=x_coord(r)-x_coord(q);
11366 dyout=y_coord(r)-y_coord(q);
11370 dxout=dxout-x_coord(h);
11371 dyout=dyout-y_coord(h);
11373 tmp=mp_pyth_add(mp, dxout,dyout);
11374 if ( tmp==0 ) mp_confusion(mp, "degenerate spec");
11375 @:this can't happen degerate spec}{\quad degenerate spec@>
11376 dxout=mp_make_fraction(mp, dxout,tmp);
11377 dyout=mp_make_fraction(mp, dyout,tmp)
11379 @* \[23] Direction and intersection times.
11380 A path of length $n$ is defined parametrically by functions $x(t)$ and
11381 $y(t)$, for |0<=t<=n|; we can regard $t$ as the ``time'' at which the path
11382 reaches the point $\bigl(x(t),y(t)\bigr)$. In this section of the program
11383 we shall consider operations that determine special times associated with
11384 given paths: the first time that a path travels in a given direction, and
11385 a pair of times at which two paths cross each other.
11387 @ Let's start with the easier task. The function |find_direction_time| is
11388 given a direction |(x,y)| and a path starting at~|h|. If the path never
11389 travels in direction |(x,y)|, the direction time will be~|-1|; otherwise
11390 it will be nonnegative.
11392 Certain anomalous cases can arise: If |(x,y)=(0,0)|, so that the given
11393 direction is undefined, the direction time will be~0. If $\bigl(x'(t),
11394 y'(t)\bigr)=(0,0)$, so that the path direction is undefined, it will be
11395 assumed to match any given direction at time~|t|.
11397 The routine solves this problem in nondegenerate cases by rotating the path
11398 and the given direction so that |(x,y)=(1,0)|; i.e., the main task will be
11399 to find when a given path first travels ``due east.''
11402 scaled mp_find_direction_time (MP mp,scaled x, scaled y, pointer h) {
11403 scaled max; /* $\max\bigl(\vert x\vert,\vert y\vert\bigr)$ */
11404 pointer p,q; /* for list traversal */
11405 scaled n; /* the direction time at knot |p| */
11406 scaled tt; /* the direction time within a cubic */
11407 @<Other local variables for |find_direction_time|@>;
11408 @<Normalize the given direction for better accuracy;
11409 but |return| with zero result if it's zero@>;
11412 if ( right_type(p)==mp_endpoint ) break;
11414 @<Rotate the cubic between |p| and |q|; then
11415 |goto found| if the rotated cubic travels due east at some time |tt|;
11416 but |break| if an entire cyclic path has been traversed@>;
11424 @ @<Normalize the given direction for better accuracy...@>=
11425 if ( abs(x)<abs(y) ) {
11426 x=mp_make_fraction(mp, x,abs(y));
11427 if ( y>0 ) y=fraction_one; else y=-fraction_one;
11428 } else if ( x==0 ) {
11431 y=mp_make_fraction(mp, y,abs(x));
11432 if ( x>0 ) x=fraction_one; else x=-fraction_one;
11435 @ Since we're interested in the tangent directions, we work with the
11436 derivative $${1\over3}B'(x_0,x_1,x_2,x_3;t)=
11437 B(x_1-x_0,x_2-x_1,x_3-x_2;t)$$ instead of
11438 $B(x_0,x_1,x_2,x_3;t)$ itself. The derived coefficients are also scaled up
11439 in order to achieve better accuracy.
11441 The given path may turn abruptly at a knot, and it might pass the critical
11442 tangent direction at such a time. Therefore we remember the direction |phi|
11443 in which the previous rotated cubic was traveling. (The value of |phi| will be
11444 undefined on the first cubic, i.e., when |n=0|.)
11446 @<Rotate the cubic between |p| and |q|; then...@>=
11448 @<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples of the control
11449 points of the rotated derivatives@>;
11450 if ( y1==0 ) if ( x1>=0 ) goto FOUND;
11452 @<Exit to |found| if an eastward direction occurs at knot |p|@>;
11455 if ( (x3!=0)||(y3!=0) ) phi=mp_n_arg(mp, x3,y3);
11456 @<Exit to |found| if the curve whose derivatives are specified by
11457 |x1,x2,x3,y1,y2,y3| travels eastward at some time~|tt|@>
11459 @ @<Other local variables for |find_direction_time|@>=
11460 scaled x1,x2,x3,y1,y2,y3; /* multiples of rotated derivatives */
11461 angle theta,phi; /* angles of exit and entry at a knot */
11462 fraction t; /* temp storage */
11464 @ @<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples...@>=
11465 x1=right_x(p)-x_coord(p); x2=left_x(q)-right_x(p);
11466 x3=x_coord(q)-left_x(q);
11467 y1=right_y(p)-y_coord(p); y2=left_y(q)-right_y(p);
11468 y3=y_coord(q)-left_y(q);
11470 if ( abs(x2)>max ) max=abs(x2);
11471 if ( abs(x3)>max ) max=abs(x3);
11472 if ( abs(y1)>max ) max=abs(y1);
11473 if ( abs(y2)>max ) max=abs(y2);
11474 if ( abs(y3)>max ) max=abs(y3);
11475 if ( max==0 ) goto FOUND;
11476 while ( max<fraction_half ){
11477 max+=max; x1+=x1; x2+=x2; x3+=x3;
11478 y1+=y1; y2+=y2; y3+=y3;
11480 t=x1; x1=mp_take_fraction(mp, x1,x)+mp_take_fraction(mp, y1,y);
11481 y1=mp_take_fraction(mp, y1,x)-mp_take_fraction(mp, t,y);
11482 t=x2; x2=mp_take_fraction(mp, x2,x)+mp_take_fraction(mp, y2,y);
11483 y2=mp_take_fraction(mp, y2,x)-mp_take_fraction(mp, t,y);
11484 t=x3; x3=mp_take_fraction(mp, x3,x)+mp_take_fraction(mp, y3,y);
11485 y3=mp_take_fraction(mp, y3,x)-mp_take_fraction(mp, t,y)
11487 @ @<Exit to |found| if an eastward direction occurs at knot |p|@>=
11488 theta=mp_n_arg(mp, x1,y1);
11489 if ( theta>=0 ) if ( phi<=0 ) if ( phi>=theta-one_eighty_deg ) goto FOUND;
11490 if ( theta<=0 ) if ( phi>=0 ) if ( phi<=theta+one_eighty_deg ) goto FOUND
11492 @ In this step we want to use the |crossing_point| routine to find the
11493 roots of the quadratic equation $B(y_1,y_2,y_3;t)=0$.
11494 Several complications arise: If the quadratic equation has a double root,
11495 the curve never crosses zero, and |crossing_point| will find nothing;
11496 this case occurs iff $y_1y_3=y_2^2$ and $y_1y_2<0$. If the quadratic
11497 equation has simple roots, or only one root, we may have to negate it
11498 so that $B(y_1,y_2,y_3;t)$ crosses from positive to negative at its first root.
11499 And finally, we need to do special things if $B(y_1,y_2,y_3;t)$ is
11502 @ @<Exit to |found| if the curve whose derivatives are specified by...@>=
11503 if ( x1<0 ) if ( x2<0 ) if ( x3<0 ) goto DONE;
11504 if ( mp_ab_vs_cd(mp, y1,y3,y2,y2)==0 ) {
11505 @<Handle the test for eastward directions when $y_1y_3=y_2^2$;
11506 either |goto found| or |goto done|@>;
11509 if ( y1<0 ) { y1=-y1; y2=-y2; y3=-y3; }
11510 else if ( y2>0 ){ y2=-y2; y3=-y3; };
11512 @<Check the places where $B(y_1,y_2,y_3;t)=0$ to see if
11513 $B(x_1,x_2,x_3;t)\ge0$@>;
11516 @ The quadratic polynomial $B(y_1,y_2,y_3;t)$ begins |>=0| and has at most
11517 two roots, because we know that it isn't identically zero.
11519 It must be admitted that the |crossing_point| routine is not perfectly accurate;
11520 rounding errors might cause it to find a root when $y_1y_3>y_2^2$, or to
11521 miss the roots when $y_1y_3<y_2^2$. The rotation process is itself
11522 subject to rounding errors. Yet this code optimistically tries to
11523 do the right thing.
11525 @d we_found_it { tt=(t+04000) / 010000; goto FOUND; }
11527 @<Check the places where $B(y_1,y_2,y_3;t)=0$...@>=
11528 t=mp_crossing_point(mp, y1,y2,y3);
11529 if ( t>fraction_one ) goto DONE;
11530 y2=t_of_the_way(y2,y3);
11531 x1=t_of_the_way(x1,x2);
11532 x2=t_of_the_way(x2,x3);
11533 x1=t_of_the_way(x1,x2);
11534 if ( x1>=0 ) we_found_it;
11536 tt=t; t=mp_crossing_point(mp, 0,-y2,-y3);
11537 if ( t>fraction_one ) goto DONE;
11538 x1=t_of_the_way(x1,x2);
11539 x2=t_of_the_way(x2,x3);
11540 if ( t_of_the_way(x1,x2)>=0 ) {
11541 t=t_of_the_way(tt,fraction_one); we_found_it;
11544 @ @<Handle the test for eastward directions when $y_1y_3=y_2^2$;
11545 either |goto found| or |goto done|@>=
11547 if ( mp_ab_vs_cd(mp, y1,y2,0,0)<0 ) {
11548 t=mp_make_fraction(mp, y1,y1-y2);
11549 x1=t_of_the_way(x1,x2);
11550 x2=t_of_the_way(x2,x3);
11551 if ( t_of_the_way(x1,x2)>=0 ) we_found_it;
11552 } else if ( y3==0 ) {
11554 @<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|@>;
11555 } else if ( x3>=0 ) {
11556 tt=unity; goto FOUND;
11562 @ At this point we know that the derivative of |y(t)| is identically zero,
11563 and that |x1<0|; but either |x2>=0| or |x3>=0|, so there's some hope of
11566 @<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|...@>=
11568 t=mp_crossing_point(mp, -x1,-x2,-x3);
11569 if ( t<=fraction_one ) we_found_it;
11570 if ( mp_ab_vs_cd(mp, x1,x3,x2,x2)<=0 ) {
11571 t=mp_make_fraction(mp, x1,x1-x2); we_found_it;
11575 @ The intersection of two cubics can be found by an interesting variant
11576 of the general bisection scheme described in the introduction to
11578 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)$,
11579 we wish to find a pair of times $(t_1,t_2)$ such that $w(t_1)=z(t_2)$,
11580 if an intersection exists. First we find the smallest rectangle that
11581 encloses the points $\{w_0,w_1,w_2,w_3\}$ and check that it overlaps
11582 the smallest rectangle that encloses
11583 $\{z_0,z_1,z_2,z_3\}$; if not, the cubics certainly don't intersect.
11584 But if the rectangles do overlap, we bisect the intervals, getting
11585 new cubics $w'$ and~$w''$, $z'$~and~$z''$; the intersection routine first
11586 tries for an intersection between $w'$ and~$z'$, then (if unsuccessful)
11587 between $w'$ and~$z''$, then (if still unsuccessful) between $w''$ and~$z'$,
11588 finally (if thrice unsuccessful) between $w''$ and~$z''$. After $l$~successful
11589 levels of bisection we will have determined the intersection times $t_1$
11590 and~$t_2$ to $l$~bits of accuracy.
11592 \def\submin{_{\rm min}} \def\submax{_{\rm max}}
11593 As before, it is better to work with the numbers $W_k=2^l(w_k-w_{k-1})$
11594 and $Z_k=2^l(z_k-z_{k-1})$ rather than the coefficients $w_k$ and $z_k$
11595 themselves. We also need one other quantity, $\Delta=2^l(w_0-z_0)$,
11596 to determine when the enclosing rectangles overlap. Here's why:
11597 The $x$~coordinates of~$w(t)$ are between $u\submin$ and $u\submax$,
11598 and the $x$~coordinates of~$z(t)$ are between $x\submin$ and $x\submax$,
11599 if we write $w_k=(u_k,v_k)$ and $z_k=(x_k,y_k)$ and $u\submin=
11600 \min(u_0,u_1,u_2,u_3)$, etc. These intervals of $x$~coordinates
11601 overlap if and only if $u\submin\L x\submax$ and
11602 $x\submin\L u\submax$. Letting
11603 $$U\submin=\min(0,U_1,U_1+U_2,U_1+U_2+U_3),\;
11604 U\submax=\max(0,U_1,U_1+U_2,U_1+U_2+U_3),$$
11605 we have $2^lu\submin=2^lu_0+U\submin$, etc.; the condition for overlap
11607 $$X\submin-U\submax\L 2^l(u_0-x_0)\L X\submax-U\submin.$$
11608 Thus we want to maintain the quantity $2^l(u_0-x_0)$; similarly,
11609 the quantity $2^l(v_0-y_0)$ accounts for the $y$~coordinates. The
11610 coordinates of $\Delta=2^l(w_0-z_0)$ must stay bounded as $l$ increases,
11611 because of the overlap condition; i.e., we know that $X\submin$,
11612 $X\submax$, and their relatives are bounded, hence $X\submax-
11613 U\submin$ and $X\submin-U\submax$ are bounded.
11615 @ Incidentally, if the given cubics intersect more than once, the process
11616 just sketched will not necessarily find the lexicographically smallest pair
11617 $(t_1,t_2)$. The solution actually obtained will be smallest in ``shuffled
11618 order''; i.e., if $t_1=(.a_1a_2\ldots a_{16})_2$ and
11619 $t_2=(.b_1b_2\ldots b_{16})_2$, then we will minimize
11620 $a_1b_1a_2b_2\ldots a_{16}b_{16}$, not
11621 $a_1a_2\ldots a_{16}b_1b_2\ldots b_{16}$.
11622 Shuffled order agrees with lexicographic order if all pairs of solutions
11623 $(t_1,t_2)$ and $(t_1',t_2')$ have the property that $t_1<t_1'$ iff
11624 $t_2<t_2'$; but in general, lexicographic order can be quite different,
11625 and the bisection algorithm would be substantially less efficient if it were
11626 constrained by lexicographic order.
11628 For example, suppose that an overlap has been found for $l=3$ and
11629 $(t_1,t_2)= (.101,.011)$ in binary, but that no overlap is produced by
11630 either of the alternatives $(.1010,.0110)$, $(.1010,.0111)$ at level~4.
11631 Then there is probably an intersection in one of the subintervals
11632 $(.1011,.011x)$; but lexicographic order would require us to explore
11633 $(.1010,.1xxx)$ and $(.1011,.00xx)$ and $(.1011,.010x)$ first. We wouldn't
11634 want to store all of the subdivision data for the second path, so the
11635 subdivisions would have to be regenerated many times. Such inefficiencies
11636 would be associated with every `1' in the binary representation of~$t_1$.
11638 @ The subdivision process introduces rounding errors, hence we need to
11639 make a more liberal test for overlap. It is not hard to show that the
11640 computed values of $U_i$ differ from the truth by at most~$l$, on
11641 level~$l$, hence $U\submin$ and $U\submax$ will be at most $3l$ in error.
11642 If $\beta$ is an upper bound on the absolute error in the computed
11643 components of $\Delta=(|delx|,|dely|)$ on level~$l$, we will replace
11644 the test `$X\submin-U\submax\L|delx|$' by the more liberal test
11645 `$X\submin-U\submax\L|delx|+|tol|$', where $|tol|=6l+\beta$.
11647 More accuracy is obtained if we try the algorithm first with |tol=0|;
11648 the more liberal tolerance is used only if an exact approach fails.
11649 It is convenient to do this double-take by letting `3' in the preceding
11650 paragraph be a parameter, which is first 0, then 3.
11653 unsigned int tol_step; /* either 0 or 3, usually */
11655 @ We shall use an explicit stack to implement the recursive bisection
11656 method described above. The |bisect_stack| array will contain numerous 5-word
11657 packets like $(U_1,U_2,U_3,U\submin,U\submax)$, as well as 20-word packets
11658 comprising the 5-word packets for $U$, $V$, $X$, and~$Y$.
11660 The following macros define the allocation of stack positions to
11661 the quantities needed for bisection-intersection.
11663 @d stack_1(A) mp->bisect_stack[(A)] /* $U_1$, $V_1$, $X_1$, or $Y_1$ */
11664 @d stack_2(A) mp->bisect_stack[(A)+1] /* $U_2$, $V_2$, $X_2$, or $Y_2$ */
11665 @d stack_3(A) mp->bisect_stack[(A)+2] /* $U_3$, $V_3$, $X_3$, or $Y_3$ */
11666 @d stack_min(A) mp->bisect_stack[(A)+3]
11667 /* $U\submin$, $V\submin$, $X\submin$, or $Y\submin$ */
11668 @d stack_max(A) mp->bisect_stack[(A)+4]
11669 /* $U\submax$, $V\submax$, $X\submax$, or $Y\submax$ */
11670 @d int_packets 20 /* number of words to represent $U_k$, $V_k$, $X_k$, and $Y_k$ */
11672 @d u_packet(A) ((A)-5)
11673 @d v_packet(A) ((A)-10)
11674 @d x_packet(A) ((A)-15)
11675 @d y_packet(A) ((A)-20)
11676 @d l_packets (mp->bisect_ptr-int_packets)
11677 @d r_packets mp->bisect_ptr
11678 @d ul_packet u_packet(l_packets) /* base of $U'_k$ variables */
11679 @d vl_packet v_packet(l_packets) /* base of $V'_k$ variables */
11680 @d xl_packet x_packet(l_packets) /* base of $X'_k$ variables */
11681 @d yl_packet y_packet(l_packets) /* base of $Y'_k$ variables */
11682 @d ur_packet u_packet(r_packets) /* base of $U''_k$ variables */
11683 @d vr_packet v_packet(r_packets) /* base of $V''_k$ variables */
11684 @d xr_packet x_packet(r_packets) /* base of $X''_k$ variables */
11685 @d yr_packet y_packet(r_packets) /* base of $Y''_k$ variables */
11687 @d u1l stack_1(ul_packet) /* $U'_1$ */
11688 @d u2l stack_2(ul_packet) /* $U'_2$ */
11689 @d u3l stack_3(ul_packet) /* $U'_3$ */
11690 @d v1l stack_1(vl_packet) /* $V'_1$ */
11691 @d v2l stack_2(vl_packet) /* $V'_2$ */
11692 @d v3l stack_3(vl_packet) /* $V'_3$ */
11693 @d x1l stack_1(xl_packet) /* $X'_1$ */
11694 @d x2l stack_2(xl_packet) /* $X'_2$ */
11695 @d x3l stack_3(xl_packet) /* $X'_3$ */
11696 @d y1l stack_1(yl_packet) /* $Y'_1$ */
11697 @d y2l stack_2(yl_packet) /* $Y'_2$ */
11698 @d y3l stack_3(yl_packet) /* $Y'_3$ */
11699 @d u1r stack_1(ur_packet) /* $U''_1$ */
11700 @d u2r stack_2(ur_packet) /* $U''_2$ */
11701 @d u3r stack_3(ur_packet) /* $U''_3$ */
11702 @d v1r stack_1(vr_packet) /* $V''_1$ */
11703 @d v2r stack_2(vr_packet) /* $V''_2$ */
11704 @d v3r stack_3(vr_packet) /* $V''_3$ */
11705 @d x1r stack_1(xr_packet) /* $X''_1$ */
11706 @d x2r stack_2(xr_packet) /* $X''_2$ */
11707 @d x3r stack_3(xr_packet) /* $X''_3$ */
11708 @d y1r stack_1(yr_packet) /* $Y''_1$ */
11709 @d y2r stack_2(yr_packet) /* $Y''_2$ */
11710 @d y3r stack_3(yr_packet) /* $Y''_3$ */
11712 @d stack_dx mp->bisect_stack[mp->bisect_ptr] /* stacked value of |delx| */
11713 @d stack_dy mp->bisect_stack[mp->bisect_ptr+1] /* stacked value of |dely| */
11714 @d stack_tol mp->bisect_stack[mp->bisect_ptr+2] /* stacked value of |tol| */
11715 @d stack_uv mp->bisect_stack[mp->bisect_ptr+3] /* stacked value of |uv| */
11716 @d stack_xy mp->bisect_stack[mp->bisect_ptr+4] /* stacked value of |xy| */
11717 @d int_increment (int_packets+int_packets+5) /* number of stack words per level */
11720 integer *bisect_stack;
11721 unsigned int bisect_ptr;
11723 @ @<Allocate or initialize ...@>=
11724 mp->bisect_stack = xmalloc((bistack_size+1),sizeof(integer));
11726 @ @<Dealloc variables@>=
11727 xfree(mp->bisect_stack);
11729 @ @<Check the ``constant''...@>=
11730 if ( int_packets+17*int_increment>bistack_size ) mp->bad=19;
11732 @ Computation of the min and max is a tedious but fairly fast sequence of
11733 instructions; exactly four comparisons are made in each branch.
11736 if ( stack_1((A))<0 ) {
11737 if ( stack_3((A))>=0 ) {
11738 if ( stack_2((A))<0 ) stack_min((A))=stack_1((A))+stack_2((A));
11739 else stack_min((A))=stack_1((A));
11740 stack_max((A))=stack_1((A))+stack_2((A))+stack_3((A));
11741 if ( stack_max((A))<0 ) stack_max((A))=0;
11743 stack_min((A))=stack_1((A))+stack_2((A))+stack_3((A));
11744 if ( stack_min((A))>stack_1((A)) ) stack_min((A))=stack_1((A));
11745 stack_max((A))=stack_1((A))+stack_2((A));
11746 if ( stack_max((A))<0 ) stack_max((A))=0;
11748 } else if ( stack_3((A))<=0 ) {
11749 if ( stack_2((A))>0 ) stack_max((A))=stack_1((A))+stack_2((A));
11750 else stack_max((A))=stack_1((A));
11751 stack_min((A))=stack_1((A))+stack_2((A))+stack_3((A));
11752 if ( stack_min((A))>0 ) stack_min((A))=0;
11754 stack_max((A))=stack_1((A))+stack_2((A))+stack_3((A));
11755 if ( stack_max((A))<stack_1((A)) ) stack_max((A))=stack_1((A));
11756 stack_min((A))=stack_1((A))+stack_2((A));
11757 if ( stack_min((A))>0 ) stack_min((A))=0;
11760 @ It's convenient to keep the current values of $l$, $t_1$, and $t_2$ in
11761 the integer form $2^l+2^lt_1$ and $2^l+2^lt_2$. The |cubic_intersection|
11762 routine uses global variables |cur_t| and |cur_tt| for this purpose;
11763 after successful completion, |cur_t| and |cur_tt| will contain |unity|
11764 plus the |scaled| values of $t_1$ and~$t_2$.
11766 The values of |cur_t| and |cur_tt| will be set to zero if |cubic_intersection|
11767 finds no intersection. The routine gives up and gives an approximate answer
11768 if it has backtracked
11769 more than 5000 times (otherwise there are cases where several minutes
11770 of fruitless computation would be possible).
11772 @d max_patience 5000
11775 integer cur_t;integer cur_tt; /* controls and results of |cubic_intersection| */
11776 integer time_to_go; /* this many backtracks before giving up */
11777 integer max_t; /* maximum of $2^{l+1}$ so far achieved */
11779 @ The given cubics $B(w_0,w_1,w_2,w_3;t)$ and
11780 $B(z_0,z_1,z_2,z_3;t)$ are specified in adjacent knot nodes |(p,link(p))|
11781 and |(pp,link(pp))|, respectively.
11783 @c void mp_cubic_intersection (MP mp,pointer p, pointer pp) {
11784 pointer q,qq; /* |link(p)|, |link(pp)| */
11785 mp->time_to_go=max_patience; mp->max_t=2;
11786 @<Initialize for intersections at level zero@>;
11789 if ( mp->delx-mp->tol<=stack_max(x_packet(mp->xy))-stack_min(u_packet(mp->uv)))
11790 if ( mp->delx+mp->tol>=stack_min(x_packet(mp->xy))-stack_max(u_packet(mp->uv)))
11791 if ( mp->dely-mp->tol<=stack_max(y_packet(mp->xy))-stack_min(v_packet(mp->uv)))
11792 if ( mp->dely+mp->tol>=stack_min(y_packet(mp->xy))-stack_max(v_packet(mp->uv)))
11794 if ( mp->cur_t>=mp->max_t ){
11795 if ( mp->max_t==two ) { /* we've done 17 bisections */
11796 mp->cur_t=halfp(mp->cur_t+1);
11797 mp->cur_tt=halfp(mp->cur_tt+1);
11800 mp->max_t+=mp->max_t; mp->appr_t=mp->cur_t; mp->appr_tt=mp->cur_tt;
11802 @<Subdivide for a new level of intersection@>;
11805 if ( mp->time_to_go>0 ) {
11806 decr(mp->time_to_go);
11808 while ( mp->appr_t<unity ) {
11809 mp->appr_t+=mp->appr_t; mp->appr_tt+=mp->appr_tt;
11811 mp->cur_t=mp->appr_t; mp->cur_tt=mp->appr_tt; return;
11813 @<Advance to the next pair |(cur_t,cur_tt)|@>;
11817 @ The following variables are global, although they are used only by
11818 |cubic_intersection|, because it is necessary on some machines to
11819 split |cubic_intersection| up into two procedures.
11822 integer delx;integer dely; /* the components of $\Delta=2^l(w_0-z_0)$ */
11823 integer tol; /* bound on the uncertainty in the overlap test */
11825 unsigned int xy; /* pointers to the current packets of interest */
11826 integer three_l; /* |tol_step| times the bisection level */
11827 integer appr_t;integer appr_tt; /* best approximations known to the answers */
11829 @ We shall assume that the coordinates are sufficiently non-extreme that
11830 integer overflow will not occur.
11831 @^overflow in arithmetic@>
11833 @<Initialize for intersections at level zero@>=
11834 q=link(p); qq=link(pp); mp->bisect_ptr=int_packets;
11835 u1r=right_x(p)-x_coord(p); u2r=left_x(q)-right_x(p);
11836 u3r=x_coord(q)-left_x(q); set_min_max(ur_packet);
11837 v1r=right_y(p)-y_coord(p); v2r=left_y(q)-right_y(p);
11838 v3r=y_coord(q)-left_y(q); set_min_max(vr_packet);
11839 x1r=right_x(pp)-x_coord(pp); x2r=left_x(qq)-right_x(pp);
11840 x3r=x_coord(qq)-left_x(qq); set_min_max(xr_packet);
11841 y1r=right_y(pp)-y_coord(pp); y2r=left_y(qq)-right_y(pp);
11842 y3r=y_coord(qq)-left_y(qq); set_min_max(yr_packet);
11843 mp->delx=x_coord(p)-x_coord(pp); mp->dely=y_coord(p)-y_coord(pp);
11844 mp->tol=0; mp->uv=r_packets; mp->xy=r_packets;
11845 mp->three_l=0; mp->cur_t=1; mp->cur_tt=1
11847 @ @<Subdivide for a new level of intersection@>=
11848 stack_dx=mp->delx; stack_dy=mp->dely; stack_tol=mp->tol;
11849 stack_uv=mp->uv; stack_xy=mp->xy;
11850 mp->bisect_ptr=mp->bisect_ptr+int_increment;
11851 mp->cur_t+=mp->cur_t; mp->cur_tt+=mp->cur_tt;
11852 u1l=stack_1(u_packet(mp->uv)); u3r=stack_3(u_packet(mp->uv));
11853 u2l=half(u1l+stack_2(u_packet(mp->uv)));
11854 u2r=half(u3r+stack_2(u_packet(mp->uv)));
11855 u3l=half(u2l+u2r); u1r=u3l;
11856 set_min_max(ul_packet); set_min_max(ur_packet);
11857 v1l=stack_1(v_packet(mp->uv)); v3r=stack_3(v_packet(mp->uv));
11858 v2l=half(v1l+stack_2(v_packet(mp->uv)));
11859 v2r=half(v3r+stack_2(v_packet(mp->uv)));
11860 v3l=half(v2l+v2r); v1r=v3l;
11861 set_min_max(vl_packet); set_min_max(vr_packet);
11862 x1l=stack_1(x_packet(mp->xy)); x3r=stack_3(x_packet(mp->xy));
11863 x2l=half(x1l+stack_2(x_packet(mp->xy)));
11864 x2r=half(x3r+stack_2(x_packet(mp->xy)));
11865 x3l=half(x2l+x2r); x1r=x3l;
11866 set_min_max(xl_packet); set_min_max(xr_packet);
11867 y1l=stack_1(y_packet(mp->xy)); y3r=stack_3(y_packet(mp->xy));
11868 y2l=half(y1l+stack_2(y_packet(mp->xy)));
11869 y2r=half(y3r+stack_2(y_packet(mp->xy)));
11870 y3l=half(y2l+y2r); y1r=y3l;
11871 set_min_max(yl_packet); set_min_max(yr_packet);
11872 mp->uv=l_packets; mp->xy=l_packets;
11873 mp->delx+=mp->delx; mp->dely+=mp->dely;
11874 mp->tol=mp->tol-mp->three_l+mp->tol_step;
11875 mp->tol+=mp->tol; mp->three_l=mp->three_l+mp->tol_step
11877 @ @<Advance to the next pair |(cur_t,cur_tt)|@>=
11879 if ( odd(mp->cur_tt) ) {
11880 if ( odd(mp->cur_t) ) {
11881 @<Descend to the previous level and |goto not_found|@>;
11884 mp->delx=mp->delx+stack_1(u_packet(mp->uv))+stack_2(u_packet(mp->uv))
11885 +stack_3(u_packet(mp->uv));
11886 mp->dely=mp->dely+stack_1(v_packet(mp->uv))+stack_2(v_packet(mp->uv))
11887 +stack_3(v_packet(mp->uv));
11888 mp->uv=mp->uv+int_packets; /* switch from |l_packets| to |r_packets| */
11889 decr(mp->cur_tt); mp->xy=mp->xy-int_packets;
11890 /* switch from |r_packets| to |l_packets| */
11891 mp->delx=mp->delx+stack_1(x_packet(mp->xy))+stack_2(x_packet(mp->xy))
11892 +stack_3(x_packet(mp->xy));
11893 mp->dely=mp->dely+stack_1(y_packet(mp->xy))+stack_2(y_packet(mp->xy))
11894 +stack_3(y_packet(mp->xy));
11897 incr(mp->cur_tt); mp->tol=mp->tol+mp->three_l;
11898 mp->delx=mp->delx-stack_1(x_packet(mp->xy))-stack_2(x_packet(mp->xy))
11899 -stack_3(x_packet(mp->xy));
11900 mp->dely=mp->dely-stack_1(y_packet(mp->xy))-stack_2(y_packet(mp->xy))
11901 -stack_3(y_packet(mp->xy));
11902 mp->xy=mp->xy+int_packets; /* switch from |l_packets| to |r_packets| */
11905 @ @<Descend to the previous level...@>=
11907 mp->cur_t=halfp(mp->cur_t); mp->cur_tt=halfp(mp->cur_tt);
11908 if ( mp->cur_t==0 ) return;
11909 mp->bisect_ptr=mp->bisect_ptr-int_increment;
11910 mp->three_l=mp->three_l-mp->tol_step;
11911 mp->delx=stack_dx; mp->dely=stack_dy; mp->tol=stack_tol;
11912 mp->uv=stack_uv; mp->xy=stack_xy;
11916 @ The |path_intersection| procedure is much simpler.
11917 It invokes |cubic_intersection| in lexicographic order until finding a
11918 pair of cubics that intersect. The final intersection times are placed in
11919 |cur_t| and~|cur_tt|.
11921 @c void mp_path_intersection (MP mp,pointer h, pointer hh) {
11922 pointer p,pp; /* link registers that traverse the given paths */
11923 integer n,nn; /* integer parts of intersection times, minus |unity| */
11924 @<Change one-point paths into dead cycles@>;
11929 if ( right_type(p)!=mp_endpoint ) {
11932 if ( right_type(pp)!=mp_endpoint ) {
11933 mp_cubic_intersection(mp, p,pp);
11934 if ( mp->cur_t>0 ) {
11935 mp->cur_t=mp->cur_t+n; mp->cur_tt=mp->cur_tt+nn;
11939 nn=nn+unity; pp=link(pp);
11942 n=n+unity; p=link(p);
11944 mp->tol_step=mp->tol_step+3;
11945 } while (mp->tol_step<=3);
11946 mp->cur_t=-unity; mp->cur_tt=-unity;
11949 @ @<Change one-point paths...@>=
11950 if ( right_type(h)==mp_endpoint ) {
11951 right_x(h)=x_coord(h); left_x(h)=x_coord(h);
11952 right_y(h)=y_coord(h); left_y(h)=y_coord(h); right_type(h)=mp_explicit;
11954 if ( right_type(hh)==mp_endpoint ) {
11955 right_x(hh)=x_coord(hh); left_x(hh)=x_coord(hh);
11956 right_y(hh)=y_coord(hh); left_y(hh)=y_coord(hh); right_type(hh)=mp_explicit;
11959 @* \[24] Dynamic linear equations.
11960 \MP\ users define variables implicitly by stating equations that should be
11961 satisfied; the computer is supposed to be smart enough to solve those equations.
11962 And indeed, the computer tries valiantly to do so, by distinguishing five
11963 different types of numeric values:
11966 |type(p)=mp_known| is the nice case, when |value(p)| is the |scaled| value
11967 of the variable whose address is~|p|.
11970 |type(p)=mp_dependent| means that |value(p)| is not present, but |dep_list(p)|
11971 points to a {\sl dependency list\/} that expresses the value of variable~|p|
11972 as a |scaled| number plus a sum of independent variables with |fraction|
11976 |type(p)=mp_independent| means that |value(p)=64s+m|, where |s>0| is a ``serial
11977 number'' reflecting the time this variable was first used in an equation;
11978 also |0<=m<64|, and each dependent variable
11979 that refers to this one is actually referring to the future value of
11980 this variable times~$2^m$. (Usually |m=0|, but higher degrees of
11981 scaling are sometimes needed to keep the coefficients in dependency lists
11982 from getting too large. The value of~|m| will always be even.)
11985 |type(p)=mp_numeric_type| means that variable |p| hasn't appeared in an
11986 equation before, but it has been explicitly declared to be numeric.
11989 |type(p)=undefined| means that variable |p| hasn't appeared before.
11991 \smallskip\noindent
11992 We have actually discussed these five types in the reverse order of their
11993 history during a computation: Once |known|, a variable never again
11994 becomes |dependent|; once |dependent|, it almost never again becomes
11995 |mp_independent|; once |mp_independent|, it never again becomes |mp_numeric_type|;
11996 and once |mp_numeric_type|, it never again becomes |undefined| (except
11997 of course when the user specifically decides to scrap the old value
11998 and start again). A backward step may, however, take place: Sometimes
11999 a |dependent| variable becomes |mp_independent| again, when one of the
12000 independent variables it depends on is reverting to |undefined|.
12003 The next patch detects overflow of independent-variable serial
12004 numbers. Diagnosed and patched by Thorsten Dahlheimer.
12006 @d s_scale 64 /* the serial numbers are multiplied by this factor */
12007 @d new_indep(A) /* create a new independent variable */
12008 { if ( mp->serial_no>el_gordo-s_scale )
12009 mp_fatal_error(mp, "variable instance identifiers exhausted");
12010 type((A))=mp_independent; mp->serial_no=mp->serial_no+s_scale;
12011 value((A))=mp->serial_no;
12015 integer serial_no; /* the most recent serial number, times |s_scale| */
12017 @ @<Make variable |q+s| newly independent@>=new_indep(q+s)
12019 @ But how are dependency lists represented? It's simple: The linear combination
12020 $\alpha_1v_1+\cdots+\alpha_kv_k+\beta$ appears in |k+1| value nodes. If
12021 |q=dep_list(p)| points to this list, and if |k>0|, then |value(q)=
12022 @t$\alpha_1$@>| (which is a |fraction|); |info(q)| points to the location
12023 of $\alpha_1$; and |link(p)| points to the dependency list
12024 $\alpha_2v_2+\cdots+\alpha_kv_k+\beta$. On the other hand if |k=0|,
12025 then |value(q)=@t$\beta$@>| (which is |scaled|) and |info(q)=null|.
12026 The independent variables $v_1$, \dots,~$v_k$ have been sorted so that
12027 they appear in decreasing order of their |value| fields (i.e., of
12028 their serial numbers). \ (It is convenient to use decreasing order,
12029 since |value(null)=0|. If the independent variables were not sorted by
12030 serial number but by some other criterion, such as their location in |mem|,
12031 the equation-solving mechanism would be too system-dependent, because
12032 the ordering can affect the computed results.)
12034 The |link| field in the node that contains the constant term $\beta$ is
12035 called the {\sl final link\/} of the dependency list. \MP\ maintains
12036 a doubly-linked master list of all dependency lists, in terms of a permanently
12038 in |mem| called |dep_head|. If there are no dependencies, we have
12039 |link(dep_head)=dep_head| and |prev_dep(dep_head)=dep_head|;
12040 otherwise |link(dep_head)| points to the first dependent variable, say~|p|,
12041 and |prev_dep(p)=dep_head|. We have |type(p)=mp_dependent|, and |dep_list(p)|
12042 points to its dependency list. If the final link of that dependency list
12043 occurs in location~|q|, then |link(q)| points to the next dependent
12044 variable (say~|r|); and we have |prev_dep(r)=q|, etc.
12046 @d dep_list(A) link(value_loc((A)))
12047 /* half of the |value| field in a |dependent| variable */
12048 @d prev_dep(A) info(value_loc((A)))
12049 /* the other half; makes a doubly linked list */
12050 @d dep_node_size 2 /* the number of words per dependency node */
12052 @<Initialize table entries...@>= mp->serial_no=0;
12053 link(dep_head)=dep_head; prev_dep(dep_head)=dep_head;
12054 info(dep_head)=null; dep_list(dep_head)=null;
12056 @ Actually the description above contains a little white lie. There's
12057 another kind of variable called |mp_proto_dependent|, which is
12058 just like a |dependent| one except that the $\alpha$ coefficients
12059 in its dependency list are |scaled| instead of being fractions.
12060 Proto-dependency lists are mixed with dependency lists in the
12061 nodes reachable from |dep_head|.
12063 @ Here is a procedure that prints a dependency list in symbolic form.
12064 The second parameter should be either |dependent| or |mp_proto_dependent|,
12065 to indicate the scaling of the coefficients.
12067 @<Declare subroutines for printing expressions@>=
12068 void mp_print_dependency (MP mp,pointer p, small_number t) {
12069 integer v; /* a coefficient */
12070 pointer pp,q; /* for list manipulation */
12073 v=abs(value(p)); q=info(p);
12074 if ( q==null ) { /* the constant term */
12075 if ( (v!=0)||(p==pp) ) {
12076 if ( value(p)>0 ) if ( p!=pp ) mp_print_char(mp, '+');
12077 mp_print_scaled(mp, value(p));
12081 @<Print the coefficient, unless it's $\pm1.0$@>;
12082 if ( type(q)!=mp_independent ) mp_confusion(mp, "dep");
12083 @:this can't happen dep}{\quad dep@>
12084 mp_print_variable_name(mp, q); v=value(q) % s_scale;
12085 while ( v>0 ) { mp_print(mp, "*4"); v=v-2; }
12090 @ @<Print the coefficient, unless it's $\pm1.0$@>=
12091 if ( value(p)<0 ) mp_print_char(mp, '-');
12092 else if ( p!=pp ) mp_print_char(mp, '+');
12093 if ( t==mp_dependent ) v=mp_round_fraction(mp, v);
12094 if ( v!=unity ) mp_print_scaled(mp, v)
12096 @ The maximum absolute value of a coefficient in a given dependency list
12097 is returned by the following simple function.
12099 @c fraction mp_max_coef (MP mp,pointer p) {
12100 fraction x; /* the maximum so far */
12102 while ( info(p)!=null ) {
12103 if ( abs(value(p))>x ) x=abs(value(p));
12109 @ One of the main operations needed on dependency lists is to add a multiple
12110 of one list to the other; we call this |p_plus_fq|, where |p| and~|q| point
12111 to dependency lists and |f| is a fraction.
12113 If the coefficient of any independent variable becomes |coef_bound| or
12114 more, in absolute value, this procedure changes the type of that variable
12115 to `|independent_needing_fix|', and sets the global variable |fix_needed|
12116 to~|true|. The value of $|coef_bound|=\mu$ is chosen so that
12117 $\mu^2+\mu<8$; this means that the numbers we deal with won't
12118 get too large. (Instead of the ``optimum'' $\mu=(\sqrt{33}-1)/2\approx
12119 2.3723$, the safer value 7/3 is taken as the threshold.)
12121 The changes mentioned in the preceding paragraph are actually done only if
12122 the global variable |watch_coefs| is |true|. But it usually is; in fact,
12123 it is |false| only when \MP\ is making a dependency list that will soon
12124 be equated to zero.
12126 Several procedures that act on dependency lists, including |p_plus_fq|,
12127 set the global variable |dep_final| to the final (constant term) node of
12128 the dependency list that they produce.
12130 @d coef_bound 04525252525 /* |fraction| approximation to 7/3 */
12131 @d independent_needing_fix 0
12134 boolean fix_needed; /* does at least one |independent| variable need scaling? */
12135 boolean watch_coefs; /* should we scale coefficients that exceed |coef_bound|? */
12136 pointer dep_final; /* location of the constant term and final link */
12139 mp->fix_needed=false; mp->watch_coefs=true;
12141 @ The |p_plus_fq| procedure has a fourth parameter, |t|, that should be
12142 set to |mp_proto_dependent| if |p| is a proto-dependency list. In this
12143 case |f| will be |scaled|, not a |fraction|. Similarly, the fifth parameter~|tt|
12144 should be |mp_proto_dependent| if |q| is a proto-dependency list.
12146 List |q| is unchanged by the operation; but list |p| is totally destroyed.
12148 The final link of the dependency list or proto-dependency list returned
12149 by |p_plus_fq| is the same as the original final link of~|p|. Indeed, the
12150 constant term of the result will be located in the same |mem| location
12151 as the original constant term of~|p|.
12153 Coefficients of the result are assumed to be zero if they are less than
12154 a certain threshold. This compensates for inevitable rounding errors,
12155 and tends to make more variables `|known|'. The threshold is approximately
12156 $10^{-5}$ in the case of normal dependency lists, $10^{-4}$ for
12157 proto-dependencies.
12159 @d fraction_threshold 2685 /* a |fraction| coefficient less than this is zeroed */
12160 @d half_fraction_threshold 1342 /* half of |fraction_threshold| */
12161 @d scaled_threshold 8 /* a |scaled| coefficient less than this is zeroed */
12162 @d half_scaled_threshold 4 /* half of |scaled_threshold| */
12164 @<Declare basic dependency-list subroutines@>=
12165 pointer mp_p_plus_fq ( MP mp, pointer p, integer f,
12166 pointer q, small_number t, small_number tt) ;
12169 pointer mp_p_plus_fq ( MP mp, pointer p, integer f,
12170 pointer q, small_number t, small_number tt) {
12171 pointer pp,qq; /* |info(p)| and |info(q)|, respectively */
12172 pointer r,s; /* for list manipulation */
12173 integer threshold; /* defines a neighborhood of zero */
12174 integer v; /* temporary register */
12175 if ( t==mp_dependent ) threshold=fraction_threshold;
12176 else threshold=scaled_threshold;
12177 r=temp_head; pp=info(p); qq=info(q);
12183 @<Contribute a term from |p|, plus |f| times the
12184 corresponding term from |q|@>
12186 } else if ( value(pp)<value(qq) ) {
12187 @<Contribute a term from |q|, multiplied by~|f|@>
12189 link(r)=p; r=p; p=link(p); pp=info(p);
12192 if ( t==mp_dependent )
12193 value(p)=mp_slow_add(mp, value(p),mp_take_fraction(mp, value(q),f));
12195 value(p)=mp_slow_add(mp, value(p),mp_take_scaled(mp, value(q),f));
12196 link(r)=p; mp->dep_final=p;
12197 return link(temp_head);
12200 @ @<Contribute a term from |p|, plus |f|...@>=
12202 if ( tt==mp_dependent ) v=value(p)+mp_take_fraction(mp, f,value(q));
12203 else v=value(p)+mp_take_scaled(mp, f,value(q));
12204 value(p)=v; s=p; p=link(p);
12205 if ( abs(v)<threshold ) {
12206 mp_free_node(mp, s,dep_node_size);
12208 if ( (abs(v)>=coef_bound) && mp->watch_coefs ) {
12209 type(qq)=independent_needing_fix; mp->fix_needed=true;
12213 pp=info(p); q=link(q); qq=info(q);
12216 @ @<Contribute a term from |q|, multiplied by~|f|@>=
12218 if ( tt==mp_dependent ) v=mp_take_fraction(mp, f,value(q));
12219 else v=mp_take_scaled(mp, f,value(q));
12220 if ( abs(v)>halfp(threshold) ) {
12221 s=mp_get_node(mp, dep_node_size); info(s)=qq; value(s)=v;
12222 if ( (abs(v)>=coef_bound) && mp->watch_coefs ) {
12223 type(qq)=independent_needing_fix; mp->fix_needed=true;
12227 q=link(q); qq=info(q);
12230 @ It is convenient to have another subroutine for the special case
12231 of |p_plus_fq| when |f=1.0|. In this routine lists |p| and |q| are
12232 both of the same type~|t| (either |dependent| or |mp_proto_dependent|).
12234 @c pointer mp_p_plus_q (MP mp,pointer p, pointer q, small_number t) {
12235 pointer pp,qq; /* |info(p)| and |info(q)|, respectively */
12236 pointer r,s; /* for list manipulation */
12237 integer threshold; /* defines a neighborhood of zero */
12238 integer v; /* temporary register */
12239 if ( t==mp_dependent ) threshold=fraction_threshold;
12240 else threshold=scaled_threshold;
12241 r=temp_head; pp=info(p); qq=info(q);
12247 @<Contribute a term from |p|, plus the
12248 corresponding term from |q|@>
12251 if ( value(pp)<value(qq) ) {
12252 s=mp_get_node(mp, dep_node_size); info(s)=qq; value(s)=value(q);
12253 q=link(q); qq=info(q); link(r)=s; r=s;
12255 link(r)=p; r=p; p=link(p); pp=info(p);
12259 value(p)=mp_slow_add(mp, value(p),value(q));
12260 link(r)=p; mp->dep_final=p;
12261 return link(temp_head);
12264 @ @<Contribute a term from |p|, plus the...@>=
12266 v=value(p)+value(q);
12267 value(p)=v; s=p; p=link(p); pp=info(p);
12268 if ( abs(v)<threshold ) {
12269 mp_free_node(mp, s,dep_node_size);
12271 if ( (abs(v)>=coef_bound ) && mp->watch_coefs ) {
12272 type(qq)=independent_needing_fix; mp->fix_needed=true;
12276 q=link(q); qq=info(q);
12279 @ A somewhat simpler routine will multiply a dependency list
12280 by a given constant~|v|. The constant is either a |fraction| less than
12281 |fraction_one|, or it is |scaled|. In the latter case we might be forced to
12282 convert a dependency list to a proto-dependency list.
12283 Parameters |t0| and |t1| are the list types before and after;
12284 they should agree unless |t0=mp_dependent| and |t1=mp_proto_dependent|
12285 and |v_is_scaled=true|.
12287 @c pointer mp_p_times_v (MP mp,pointer p, integer v, small_number t0,
12288 small_number t1, boolean v_is_scaled) {
12289 pointer r,s; /* for list manipulation */
12290 integer w; /* tentative coefficient */
12292 boolean scaling_down;
12293 if ( t0!=t1 ) scaling_down=true; else scaling_down=(!v_is_scaled);
12294 if ( t1==mp_dependent ) threshold=half_fraction_threshold;
12295 else threshold=half_scaled_threshold;
12297 while ( info(p)!=null ) {
12298 if ( scaling_down ) w=mp_take_fraction(mp, v,value(p));
12299 else w=mp_take_scaled(mp, v,value(p));
12300 if ( abs(w)<=threshold ) {
12301 s=link(p); mp_free_node(mp, p,dep_node_size); p=s;
12303 if ( abs(w)>=coef_bound ) {
12304 mp->fix_needed=true; type(info(p))=independent_needing_fix;
12306 link(r)=p; r=p; value(p)=w; p=link(p);
12310 if ( v_is_scaled ) value(p)=mp_take_scaled(mp, value(p),v);
12311 else value(p)=mp_take_fraction(mp, value(p),v);
12312 return link(temp_head);
12315 @ Similarly, we sometimes need to divide a dependency list
12316 by a given |scaled| constant.
12318 @<Declare basic dependency-list subroutines@>=
12319 pointer mp_p_over_v (MP mp,pointer p, scaled v, small_number
12320 t0, small_number t1) ;
12323 pointer mp_p_over_v (MP mp,pointer p, scaled v, small_number
12324 t0, small_number t1) {
12325 pointer r,s; /* for list manipulation */
12326 integer w; /* tentative coefficient */
12328 boolean scaling_down;
12329 if ( t0!=t1 ) scaling_down=true; else scaling_down=false;
12330 if ( t1==mp_dependent ) threshold=half_fraction_threshold;
12331 else threshold=half_scaled_threshold;
12333 while ( info( p)!=null ) {
12334 if ( scaling_down ) {
12335 if ( abs(v)<02000000 ) w=mp_make_scaled(mp, value(p),v*010000);
12336 else w=mp_make_scaled(mp, mp_round_fraction(mp, value(p)),v);
12338 w=mp_make_scaled(mp, value(p),v);
12340 if ( abs(w)<=threshold ) {
12341 s=link(p); mp_free_node(mp, p,dep_node_size); p=s;
12343 if ( abs(w)>=coef_bound ) {
12344 mp->fix_needed=true; type(info(p))=independent_needing_fix;
12346 link(r)=p; r=p; value(p)=w; p=link(p);
12349 link(r)=p; value(p)=mp_make_scaled(mp, value(p),v);
12350 return link(temp_head);
12353 @ Here's another utility routine for dependency lists. When an independent
12354 variable becomes dependent, we want to remove it from all existing
12355 dependencies. The |p_with_x_becoming_q| function computes the
12356 dependency list of~|p| after variable~|x| has been replaced by~|q|.
12358 This procedure has basically the same calling conventions as |p_plus_fq|:
12359 List~|q| is unchanged; list~|p| is destroyed; the constant node and the
12360 final link are inherited from~|p|; and the fourth parameter tells whether
12361 or not |p| is |mp_proto_dependent|. However, the global variable |dep_final|
12362 is not altered if |x| does not occur in list~|p|.
12364 @c pointer mp_p_with_x_becoming_q (MP mp,pointer p,
12365 pointer x, pointer q, small_number t) {
12366 pointer r,s; /* for list manipulation */
12367 integer v; /* coefficient of |x| */
12368 integer sx; /* serial number of |x| */
12369 s=p; r=temp_head; sx=value(x);
12370 while ( value(info(s))>sx ) { r=s; s=link(s); };
12371 if ( info(s)!=x ) {
12374 link(temp_head)=p; link(r)=link(s); v=value(s);
12375 mp_free_node(mp, s,dep_node_size);
12376 return mp_p_plus_fq(mp, link(temp_head),v,q,t,mp_dependent);
12380 @ Here's a simple procedure that reports an error when a variable
12381 has just received a known value that's out of the required range.
12383 @<Declare basic dependency-list subroutines@>=
12384 void mp_val_too_big (MP mp,scaled x) ;
12386 @ @c void mp_val_too_big (MP mp,scaled x) {
12387 if ( mp->internal[mp_warning_check]>0 ) {
12388 print_err("Value is too large ("); mp_print_scaled(mp, x); mp_print_char(mp, ')');
12389 @.Value is too large@>
12390 help4("The equation I just processed has given some variable")
12391 ("a value of 4096 or more. Continue and I'll try to cope")
12392 ("with that big value; but it might be dangerous.")
12393 ("(Set warningcheck:=0 to suppress this message.)");
12398 @ When a dependent variable becomes known, the following routine
12399 removes its dependency list. Here |p| points to the variable, and
12400 |q| points to the dependency list (which is one node long).
12402 @<Declare basic dependency-list subroutines@>=
12403 void mp_make_known (MP mp,pointer p, pointer q) ;
12405 @ @c void mp_make_known (MP mp,pointer p, pointer q) {
12406 int t; /* the previous type */
12407 prev_dep(link(q))=prev_dep(p);
12408 link(prev_dep(p))=link(q); t=type(p);
12409 type(p)=mp_known; value(p)=value(q); mp_free_node(mp, q,dep_node_size);
12410 if ( abs(value(p))>=fraction_one ) mp_val_too_big(mp, value(p));
12411 if (( mp->internal[mp_tracing_equations]>0) && mp_interesting(mp, p) ) {
12412 mp_begin_diagnostic(mp); mp_print_nl(mp, "#### ");
12413 @:]]]\#\#\#\#_}{\.{\#\#\#\#}@>
12414 mp_print_variable_name(mp, p);
12415 mp_print_char(mp, '='); mp_print_scaled(mp, value(p));
12416 mp_end_diagnostic(mp, false);
12418 if (( mp->cur_exp==p ) && mp->cur_type==t ) {
12419 mp->cur_type=mp_known; mp->cur_exp=value(p);
12420 mp_free_node(mp, p,value_node_size);
12424 @ The |fix_dependencies| routine is called into action when |fix_needed|
12425 has been triggered. The program keeps a list~|s| of independent variables
12426 whose coefficients must be divided by~4.
12428 In unusual cases, this fixup process might reduce one or more coefficients
12429 to zero, so that a variable will become known more or less by default.
12431 @<Declare basic dependency-list subroutines@>=
12432 void mp_fix_dependencies (MP mp);
12434 @ @c void mp_fix_dependencies (MP mp) {
12435 pointer p,q,r,s,t; /* list manipulation registers */
12436 pointer x; /* an independent variable */
12437 r=link(dep_head); s=null;
12438 while ( r!=dep_head ){
12440 @<Run through the dependency list for variable |t|, fixing
12441 all nodes, and ending with final link~|q|@>;
12443 if ( q==dep_list(t) ) mp_make_known(mp, t,q);
12445 while ( s!=null ) {
12446 p=link(s); x=info(s); free_avail(s); s=p;
12447 type(x)=mp_independent; value(x)=value(x)+2;
12449 mp->fix_needed=false;
12452 @ @d independent_being_fixed 1 /* this variable already appears in |s| */
12454 @<Run through the dependency list for variable |t|...@>=
12455 r=value_loc(t); /* |link(r)=dep_list(t)| */
12457 q=link(r); x=info(q);
12458 if ( x==null ) break;
12459 if ( type(x)<=independent_being_fixed ) {
12460 if ( type(x)<independent_being_fixed ) {
12461 p=mp_get_avail(mp); link(p)=s; s=p;
12462 info(s)=x; type(x)=independent_being_fixed;
12464 value(q)=value(q) / 4;
12465 if ( value(q)==0 ) {
12466 link(r)=link(q); mp_free_node(mp, q,dep_node_size); q=r;
12473 @ The |new_dep| routine installs a dependency list~|p| into the value node~|q|,
12474 linking it into the list of all known dependencies. We assume that
12475 |dep_final| points to the final node of list~|p|.
12477 @c void mp_new_dep (MP mp,pointer q, pointer p) {
12478 pointer r; /* what used to be the first dependency */
12479 dep_list(q)=p; prev_dep(q)=dep_head;
12480 r=link(dep_head); link(mp->dep_final)=r; prev_dep(r)=mp->dep_final;
12484 @ Here is one of the ways a dependency list gets started.
12485 The |const_dependency| routine produces a list that has nothing but
12488 @c pointer mp_const_dependency (MP mp, scaled v) {
12489 mp->dep_final=mp_get_node(mp, dep_node_size);
12490 value(mp->dep_final)=v; info(mp->dep_final)=null;
12491 return mp->dep_final;
12494 @ And here's a more interesting way to start a dependency list from scratch:
12495 The parameter to |single_dependency| is the location of an
12496 independent variable~|x|, and the result is the simple dependency list
12499 In the unlikely event that the given independent variable has been doubled so
12500 often that we can't refer to it with a nonzero coefficient,
12501 |single_dependency| returns the simple list `0'. This case can be
12502 recognized by testing that the returned list pointer is equal to
12505 @c pointer mp_single_dependency (MP mp,pointer p) {
12506 pointer q; /* the new dependency list */
12507 integer m; /* the number of doublings */
12508 m=value(p) % s_scale;
12510 return mp_const_dependency(mp, 0);
12512 q=mp_get_node(mp, dep_node_size);
12513 value(q)=two_to_the(28-m); info(q)=p;
12514 link(q)=mp_const_dependency(mp, 0);
12519 @ We sometimes need to make an exact copy of a dependency list.
12521 @c pointer mp_copy_dep_list (MP mp,pointer p) {
12522 pointer q; /* the new dependency list */
12523 q=mp_get_node(mp, dep_node_size); mp->dep_final=q;
12525 info(mp->dep_final)=info(p); value(mp->dep_final)=value(p);
12526 if ( info(mp->dep_final)==null ) break;
12527 link(mp->dep_final)=mp_get_node(mp, dep_node_size);
12528 mp->dep_final=link(mp->dep_final); p=link(p);
12533 @ But how do variables normally become known? Ah, now we get to the heart of the
12534 equation-solving mechanism. The |linear_eq| procedure is given a |dependent|
12535 or |mp_proto_dependent| list,~|p|, in which at least one independent variable
12536 appears. It equates this list to zero, by choosing an independent variable
12537 with the largest coefficient and making it dependent on the others. The
12538 newly dependent variable is eliminated from all current dependencies,
12539 thereby possibly making other dependent variables known.
12541 The given list |p| is, of course, totally destroyed by all this processing.
12543 @c void mp_linear_eq (MP mp, pointer p, small_number t) {
12544 pointer q,r,s; /* for link manipulation */
12545 pointer x; /* the variable that loses its independence */
12546 integer n; /* the number of times |x| had been halved */
12547 integer v; /* the coefficient of |x| in list |p| */
12548 pointer prev_r; /* lags one step behind |r| */
12549 pointer final_node; /* the constant term of the new dependency list */
12550 integer w; /* a tentative coefficient */
12551 @<Find a node |q| in list |p| whose coefficient |v| is largest@>;
12552 x=info(q); n=value(x) % s_scale;
12553 @<Divide list |p| by |-v|, removing node |q|@>;
12554 if ( mp->internal[mp_tracing_equations]>0 ) {
12555 @<Display the new dependency@>;
12557 @<Simplify all existing dependencies by substituting for |x|@>;
12558 @<Change variable |x| from |independent| to |dependent| or |known|@>;
12559 if ( mp->fix_needed ) mp_fix_dependencies(mp);
12562 @ @<Find a node |q| in list |p| whose coefficient |v| is largest@>=
12563 q=p; r=link(p); v=value(q);
12564 while ( info(r)!=null ) {
12565 if ( abs(value(r))>abs(v) ) { q=r; v=value(r); };
12569 @ Here we want to change the coefficients from |scaled| to |fraction|,
12570 except in the constant term. In the common case of a trivial equation
12571 like `\.{x=3.14}', we will have |v=-fraction_one|, |q=p|, and |t=mp_dependent|.
12573 @<Divide list |p| by |-v|, removing node |q|@>=
12574 s=temp_head; link(s)=p; r=p;
12577 link(s)=link(r); mp_free_node(mp, r,dep_node_size);
12579 w=mp_make_fraction(mp, value(r),v);
12580 if ( abs(w)<=half_fraction_threshold ) {
12581 link(s)=link(r); mp_free_node(mp, r,dep_node_size);
12587 } while (info(r)!=null);
12588 if ( t==mp_proto_dependent ) {
12589 value(r)=-mp_make_scaled(mp, value(r),v);
12590 } else if ( v!=-fraction_one ) {
12591 value(r)=-mp_make_fraction(mp, value(r),v);
12593 final_node=r; p=link(temp_head)
12595 @ @<Display the new dependency@>=
12596 if ( mp_interesting(mp, x) ) {
12597 mp_begin_diagnostic(mp); mp_print_nl(mp, "## ");
12598 mp_print_variable_name(mp, x);
12599 @:]]]\#\#_}{\.{\#\#}@>
12601 while ( w>0 ) { mp_print(mp, "*4"); w=w-2; };
12602 mp_print_char(mp, '='); mp_print_dependency(mp, p,mp_dependent);
12603 mp_end_diagnostic(mp, false);
12606 @ @<Simplify all existing dependencies by substituting for |x|@>=
12607 prev_r=dep_head; r=link(dep_head);
12608 while ( r!=dep_head ) {
12609 s=dep_list(r); q=mp_p_with_x_becoming_q(mp, s,x,p,type(r));
12610 if ( info(q)==null ) {
12611 mp_make_known(mp, r,q);
12614 do { q=link(q); } while (info(q)!=null);
12620 @ @<Change variable |x| from |independent| to |dependent| or |known|@>=
12621 if ( n>0 ) @<Divide list |p| by $2^n$@>;
12622 if ( info(p)==null ) {
12625 if ( abs(value(x))>=fraction_one ) mp_val_too_big(mp, value(x));
12626 mp_free_node(mp, p,dep_node_size);
12627 if ( mp->cur_exp==x ) if ( mp->cur_type==mp_independent ) {
12628 mp->cur_exp=value(x); mp->cur_type=mp_known;
12629 mp_free_node(mp, x,value_node_size);
12632 type(x)=mp_dependent; mp->dep_final=final_node; mp_new_dep(mp, x,p);
12633 if ( mp->cur_exp==x ) if ( mp->cur_type==mp_independent ) mp->cur_type=mp_dependent;
12636 @ @<Divide list |p| by $2^n$@>=
12638 s=temp_head; link(temp_head)=p; r=p;
12641 else w=value(r) / two_to_the(n);
12642 if ( (abs(w)<=half_fraction_threshold)&&(info(r)!=null) ) {
12644 mp_free_node(mp, r,dep_node_size);
12649 } while (info(s)!=null);
12653 @ The |check_mem| procedure, which is used only when \MP\ is being
12654 debugged, makes sure that the current dependency lists are well formed.
12656 @<Check the list of linear dependencies@>=
12657 q=dep_head; p=link(q);
12658 while ( p!=dep_head ) {
12659 if ( prev_dep(p)!=q ) {
12660 mp_print_nl(mp, "Bad PREVDEP at "); mp_print_int(mp, p);
12665 r=info(p); q=p; p=link(q);
12666 if ( r==null ) break;
12667 if ( value(info(p))>=value(r) ) {
12668 mp_print_nl(mp, "Out of order at "); mp_print_int(mp, p);
12669 @.Out of order...@>
12674 @* \[25] Dynamic nonlinear equations.
12675 Variables of numeric type are maintained by the general scheme of
12676 independent, dependent, and known values that we have just studied;
12677 and the components of pair and transform variables are handled in the
12678 same way. But \MP\ also has five other types of values: \&{boolean},
12679 \&{string}, \&{pen}, \&{path}, and \&{picture}; what about them?
12681 Equations are allowed between nonlinear quantities, but only in a
12682 simple form. Two variables that haven't yet been assigned values are
12683 either equal to each other, or they're not.
12685 Before a boolean variable has received a value, its type is |mp_unknown_boolean|;
12686 similarly, there are variables whose type is |mp_unknown_string|, |mp_unknown_pen|,
12687 |mp_unknown_path|, and |mp_unknown_picture|. In such cases the value is either
12688 |null| (which means that no other variables are equivalent to this one), or
12689 it points to another variable of the same undefined type. The pointers in the
12690 latter case form a cycle of nodes, which we shall call a ``ring.''
12691 Rings of undefined variables may include capsules, which arise as
12692 intermediate results within expressions or as \&{expr} parameters to macros.
12694 When one member of a ring receives a value, the same value is given to
12695 all the other members. In the case of paths and pictures, this implies
12696 making separate copies of a potentially large data structure; users should
12697 restrain their enthusiasm for such generality, unless they have lots and
12698 lots of memory space.
12700 @ The following procedure is called when a capsule node is being
12701 added to a ring (e.g., when an unknown variable is mentioned in an expression).
12703 @c pointer mp_new_ring_entry (MP mp,pointer p) {
12704 pointer q; /* the new capsule node */
12705 q=mp_get_node(mp, value_node_size); name_type(q)=mp_capsule;
12707 if ( value(p)==null ) value(q)=p; else value(q)=value(p);
12712 @ Conversely, we might delete a capsule or a variable before it becomes known.
12713 The following procedure simply detaches a quantity from its ring,
12714 without recycling the storage.
12716 @<Declare the recycling subroutines@>=
12717 void mp_ring_delete (MP mp,pointer p) {
12720 if ( q!=null ) if ( q!=p ){
12721 while ( value(q)!=p ) q=value(q);
12726 @ Eventually there might be an equation that assigns values to all of the
12727 variables in a ring. The |nonlinear_eq| subroutine does the necessary
12728 propagation of values.
12730 If the parameter |flush_p| is |true|, node |p| itself needn't receive a
12731 value, it will soon be recycled.
12733 @c void mp_nonlinear_eq (MP mp,integer v, pointer p, boolean flush_p) {
12734 small_number t; /* the type of ring |p| */
12735 pointer q,r; /* link manipulation registers */
12736 t=type(p)-unknown_tag; q=value(p);
12737 if ( flush_p ) type(p)=mp_vacuous; else p=q;
12739 r=value(q); type(q)=t;
12741 case mp_boolean_type: value(q)=v; break;
12742 case mp_string_type: value(q)=v; add_str_ref(v); break;
12743 case mp_pen_type: value(q)=copy_pen(v); break;
12744 case mp_path_type: value(q)=mp_copy_path(mp, v); break;
12745 case mp_picture_type: value(q)=v; add_edge_ref(v); break;
12746 } /* there ain't no more cases */
12751 @ If two members of rings are equated, and if they have the same type,
12752 the |ring_merge| procedure is called on to make them equivalent.
12754 @c void mp_ring_merge (MP mp,pointer p, pointer q) {
12755 pointer r; /* traverses one list */
12759 @<Exclaim about a redundant equation@>;
12764 r=value(p); value(p)=value(q); value(q)=r;
12767 @ @<Exclaim about a redundant equation@>=
12769 print_err("Redundant equation");
12770 @.Redundant equation@>
12771 help2("I already knew that this equation was true.")
12772 ("But perhaps no harm has been done; let's continue.");
12773 mp_put_get_error(mp);
12776 @* \[26] Introduction to the syntactic routines.
12777 Let's pause a moment now and try to look at the Big Picture.
12778 The \MP\ program consists of three main parts: syntactic routines,
12779 semantic routines, and output routines. The chief purpose of the
12780 syntactic routines is to deliver the user's input to the semantic routines,
12781 while parsing expressions and locating operators and operands. The
12782 semantic routines act as an interpreter responding to these operators,
12783 which may be regarded as commands. And the output routines are
12784 periodically called on to produce compact font descriptions that can be
12785 used for typesetting or for making interim proof drawings. We have
12786 discussed the basic data structures and many of the details of semantic
12787 operations, so we are good and ready to plunge into the part of \MP\ that
12788 actually controls the activities.
12790 Our current goal is to come to grips with the |get_next| procedure,
12791 which is the keystone of \MP's input mechanism. Each call of |get_next|
12792 sets the value of three variables |cur_cmd|, |cur_mod|, and |cur_sym|,
12793 representing the next input token.
12794 $$\vbox{\halign{#\hfil\cr
12795 \hbox{|cur_cmd| denotes a command code from the long list of codes
12797 \hbox{|cur_mod| denotes a modifier of the command code;}\cr
12798 \hbox{|cur_sym| is the hash address of the symbolic token that was
12800 \hbox{\qquad or zero in the case of a numeric or string
12801 or capsule token.}\cr}}$$
12802 Underlying this external behavior of |get_next| is all the machinery
12803 necessary to convert from character files to tokens. At a given time we
12804 may be only partially finished with the reading of several files (for
12805 which \&{input} was specified), and partially finished with the expansion
12806 of some user-defined macros and/or some macro parameters, and partially
12807 finished reading some text that the user has inserted online,
12808 and so on. When reading a character file, the characters must be
12809 converted to tokens; comments and blank spaces must
12810 be removed, numeric and string tokens must be evaluated.
12812 To handle these situations, which might all be present simultaneously,
12813 \MP\ uses various stacks that hold information about the incomplete
12814 activities, and there is a finite state control for each level of the
12815 input mechanism. These stacks record the current state of an implicitly
12816 recursive process, but the |get_next| procedure is not recursive.
12819 eight_bits cur_cmd; /* current command set by |get_next| */
12820 integer cur_mod; /* operand of current command */
12821 halfword cur_sym; /* hash address of current symbol */
12823 @ The |print_cmd_mod| routine prints a symbolic interpretation of a
12824 command code and its modifier.
12825 It consists of a rather tedious sequence of print
12826 commands, and most of it is essentially an inverse to the |primitive|
12827 routine that enters a \MP\ primitive into |hash| and |eqtb|. Therefore almost
12828 all of this procedure appears elsewhere in the program, together with the
12829 corresponding |primitive| calls.
12831 @<Declare the procedure called |print_cmd_mod|@>=
12832 void mp_print_cmd_mod (MP mp,integer c, integer m) {
12834 @<Cases of |print_cmd_mod| for symbolic printing of primitives@>
12835 default: mp_print(mp, "[unknown command code!]"); break;
12839 @ Here is a procedure that displays a given command in braces, in the
12840 user's transcript file.
12842 @d show_cur_cmd_mod mp_show_cmd_mod(mp, mp->cur_cmd,mp->cur_mod)
12845 void mp_show_cmd_mod (MP mp,integer c, integer m) {
12846 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
12847 mp_print_cmd_mod(mp, c,m); mp_print_char(mp, '}');
12848 mp_end_diagnostic(mp, false);
12851 @* \[27] Input stacks and states.
12852 The state of \MP's input mechanism appears in the input stack, whose
12853 entries are records with five fields, called |index|, |start|, |loc|,
12854 |limit|, and |name|. The top element of this stack is maintained in a
12855 global variable for which no subscripting needs to be done; the other
12856 elements of the stack appear in an array. Hence the stack is declared thus:
12860 quarterword index_field;
12861 halfword start_field, loc_field, limit_field, name_field;
12865 in_state_record *input_stack;
12866 integer input_ptr; /* first unused location of |input_stack| */
12867 integer max_in_stack; /* largest value of |input_ptr| when pushing */
12868 in_state_record cur_input; /* the ``top'' input state */
12869 int stack_size; /* maximum number of simultaneous input sources */
12871 @ @<Allocate or initialize ...@>=
12872 mp->stack_size = 300;
12873 mp->input_stack = xmalloc((mp->stack_size+1),sizeof(in_state_record));
12875 @ @<Dealloc variables@>=
12876 xfree(mp->input_stack);
12878 @ We've already defined the special variable |loc==cur_input.loc_field|
12879 in our discussion of basic input-output routines. The other components of
12880 |cur_input| are defined in the same way:
12882 @d index mp->cur_input.index_field /* reference for buffer information */
12883 @d start mp->cur_input.start_field /* starting position in |buffer| */
12884 @d limit mp->cur_input.limit_field /* end of current line in |buffer| */
12885 @d name mp->cur_input.name_field /* name of the current file */
12887 @ Let's look more closely now at the five control variables
12888 (|index|,~|start|,~|loc|,~|limit|,~|name|),
12889 assuming that \MP\ is reading a line of characters that have been input
12890 from some file or from the user's terminal. There is an array called
12891 |buffer| that acts as a stack of all lines of characters that are
12892 currently being read from files, including all lines on subsidiary
12893 levels of the input stack that are not yet completed. \MP\ will return to
12894 the other lines when it is finished with the present input file.
12896 (Incidentally, on a machine with byte-oriented addressing, it would be
12897 appropriate to combine |buffer| with the |str_pool| array,
12898 letting the buffer entries grow downward from the top of the string pool
12899 and checking that these two tables don't bump into each other.)
12901 The line we are currently working on begins in position |start| of the
12902 buffer; the next character we are about to read is |buffer[loc]|; and
12903 |limit| is the location of the last character present. We always have
12904 |loc<=limit|. For convenience, |buffer[limit]| has been set to |"%"|, so
12905 that the end of a line is easily sensed.
12907 The |name| variable is a string number that designates the name of
12908 the current file, if we are reading an ordinary text file. Special codes
12909 |is_term..max_spec_src| indicate other sources of input text.
12911 @d is_term 0 /* |name| value when reading from the terminal for normal input */
12912 @d is_read 1 /* |name| value when executing a \&{readstring} or \&{readfrom} */
12913 @d is_scantok 2 /* |name| value when reading text generated by \&{scantokens} */
12914 @d max_spec_src is_scantok
12916 @ Additional information about the current line is available via the
12917 |index| variable, which counts how many lines of characters are present
12918 in the buffer below the current level. We have |index=0| when reading
12919 from the terminal and prompting the user for each line; then if the user types,
12920 e.g., `\.{input figs}', we will have |index=1| while reading
12921 the file \.{figs.mp}. However, it does not follow that |index| is the
12922 same as the input stack pointer, since many of the levels on the input
12923 stack may come from token lists and some |index| values may correspond
12924 to \.{MPX} files that are not currently on the stack.
12926 The global variable |in_open| is equal to the highest |index| value counting
12927 \.{MPX} files but excluding token-list input levels. Thus, the number of
12928 partially read lines in the buffer is |in_open+1| and we have |in_open>=index|
12929 when we are not reading a token list.
12931 If we are not currently reading from the terminal,
12932 we are reading from the file variable |input_file[index]|. We use
12933 the notation |terminal_input| as a convenient abbreviation for |name=is_term|,
12934 and |cur_file| as an abbreviation for |input_file[index]|.
12936 When \MP\ is not reading from the terminal, the global variable |line| contains
12937 the line number in the current file, for use in error messages. More precisely,
12938 |line| is a macro for |line_stack[index]| and the |line_stack| array gives
12939 the line number for each file in the |input_file| array.
12941 When an \.{MPX} file is opened the file name is stored in the |mpx_name|
12942 array so that the name doesn't get lost when the file is temporarily removed
12943 from the input stack.
12944 Thus when |input_file[k]| is an \.{MPX} file, its name is |mpx_name[k]|
12945 and it contains translated \TeX\ pictures for |input_file[k-1]|.
12946 Since this is not an \.{MPX} file, we have
12947 $$ \hbox{|mpx_name[k-1]<=absent|}. $$
12948 This |name| field is set to |finished| when |input_file[k]| is completely
12951 If more information about the input state is needed, it can be
12952 included in small arrays like those shown here. For example,
12953 the current page or segment number in the input file might be put
12954 into a variable |page|, that is really a macro for the current entry
12955 in `\ignorespaces|page_stack:array[0..max_in_open] of integer|\unskip'
12956 by analogy with |line_stack|.
12957 @^system dependencies@>
12959 @d terminal_input (name==is_term) /* are we reading from the terminal? */
12960 @d cur_file mp->input_file[index] /* the current |void *| variable */
12961 @d line mp->line_stack[index] /* current line number in the current source file */
12962 @d in_name mp->iname_stack[index] /* a string used to construct \.{MPX} file names */
12963 @d in_area mp->iarea_stack[index] /* another string for naming \.{MPX} files */
12964 @d absent 1 /* |name_field| value for unused |mpx_in_stack| entries */
12965 @d mpx_reading (mp->mpx_name[index]>absent)
12966 /* when reading a file, is it an \.{MPX} file? */
12968 /* |name_field| value when the corresponding \.{MPX} file is finished */
12971 integer in_open; /* the number of lines in the buffer, less one */
12972 unsigned int open_parens; /* the number of open text files */
12973 void * *input_file ;
12974 integer *line_stack ; /* the line number for each file */
12975 char * *iname_stack; /* used for naming \.{MPX} files */
12976 char * *iarea_stack; /* used for naming \.{MPX} files */
12977 halfword*mpx_name ;
12979 @ @<Allocate or ...@>=
12980 mp->input_file = xmalloc((mp->max_in_open+1),sizeof(void *));
12981 mp->line_stack = xmalloc((mp->max_in_open+1),sizeof(integer));
12982 mp->iname_stack = xmalloc((mp->max_in_open+1),sizeof(char *));
12983 mp->iarea_stack = xmalloc((mp->max_in_open+1),sizeof(char *));
12984 mp->mpx_name = xmalloc((mp->max_in_open+1),sizeof(halfword));
12987 for (k=0;k<=mp->max_in_open;k++) {
12988 mp->iname_stack[k] =NULL;
12989 mp->iarea_stack[k] =NULL;
12993 @ @<Dealloc variables@>=
12996 for (l=0;l<=mp->max_in_open;l++) {
12997 xfree(mp->iname_stack[l]);
12998 xfree(mp->iarea_stack[l]);
13001 xfree(mp->input_file);
13002 xfree(mp->line_stack);
13003 xfree(mp->iname_stack);
13004 xfree(mp->iarea_stack);
13005 xfree(mp->mpx_name);
13008 @ However, all this discussion about input state really applies only to the
13009 case that we are inputting from a file. There is another important case,
13010 namely when we are currently getting input from a token list. In this case
13011 |index>max_in_open|, and the conventions about the other state variables
13014 \yskip\hang|loc| is a pointer to the current node in the token list, i.e.,
13015 the node that will be read next. If |loc=null|, the token list has been
13018 \yskip\hang|start| points to the first node of the token list; this node
13019 may or may not contain a reference count, depending on the type of token
13022 \yskip\hang|token_type|, which takes the place of |index| in the
13023 discussion above, is a code number that explains what kind of token list
13026 \yskip\hang|name| points to the |eqtb| address of the control sequence
13027 being expanded, if the current token list is a macro not defined by
13028 \&{vardef}. Macros defined by \&{vardef} have |name=null|; their name
13029 can be deduced by looking at their first two parameters.
13031 \yskip\hang|param_start|, which takes the place of |limit|, tells where
13032 the parameters of the current macro or loop text begin in the |param_stack|.
13034 \yskip\noindent The |token_type| can take several values, depending on
13035 where the current token list came from:
13038 \indent|forever_text|, if the token list being scanned is the body of
13039 a \&{forever} loop;
13041 \indent|loop_text|, if the token list being scanned is the body of
13042 a \&{for} or \&{forsuffixes} loop;
13044 \indent|parameter|, if a \&{text} or \&{suffix} parameter is being scanned;
13046 \indent|backed_up|, if the token list being scanned has been inserted as
13047 `to be read again'.
13049 \indent|inserted|, if the token list being scanned has been inserted as
13050 part of error recovery;
13052 \indent|macro|, if the expansion of a user-defined symbolic token is being
13056 The token list begins with a reference count if and only if |token_type=
13058 @^reference counts@>
13060 @d token_type index /* type of current token list */
13061 @d token_state (index>(int)mp->max_in_open) /* are we scanning a token list? */
13062 @d file_state (index<=(int)mp->max_in_open) /* are we scanning a file line? */
13063 @d param_start limit /* base of macro parameters in |param_stack| */
13064 @d forever_text (mp->max_in_open+1) /* |token_type| code for loop texts */
13065 @d loop_text (mp->max_in_open+2) /* |token_type| code for loop texts */
13066 @d parameter (mp->max_in_open+3) /* |token_type| code for parameter texts */
13067 @d backed_up (mp->max_in_open+4) /* |token_type| code for texts to be reread */
13068 @d inserted (mp->max_in_open+5) /* |token_type| code for inserted texts */
13069 @d macro (mp->max_in_open+6) /* |token_type| code for macro replacement texts */
13071 @ The |param_stack| is an auxiliary array used to hold pointers to the token
13072 lists for parameters at the current level and subsidiary levels of input.
13073 This stack grows at a different rate from the others.
13076 pointer *param_stack; /* token list pointers for parameters */
13077 integer param_ptr; /* first unused entry in |param_stack| */
13078 integer max_param_stack; /* largest value of |param_ptr| */
13080 @ @<Allocate or initialize ...@>=
13081 mp->param_stack = xmalloc((mp->param_size+1),sizeof(pointer));
13083 @ @<Dealloc variables@>=
13084 xfree(mp->param_stack);
13086 @ Notice that the |line| isn't valid when |token_state| is true because it
13087 depends on |index|. If we really need to know the line number for the
13088 topmost file in the index stack we use the following function. If a page
13089 number or other information is needed, this routine should be modified to
13090 compute it as well.
13091 @^system dependencies@>
13093 @<Declare a function called |true_line|@>=
13094 integer mp_true_line (MP mp) {
13095 int k; /* an index into the input stack */
13096 if ( file_state && (name>max_spec_src) ) {
13101 ((mp->input_stack[(k-1)].index_field>mp->max_in_open)||
13102 (mp->input_stack[(k-1)].name_field<=max_spec_src))) {
13105 return (k>0 ? mp->line_stack[(k-1)] : 0 );
13109 @ Thus, the ``current input state'' can be very complicated indeed; there
13110 can be many levels and each level can arise in a variety of ways. The
13111 |show_context| procedure, which is used by \MP's error-reporting routine to
13112 print out the current input state on all levels down to the most recent
13113 line of characters from an input file, illustrates most of these conventions.
13114 The global variable |file_ptr| contains the lowest level that was
13115 displayed by this procedure.
13118 integer file_ptr; /* shallowest level shown by |show_context| */
13120 @ The status at each level is indicated by printing two lines, where the first
13121 line indicates what was read so far and the second line shows what remains
13122 to be read. The context is cropped, if necessary, so that the first line
13123 contains at most |half_error_line| characters, and the second contains
13124 at most |error_line|. Non-current input levels whose |token_type| is
13125 `|backed_up|' are shown only if they have not been fully read.
13127 @c void mp_show_context (MP mp) { /* prints where the scanner is */
13128 int old_setting; /* saved |selector| setting */
13129 @<Local variables for formatting calculations@>
13130 mp->file_ptr=mp->input_ptr; mp->input_stack[mp->file_ptr]=mp->cur_input;
13131 /* store current state */
13133 mp->cur_input=mp->input_stack[mp->file_ptr]; /* enter into the context */
13134 @<Display the current context@>;
13136 if ( (name>max_spec_src) || (mp->file_ptr==0) ) break;
13137 decr(mp->file_ptr);
13139 mp->cur_input=mp->input_stack[mp->input_ptr]; /* restore original state */
13142 @ @<Display the current context@>=
13143 if ( (mp->file_ptr==mp->input_ptr) || file_state ||
13144 (token_type!=backed_up) || (loc!=null) ) {
13145 /* we omit backed-up token lists that have already been read */
13146 mp->tally=0; /* get ready to count characters */
13147 old_setting=mp->selector;
13148 if ( file_state ) {
13149 @<Print location of current line@>;
13150 @<Pseudoprint the line@>;
13152 @<Print type of token list@>;
13153 @<Pseudoprint the token list@>;
13155 mp->selector=old_setting; /* stop pseudoprinting */
13156 @<Print two lines using the tricky pseudoprinted information@>;
13159 @ This routine should be changed, if necessary, to give the best possible
13160 indication of where the current line resides in the input file.
13161 For example, on some systems it is best to print both a page and line number.
13162 @^system dependencies@>
13164 @<Print location of current line@>=
13165 if ( name>max_spec_src ) {
13166 mp_print_nl(mp, "l."); mp_print_int(mp, mp_true_line(mp));
13167 } else if ( terminal_input ) {
13168 if ( mp->file_ptr==0 ) mp_print_nl(mp, "<*>");
13169 else mp_print_nl(mp, "<insert>");
13170 } else if ( name==is_scantok ) {
13171 mp_print_nl(mp, "<scantokens>");
13173 mp_print_nl(mp, "<read>");
13175 mp_print_char(mp, ' ')
13177 @ Can't use case statement here because the |token_type| is not
13178 a constant expression.
13180 @<Print type of token list@>=
13182 if(token_type==forever_text) {
13183 mp_print_nl(mp, "<forever> ");
13184 } else if (token_type==loop_text) {
13185 @<Print the current loop value@>;
13186 } else if (token_type==parameter) {
13187 mp_print_nl(mp, "<argument> ");
13188 } else if (token_type==backed_up) {
13189 if ( loc==null ) mp_print_nl(mp, "<recently read> ");
13190 else mp_print_nl(mp, "<to be read again> ");
13191 } else if (token_type==inserted) {
13192 mp_print_nl(mp, "<inserted text> ");
13193 } else if (token_type==macro) {
13195 if ( name!=null ) mp_print_text(name);
13196 else @<Print the name of a \&{vardef}'d macro@>;
13197 mp_print(mp, "->");
13199 mp_print_nl(mp, "?");/* this should never happen */
13204 @ The parameter that corresponds to a loop text is either a token list
13205 (in the case of \&{forsuffixes}) or a ``capsule'' (in the case of \&{for}).
13206 We'll discuss capsules later; for now, all we need to know is that
13207 the |link| field in a capsule parameter is |void| and that
13208 |print_exp(p,0)| displays the value of capsule~|p| in abbreviated form.
13210 @<Print the current loop value@>=
13211 { mp_print_nl(mp, "<for("); p=mp->param_stack[param_start];
13213 if ( link(p)==mp_void ) mp_print_exp(mp, p,0); /* we're in a \&{for} loop */
13214 else mp_show_token_list(mp, p,null,20,mp->tally);
13216 mp_print(mp, ")> ");
13219 @ The first two parameters of a macro defined by \&{vardef} will be token
13220 lists representing the macro's prefix and ``at point.'' By putting these
13221 together, we get the macro's full name.
13223 @<Print the name of a \&{vardef}'d macro@>=
13224 { p=mp->param_stack[param_start];
13226 mp_show_token_list(mp, mp->param_stack[param_start+1],null,20,mp->tally);
13229 while ( link(q)!=null ) q=link(q);
13230 link(q)=mp->param_stack[param_start+1];
13231 mp_show_token_list(mp, p,null,20,mp->tally);
13236 @ Now it is necessary to explain a little trick. We don't want to store a long
13237 string that corresponds to a token list, because that string might take up
13238 lots of memory; and we are printing during a time when an error message is
13239 being given, so we dare not do anything that might overflow one of \MP's
13240 tables. So `pseudoprinting' is the answer: We enter a mode of printing
13241 that stores characters into a buffer of length |error_line|, where character
13242 $k+1$ is placed into \hbox{|trick_buf[k mod error_line]|} if
13243 |k<trick_count|, otherwise character |k| is dropped. Initially we set
13244 |tally:=0| and |trick_count:=1000000|; then when we reach the
13245 point where transition from line 1 to line 2 should occur, we
13246 set |first_count:=tally| and |trick_count:=@tmax@>(error_line,
13247 tally+1+error_line-half_error_line)|. At the end of the
13248 pseudoprinting, the values of |first_count|, |tally|, and
13249 |trick_count| give us all the information we need to print the two lines,
13250 and all of the necessary text is in |trick_buf|.
13252 Namely, let |l| be the length of the descriptive information that appears
13253 on the first line. The length of the context information gathered for that
13254 line is |k=first_count|, and the length of the context information
13255 gathered for line~2 is $m=\min(|tally|, |trick_count|)-k$. If |l+k<=h|,
13256 where |h=half_error_line|, we print |trick_buf[0..k-1]| after the
13257 descriptive information on line~1, and set |n:=l+k|; here |n| is the
13258 length of line~1. If $l+k>h$, some cropping is necessary, so we set |n:=h|
13259 and print `\.{...}' followed by
13260 $$\hbox{|trick_buf[(l+k-h+3)..k-1]|,}$$
13261 where subscripts of |trick_buf| are circular modulo |error_line|. The
13262 second line consists of |n|~spaces followed by |trick_buf[k..(k+m-1)]|,
13263 unless |n+m>error_line|; in the latter case, further cropping is done.
13264 This is easier to program than to explain.
13266 @<Local variables for formatting...@>=
13267 int i; /* index into |buffer| */
13268 integer l; /* length of descriptive information on line 1 */
13269 integer m; /* context information gathered for line 2 */
13270 int n; /* length of line 1 */
13271 integer p; /* starting or ending place in |trick_buf| */
13272 integer q; /* temporary index */
13274 @ The following code tells the print routines to gather
13275 the desired information.
13277 @d begin_pseudoprint {
13278 l=mp->tally; mp->tally=0; mp->selector=pseudo;
13279 mp->trick_count=1000000;
13281 @d set_trick_count {
13282 mp->first_count=mp->tally;
13283 mp->trick_count=mp->tally+1+mp->error_line-mp->half_error_line;
13284 if ( mp->trick_count<mp->error_line ) mp->trick_count=mp->error_line;
13287 @ And the following code uses the information after it has been gathered.
13289 @<Print two lines using the tricky pseudoprinted information@>=
13290 if ( mp->trick_count==1000000 ) set_trick_count;
13291 /* |set_trick_count| must be performed */
13292 if ( mp->tally<mp->trick_count ) m=mp->tally-mp->first_count;
13293 else m=mp->trick_count-mp->first_count; /* context on line 2 */
13294 if ( l+mp->first_count<=mp->half_error_line ) {
13295 p=0; n=l+mp->first_count;
13297 mp_print(mp, "..."); p=l+mp->first_count-mp->half_error_line+3;
13298 n=mp->half_error_line;
13300 for (q=p;q<=mp->first_count-1;q++) {
13301 mp_print_char(mp, mp->trick_buf[q % mp->error_line]);
13304 for (q=1;q<=n;q++) {
13305 mp_print_char(mp, ' '); /* print |n| spaces to begin line~2 */
13307 if ( m+n<=mp->error_line ) p=mp->first_count+m;
13308 else p=mp->first_count+(mp->error_line-n-3);
13309 for (q=mp->first_count;q<=p-1;q++) {
13310 mp_print_char(mp, mp->trick_buf[q % mp->error_line]);
13312 if ( m+n>mp->error_line ) mp_print(mp, "...")
13314 @ But the trick is distracting us from our current goal, which is to
13315 understand the input state. So let's concentrate on the data structures that
13316 are being pseudoprinted as we finish up the |show_context| procedure.
13318 @<Pseudoprint the line@>=
13321 for (i=start;i<=limit-1;i++) {
13322 if ( i==loc ) set_trick_count;
13323 mp_print_str(mp, mp->buffer[i]);
13327 @ @<Pseudoprint the token list@>=
13329 if ( token_type!=macro ) mp_show_token_list(mp, start,loc,100000,0);
13330 else mp_show_macro(mp, start,loc,100000)
13332 @ Here is the missing piece of |show_token_list| that is activated when the
13333 token beginning line~2 is about to be shown:
13335 @<Do magic computation@>=set_trick_count
13337 @* \[28] Maintaining the input stacks.
13338 The following subroutines change the input status in commonly needed ways.
13340 First comes |push_input|, which stores the current state and creates a
13341 new level (having, initially, the same properties as the old).
13343 @d push_input { /* enter a new input level, save the old */
13344 if ( mp->input_ptr>mp->max_in_stack ) {
13345 mp->max_in_stack=mp->input_ptr;
13346 if ( mp->input_ptr==mp->stack_size ) {
13347 int l = (mp->stack_size+(mp->stack_size>>2));
13348 XREALLOC(mp->input_stack, l, in_state_record);
13349 mp->stack_size = l;
13352 mp->input_stack[mp->input_ptr]=mp->cur_input; /* stack the record */
13353 incr(mp->input_ptr);
13356 @ And of course what goes up must come down.
13358 @d pop_input { /* leave an input level, re-enter the old */
13359 decr(mp->input_ptr); mp->cur_input=mp->input_stack[mp->input_ptr];
13362 @ Here is a procedure that starts a new level of token-list input, given
13363 a token list |p| and its type |t|. If |t=macro|, the calling routine should
13364 set |name|, reset~|loc|, and increase the macro's reference count.
13366 @d back_list(A) mp_begin_token_list(mp, (A),backed_up) /* backs up a simple token list */
13368 @c void mp_begin_token_list (MP mp,pointer p, quarterword t) {
13369 push_input; start=p; token_type=t;
13370 param_start=mp->param_ptr; loc=p;
13373 @ When a token list has been fully scanned, the following computations
13374 should be done as we leave that level of input.
13377 @c void mp_end_token_list (MP mp) { /* leave a token-list input level */
13378 pointer p; /* temporary register */
13379 if ( token_type>=backed_up ) { /* token list to be deleted */
13380 if ( token_type<=inserted ) {
13381 mp_flush_token_list(mp, start); goto DONE;
13383 mp_delete_mac_ref(mp, start); /* update reference count */
13386 while ( mp->param_ptr>param_start ) { /* parameters must be flushed */
13387 decr(mp->param_ptr);
13388 p=mp->param_stack[mp->param_ptr];
13390 if ( link(p)==mp_void ) { /* it's an \&{expr} parameter */
13391 mp_recycle_value(mp, p); mp_free_node(mp, p,value_node_size);
13393 mp_flush_token_list(mp, p); /* it's a \&{suffix} or \&{text} parameter */
13398 pop_input; check_interrupt;
13401 @ The contents of |cur_cmd,cur_mod,cur_sym| are placed into an equivalent
13402 token by the |cur_tok| routine.
13405 @c @<Declare the procedure called |make_exp_copy|@>
13406 pointer mp_cur_tok (MP mp) {
13407 pointer p; /* a new token node */
13408 small_number save_type; /* |cur_type| to be restored */
13409 integer save_exp; /* |cur_exp| to be restored */
13410 if ( mp->cur_sym==0 ) {
13411 if ( mp->cur_cmd==capsule_token ) {
13412 save_type=mp->cur_type; save_exp=mp->cur_exp;
13413 mp_make_exp_copy(mp, mp->cur_mod); p=mp_stash_cur_exp(mp); link(p)=null;
13414 mp->cur_type=save_type; mp->cur_exp=save_exp;
13416 p=mp_get_node(mp, token_node_size);
13417 value(p)=mp->cur_mod; name_type(p)=mp_token;
13418 if ( mp->cur_cmd==numeric_token ) type(p)=mp_known;
13419 else type(p)=mp_string_type;
13422 fast_get_avail(p); info(p)=mp->cur_sym;
13427 @ Sometimes \MP\ has read too far and wants to ``unscan'' what it has
13428 seen. The |back_input| procedure takes care of this by putting the token
13429 just scanned back into the input stream, ready to be read again.
13430 If |cur_sym<>0|, the values of |cur_cmd| and |cur_mod| are irrelevant.
13433 void mp_back_input (MP mp);
13435 @ @c void mp_back_input (MP mp) {/* undoes one token of input */
13436 pointer p; /* a token list of length one */
13438 while ( token_state &&(loc==null) )
13439 mp_end_token_list(mp); /* conserve stack space */
13443 @ The |back_error| routine is used when we want to restore or replace an
13444 offending token just before issuing an error message. We disable interrupts
13445 during the call of |back_input| so that the help message won't be lost.
13448 void mp_error (MP mp);
13449 void mp_back_error (MP mp);
13451 @ @c void mp_back_error (MP mp) { /* back up one token and call |error| */
13452 mp->OK_to_interrupt=false;
13454 mp->OK_to_interrupt=true; mp_error(mp);
13456 void mp_ins_error (MP mp) { /* back up one inserted token and call |error| */
13457 mp->OK_to_interrupt=false;
13458 mp_back_input(mp); token_type=inserted;
13459 mp->OK_to_interrupt=true; mp_error(mp);
13462 @ The |begin_file_reading| procedure starts a new level of input for lines
13463 of characters to be read from a file, or as an insertion from the
13464 terminal. It does not take care of opening the file, nor does it set |loc|
13465 or |limit| or |line|.
13466 @^system dependencies@>
13468 @c void mp_begin_file_reading (MP mp) {
13469 if ( mp->in_open==mp->max_in_open )
13470 mp_overflow(mp, "text input levels",mp->max_in_open);
13471 @:MetaPost capacity exceeded text input levels}{\quad text input levels@>
13472 if ( mp->first==mp->buf_size )
13473 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
13474 incr(mp->in_open); push_input; index=mp->in_open;
13475 mp->mpx_name[index]=absent;
13477 name=is_term; /* |terminal_input| is now |true| */
13480 @ Conversely, the variables must be downdated when such a level of input
13481 is finished. Any associated \.{MPX} file must also be closed and popped
13482 off the file stack.
13484 @c void mp_end_file_reading (MP mp) {
13485 if ( mp->in_open>index ) {
13486 if ( (mp->mpx_name[mp->in_open]==absent)||(name<=max_spec_src) ) {
13487 mp_confusion(mp, "endinput");
13488 @:this can't happen endinput}{\quad endinput@>
13490 (mp->close_file)(mp,mp->input_file[mp->in_open]); /* close an \.{MPX} file */
13491 delete_str_ref(mp->mpx_name[mp->in_open]);
13496 if ( index!=mp->in_open ) mp_confusion(mp, "endinput");
13497 if ( name>max_spec_src ) {
13498 (mp->close_file)(mp,cur_file);
13499 delete_str_ref(name);
13503 pop_input; decr(mp->in_open);
13506 @ Here is a function that tries to resume input from an \.{MPX} file already
13507 associated with the current input file. It returns |false| if this doesn't
13510 @c boolean mp_begin_mpx_reading (MP mp) {
13511 if ( mp->in_open!=index+1 ) {
13514 if ( mp->mpx_name[mp->in_open]<=absent ) mp_confusion(mp, "mpx");
13515 @:this can't happen mpx}{\quad mpx@>
13516 if ( mp->first==mp->buf_size )
13517 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
13518 push_input; index=mp->in_open;
13520 name=mp->mpx_name[mp->in_open]; add_str_ref(name);
13521 @<Put an empty line in the input buffer@>;
13526 @ This procedure temporarily stops reading an \.{MPX} file.
13528 @c void mp_end_mpx_reading (MP mp) {
13529 if ( mp->in_open!=index ) mp_confusion(mp, "mpx");
13530 @:this can't happen mpx}{\quad mpx@>
13532 @<Complain that we are not at the end of a line in the \.{MPX} file@>;
13538 @ Here we enforce a restriction that simplifies the input stacks considerably.
13539 This should not inconvenience the user because \.{MPX} files are generated
13540 by an auxiliary program called \.{DVItoMP}.
13542 @ @<Complain that we are not at the end of a line in the \.{MPX} file@>=
13544 print_err("`mpxbreak' must be at the end of a line");
13545 help4("This file contains picture expressions for btex...etex")
13546 ("blocks. Such files are normally generated automatically")
13547 ("but this one seems to be messed up. I'm going to ignore")
13548 ("the rest of this line.");
13552 @ In order to keep the stack from overflowing during a long sequence of
13553 inserted `\.{show}' commands, the following routine removes completed
13554 error-inserted lines from memory.
13556 @c void mp_clear_for_error_prompt (MP mp) {
13557 while ( file_state && terminal_input &&
13558 (mp->input_ptr>0)&&(loc==limit) ) mp_end_file_reading(mp);
13559 mp_print_ln(mp); clear_terminal;
13562 @ To get \MP's whole input mechanism going, we perform the following
13565 @<Initialize the input routines@>=
13566 { mp->input_ptr=0; mp->max_in_stack=0;
13567 mp->in_open=0; mp->open_parens=0; mp->max_buf_stack=0;
13568 mp->param_ptr=0; mp->max_param_stack=0;
13570 start=1; index=0; line=0; name=is_term;
13571 mp->mpx_name[0]=absent;
13572 mp->force_eof=false;
13573 if ( ! mp_init_terminal(mp) ) mp_jump_out(mp);
13574 limit=mp->last; mp->first=mp->last+1;
13575 /* |init_terminal| has set |loc| and |last| */
13578 @* \[29] Getting the next token.
13579 The heart of \MP's input mechanism is the |get_next| procedure, which
13580 we shall develop in the next few sections of the program. Perhaps we
13581 shouldn't actually call it the ``heart,'' however; it really acts as \MP's
13582 eyes and mouth, reading the source files and gobbling them up. And it also
13583 helps \MP\ to regurgitate stored token lists that are to be processed again.
13585 The main duty of |get_next| is to input one token and to set |cur_cmd|
13586 and |cur_mod| to that token's command code and modifier. Furthermore, if
13587 the input token is a symbolic token, that token's |hash| address
13588 is stored in |cur_sym|; otherwise |cur_sym| is set to zero.
13590 Underlying this simple description is a certain amount of complexity
13591 because of all the cases that need to be handled.
13592 However, the inner loop of |get_next| is reasonably short and fast.
13594 @ Before getting into |get_next|, we need to consider a mechanism by which
13595 \MP\ helps keep errors from propagating too far. Whenever the program goes
13596 into a mode where it keeps calling |get_next| repeatedly until a certain
13597 condition is met, it sets |scanner_status| to some value other than |normal|.
13598 Then if an input file ends, or if an `\&{outer}' symbol appears,
13599 an appropriate error recovery will be possible.
13601 The global variable |warning_info| helps in this error recovery by providing
13602 additional information. For example, |warning_info| might indicate the
13603 name of a macro whose replacement text is being scanned.
13605 @d normal 0 /* |scanner_status| at ``quiet times'' */
13606 @d skipping 1 /* |scanner_status| when false conditional text is being skipped */
13607 @d flushing 2 /* |scanner_status| when junk after a statement is being ignored */
13608 @d absorbing 3 /* |scanner_status| when a \&{text} parameter is being scanned */
13609 @d var_defining 4 /* |scanner_status| when a \&{vardef} is being scanned */
13610 @d op_defining 5 /* |scanner_status| when a macro \&{def} is being scanned */
13611 @d loop_defining 6 /* |scanner_status| when a \&{for} loop is being scanned */
13612 @d tex_flushing 7 /* |scanner_status| when skipping \TeX\ material */
13615 integer scanner_status; /* are we scanning at high speed? */
13616 integer warning_info; /* if so, what else do we need to know,
13617 in case an error occurs? */
13619 @ @<Initialize the input routines@>=
13620 mp->scanner_status=normal;
13622 @ The following subroutine
13623 is called when an `\&{outer}' symbolic token has been scanned or
13624 when the end of a file has been reached. These two cases are distinguished
13625 by |cur_sym|, which is zero at the end of a file.
13627 @c boolean mp_check_outer_validity (MP mp) {
13628 pointer p; /* points to inserted token list */
13629 if ( mp->scanner_status==normal ) {
13631 } else if ( mp->scanner_status==tex_flushing ) {
13632 @<Check if the file has ended while flushing \TeX\ material and set the
13633 result value for |check_outer_validity|@>;
13635 mp->deletions_allowed=false;
13636 @<Back up an outer symbolic token so that it can be reread@>;
13637 if ( mp->scanner_status>skipping ) {
13638 @<Tell the user what has run away and try to recover@>;
13640 print_err("Incomplete if; all text was ignored after line ");
13641 @.Incomplete if...@>
13642 mp_print_int(mp, mp->warning_info);
13643 help3("A forbidden `outer' token occurred in skipped text.")
13644 ("This kind of error happens when you say `if...' and forget")
13645 ("the matching `fi'. I've inserted a `fi'; this might work.");
13646 if ( mp->cur_sym==0 )
13647 mp->help_line[2]="The file ended while I was skipping conditional text.";
13648 mp->cur_sym=frozen_fi; mp_ins_error(mp);
13650 mp->deletions_allowed=true;
13655 @ @<Check if the file has ended while flushing \TeX\ material and set...@>=
13656 if ( mp->cur_sym!=0 ) {
13659 mp->deletions_allowed=false;
13660 print_err("TeX mode didn't end; all text was ignored after line ");
13661 mp_print_int(mp, mp->warning_info);
13662 help2("The file ended while I was looking for the `etex' to")
13663 ("finish this TeX material. I've inserted `etex' now.");
13664 mp->cur_sym = frozen_etex;
13666 mp->deletions_allowed=true;
13670 @ @<Back up an outer symbolic token so that it can be reread@>=
13671 if ( mp->cur_sym!=0 ) {
13672 p=mp_get_avail(mp); info(p)=mp->cur_sym;
13673 back_list(p); /* prepare to read the symbolic token again */
13676 @ @<Tell the user what has run away...@>=
13678 mp_runaway(mp); /* print the definition-so-far */
13679 if ( mp->cur_sym==0 ) {
13680 print_err("File ended");
13681 @.File ended while scanning...@>
13683 print_err("Forbidden token found");
13684 @.Forbidden token found...@>
13686 mp_print(mp, " while scanning ");
13687 help4("I suspect you have forgotten an `enddef',")
13688 ("causing me to read past where you wanted me to stop.")
13689 ("I'll try to recover; but if the error is serious,")
13690 ("you'd better type `E' or `X' now and fix your file.");
13691 switch (mp->scanner_status) {
13692 @<Complete the error message,
13693 and set |cur_sym| to a token that might help recover from the error@>
13694 } /* there are no other cases */
13698 @ As we consider various kinds of errors, it is also appropriate to
13699 change the first line of the help message just given; |help_line[3]|
13700 points to the string that might be changed.
13702 @<Complete the error message,...@>=
13704 mp_print(mp, "to the end of the statement");
13705 mp->help_line[3]="A previous error seems to have propagated,";
13706 mp->cur_sym=frozen_semicolon;
13709 mp_print(mp, "a text argument");
13710 mp->help_line[3]="It seems that a right delimiter was left out,";
13711 if ( mp->warning_info==0 ) {
13712 mp->cur_sym=frozen_end_group;
13714 mp->cur_sym=frozen_right_delimiter;
13715 equiv(frozen_right_delimiter)=mp->warning_info;
13720 mp_print(mp, "the definition of ");
13721 if ( mp->scanner_status==op_defining )
13722 mp_print_text(mp->warning_info);
13724 mp_print_variable_name(mp, mp->warning_info);
13725 mp->cur_sym=frozen_end_def;
13727 case loop_defining:
13728 mp_print(mp, "the text of a ");
13729 mp_print_text(mp->warning_info);
13730 mp_print(mp, " loop");
13731 mp->help_line[3]="I suspect you have forgotten an `endfor',";
13732 mp->cur_sym=frozen_end_for;
13735 @ The |runaway| procedure displays the first part of the text that occurred
13736 when \MP\ began its special |scanner_status|, if that text has been saved.
13738 @<Declare the procedure called |runaway|@>=
13739 void mp_runaway (MP mp) {
13740 if ( mp->scanner_status>flushing ) {
13741 mp_print_nl(mp, "Runaway ");
13742 switch (mp->scanner_status) {
13743 case absorbing: mp_print(mp, "text?"); break;
13745 case op_defining: mp_print(mp,"definition?"); break;
13746 case loop_defining: mp_print(mp, "loop?"); break;
13747 } /* there are no other cases */
13749 mp_show_token_list(mp, link(hold_head),null,mp->error_line-10,0);
13753 @ We need to mention a procedure that may be called by |get_next|.
13756 void mp_firm_up_the_line (MP mp);
13758 @ And now we're ready to take the plunge into |get_next| itself.
13759 Note that the behavior depends on the |scanner_status| because percent signs
13760 and double quotes need to be passed over when skipping TeX material.
13763 void mp_get_next (MP mp) {
13764 /* sets |cur_cmd|, |cur_mod|, |cur_sym| to next token */
13766 /*restart*/ /* go here to get the next input token */
13767 /*exit*/ /* go here when the next input token has been got */
13768 /*|common_ending|*/ /* go here to finish getting a symbolic token */
13769 /*found*/ /* go here when the end of a symbolic token has been found */
13770 /*switch*/ /* go here to branch on the class of an input character */
13771 /*|start_numeric_token|,|start_decimal_token|,|fin_numeric_token|,|done|*/
13772 /* go here at crucial stages when scanning a number */
13773 int k; /* an index into |buffer| */
13774 ASCII_code c; /* the current character in the buffer */
13775 ASCII_code class; /* its class number */
13776 integer n,f; /* registers for decimal-to-binary conversion */
13779 if ( file_state ) {
13780 @<Input from external file; |goto restart| if no input found,
13781 or |return| if a non-symbolic token is found@>;
13783 @<Input from token list; |goto restart| if end of list or
13784 if a parameter needs to be expanded,
13785 or |return| if a non-symbolic token is found@>;
13788 @<Finish getting the symbolic token in |cur_sym|;
13789 |goto restart| if it is illegal@>;
13792 @ When a symbolic token is declared to be `\&{outer}', its command code
13793 is increased by |outer_tag|.
13796 @<Finish getting the symbolic token in |cur_sym|...@>=
13797 mp->cur_cmd=eq_type(mp->cur_sym); mp->cur_mod=equiv(mp->cur_sym);
13798 if ( mp->cur_cmd>=outer_tag ) {
13799 if ( mp_check_outer_validity(mp) )
13800 mp->cur_cmd=mp->cur_cmd-outer_tag;
13805 @ A percent sign appears in |buffer[limit]|; this makes it unnecessary
13806 to have a special test for end-of-line.
13809 @<Input from external file;...@>=
13812 c=mp->buffer[loc]; incr(loc); class=mp->char_class[c];
13814 case digit_class: goto START_NUMERIC_TOKEN; break;
13816 class=mp->char_class[mp->buffer[loc]];
13817 if ( class>period_class ) {
13819 } else if ( class<period_class ) { /* |class=digit_class| */
13820 n=0; goto START_DECIMAL_TOKEN;
13824 case space_class: goto SWITCH; break;
13825 case percent_class:
13826 if ( mp->scanner_status==tex_flushing ) {
13827 if ( loc<limit ) goto SWITCH;
13829 @<Move to next line of file, or |goto restart| if there is no next line@>;
13834 if ( mp->scanner_status==tex_flushing ) goto SWITCH;
13835 else @<Get a string token and |return|@>;
13837 case isolated_classes:
13838 k=loc-1; goto FOUND; break;
13839 case invalid_class:
13840 if ( mp->scanner_status==tex_flushing ) goto SWITCH;
13841 else @<Decry the invalid character and |goto restart|@>;
13843 default: break; /* letters, etc. */
13846 while ( mp->char_class[mp->buffer[loc]]==class ) incr(loc);
13848 START_NUMERIC_TOKEN:
13849 @<Get the integer part |n| of a numeric token;
13850 set |f:=0| and |goto fin_numeric_token| if there is no decimal point@>;
13851 START_DECIMAL_TOKEN:
13852 @<Get the fraction part |f| of a numeric token@>;
13854 @<Pack the numeric and fraction parts of a numeric token
13857 mp->cur_sym=mp_id_lookup(mp, k,loc-k);
13860 @ We go to |restart| instead of to |SWITCH|, because we might enter
13861 |token_state| after the error has been dealt with
13862 (cf.\ |clear_for_error_prompt|).
13864 @<Decry the invalid...@>=
13866 print_err("Text line contains an invalid character");
13867 @.Text line contains...@>
13868 help2("A funny symbol that I can\'t read has just been input.")
13869 ("Continue, and I'll forget that it ever happened.");
13870 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
13874 @ @<Get a string token and |return|@>=
13876 if ( mp->buffer[loc]=='"' ) {
13877 mp->cur_mod=rts("");
13879 k=loc; mp->buffer[limit+1]='"';
13882 } while (mp->buffer[loc]!='"');
13884 @<Decry the missing string delimiter and |goto restart|@>;
13887 mp->cur_mod=mp->buffer[k];
13891 append_char(mp->buffer[k]); incr(k);
13893 mp->cur_mod=mp_make_string(mp);
13896 incr(loc); mp->cur_cmd=string_token;
13900 @ We go to |restart| after this error message, not to |SWITCH|,
13901 because the |clear_for_error_prompt| routine might have reinstated
13902 |token_state| after |error| has finished.
13904 @<Decry the missing string delimiter and |goto restart|@>=
13906 loc=limit; /* the next character to be read on this line will be |"%"| */
13907 print_err("Incomplete string token has been flushed");
13908 @.Incomplete string token...@>
13909 help3("Strings should finish on the same line as they began.")
13910 ("I've deleted the partial string; you might want to")
13911 ("insert another by typing, e.g., `I\"new string\"'.");
13912 mp->deletions_allowed=false; mp_error(mp);
13913 mp->deletions_allowed=true;
13917 @ @<Get the integer part |n| of a numeric token...@>=
13919 while ( mp->char_class[mp->buffer[loc]]==digit_class ) {
13920 if ( n<32768 ) n=10*n+mp->buffer[loc]-'0';
13923 if ( mp->buffer[loc]=='.' )
13924 if ( mp->char_class[mp->buffer[loc+1]]==digit_class )
13927 goto FIN_NUMERIC_TOKEN;
13930 @ @<Get the fraction part |f| of a numeric token@>=
13933 if ( k<17 ) { /* digits for |k>=17| cannot affect the result */
13934 mp->dig[k]=mp->buffer[loc]-'0'; incr(k);
13937 } while (mp->char_class[mp->buffer[loc]]==digit_class);
13938 f=mp_round_decimals(mp, k);
13943 @ @<Pack the numeric and fraction parts of a numeric token and |return|@>=
13945 @<Set |cur_mod:=n*unity+f| and check if it is uncomfortably large@>;
13946 } else if ( mp->scanner_status!=tex_flushing ) {
13947 print_err("Enormous number has been reduced");
13948 @.Enormous number...@>
13949 help2("I can\'t handle numbers bigger than 32767.99998;")
13950 ("so I've changed your constant to that maximum amount.");
13951 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
13952 mp->cur_mod=el_gordo;
13954 mp->cur_cmd=numeric_token; return
13956 @ @<Set |cur_mod:=n*unity+f| and check if it is uncomfortably large@>=
13958 mp->cur_mod=n*unity+f;
13959 if ( mp->cur_mod>=fraction_one ) {
13960 if ( (mp->internal[mp_warning_check]>0) &&
13961 (mp->scanner_status!=tex_flushing) ) {
13962 print_err("Number is too large (");
13963 mp_print_scaled(mp, mp->cur_mod);
13964 mp_print_char(mp, ')');
13965 help3("It is at least 4096. Continue and I'll try to cope")
13966 ("with that big value; but it might be dangerous.")
13967 ("(Set warningcheck:=0 to suppress this message.)");
13973 @ Let's consider now what happens when |get_next| is looking at a token list.
13976 @<Input from token list;...@>=
13977 if ( loc>=mp->hi_mem_min ) { /* one-word token */
13978 mp->cur_sym=info(loc); loc=link(loc); /* move to next */
13979 if ( mp->cur_sym>=expr_base ) {
13980 if ( mp->cur_sym>=suffix_base ) {
13981 @<Insert a suffix or text parameter and |goto restart|@>;
13983 mp->cur_cmd=capsule_token;
13984 mp->cur_mod=mp->param_stack[param_start+mp->cur_sym-(expr_base)];
13985 mp->cur_sym=0; return;
13988 } else if ( loc>null ) {
13989 @<Get a stored numeric or string or capsule token and |return|@>
13990 } else { /* we are done with this token list */
13991 mp_end_token_list(mp); goto RESTART; /* resume previous level */
13994 @ @<Insert a suffix or text parameter...@>=
13996 if ( mp->cur_sym>=text_base ) mp->cur_sym=mp->cur_sym-mp->param_size;
13997 /* |param_size=text_base-suffix_base| */
13998 mp_begin_token_list(mp,
13999 mp->param_stack[param_start+mp->cur_sym-(suffix_base)],
14004 @ @<Get a stored numeric or string or capsule token...@>=
14006 if ( name_type(loc)==mp_token ) {
14007 mp->cur_mod=value(loc);
14008 if ( type(loc)==mp_known ) {
14009 mp->cur_cmd=numeric_token;
14011 mp->cur_cmd=string_token; add_str_ref(mp->cur_mod);
14014 mp->cur_mod=loc; mp->cur_cmd=capsule_token;
14016 loc=link(loc); return;
14019 @ All of the easy branches of |get_next| have now been taken care of.
14020 There is one more branch.
14022 @<Move to next line of file, or |goto restart|...@>=
14023 if ( name>max_spec_src ) {
14024 @<Read next line of file into |buffer|, or
14025 |goto restart| if the file has ended@>;
14027 if ( mp->input_ptr>0 ) {
14028 /* text was inserted during error recovery or by \&{scantokens} */
14029 mp_end_file_reading(mp); goto RESTART; /* resume previous level */
14031 if (mp->job_name == NULL && ( mp->selector<log_only || mp->selector>=write_file))
14032 mp_open_log_file(mp);
14033 if ( mp->interaction>mp_nonstop_mode ) {
14034 if ( limit==start ) /* previous line was empty */
14035 mp_print_nl(mp, "(Please type a command or say `end')");
14037 mp_print_ln(mp); mp->first=start;
14038 prompt_input("*"); /* input on-line into |buffer| */
14040 limit=mp->last; mp->buffer[limit]='%';
14041 mp->first=limit+1; loc=start;
14043 mp_fatal_error(mp, "*** (job aborted, no legal end found)");
14045 /* nonstop mode, which is intended for overnight batch processing,
14046 never waits for on-line input */
14050 @ The global variable |force_eof| is normally |false|; it is set |true|
14051 by an \&{endinput} command.
14054 boolean force_eof; /* should the next \&{input} be aborted early? */
14056 @ We must decrement |loc| in order to leave the buffer in a valid state
14057 when an error condition causes us to |goto restart| without calling
14058 |end_file_reading|.
14060 @<Read next line of file into |buffer|, or
14061 |goto restart| if the file has ended@>=
14063 incr(line); mp->first=start;
14064 if ( ! mp->force_eof ) {
14065 if ( mp_input_ln(mp, cur_file ) ) /* not end of file */
14066 mp_firm_up_the_line(mp); /* this sets |limit| */
14068 mp->force_eof=true;
14070 if ( mp->force_eof ) {
14071 mp->force_eof=false;
14073 if ( mpx_reading ) {
14074 @<Complain that the \.{MPX} file ended unexpectly; then set
14075 |cur_sym:=frozen_mpx_break| and |goto comon_ending|@>;
14077 mp_print_char(mp, ')'); decr(mp->open_parens);
14078 update_terminal; /* show user that file has been read */
14079 mp_end_file_reading(mp); /* resume previous level */
14080 if ( mp_check_outer_validity(mp) ) goto RESTART;
14084 mp->buffer[limit]='%'; mp->first=limit+1; loc=start; /* ready to read */
14087 @ We should never actually come to the end of an \.{MPX} file because such
14088 files should have an \&{mpxbreak} after the translation of the last
14089 \&{btex}$\,\ldots\,$\&{etex} block.
14091 @<Complain that the \.{MPX} file ended unexpectly; then set...@>=
14093 mp->mpx_name[index]=mpx_finished;
14094 print_err("mpx file ended unexpectedly");
14095 help4("The file had too few picture expressions for btex...etex")
14096 ("blocks. Such files are normally generated automatically")
14097 ("but this one got messed up. You might want to insert a")
14098 ("picture expression now.");
14099 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
14100 mp->cur_sym=frozen_mpx_break; goto COMMON_ENDING;
14103 @ Sometimes we want to make it look as though we have just read a blank line
14104 without really doing so.
14106 @<Put an empty line in the input buffer@>=
14107 mp->last=mp->first; limit=mp->last; /* simulate |input_ln| and |firm_up_the_line| */
14108 mp->buffer[limit]='%'; mp->first=limit+1; loc=start
14110 @ If the user has set the |mp_pausing| parameter to some positive value,
14111 and if nonstop mode has not been selected, each line of input is displayed
14112 on the terminal and the transcript file, followed by `\.{=>}'.
14113 \MP\ waits for a response. If the response is null (i.e., if nothing is
14114 typed except perhaps a few blank spaces), the original
14115 line is accepted as it stands; otherwise the line typed is
14116 used instead of the line in the file.
14118 @c void mp_firm_up_the_line (MP mp) {
14119 size_t k; /* an index into |buffer| */
14121 if ( mp->internal[mp_pausing]>0) if ( mp->interaction>mp_nonstop_mode ) {
14122 wake_up_terminal; mp_print_ln(mp);
14123 if ( start<limit ) {
14124 for (k=(size_t)start;k<=(size_t)(limit-1);k++) {
14125 mp_print_str(mp, mp->buffer[k]);
14128 mp->first=limit; prompt_input("=>"); /* wait for user response */
14130 if ( mp->last>mp->first ) {
14131 for (k=mp->first;k<=mp->last-1;k++) { /* move line down in buffer */
14132 mp->buffer[k+start-mp->first]=mp->buffer[k];
14134 limit=start+mp->last-mp->first;
14139 @* \[30] Dealing with \TeX\ material.
14140 The \&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}$\,\ldots\,$\&{etex}
14141 features need to be implemented at a low level in the scanning process
14142 so that \MP\ can stay in synch with the a preprocessor that treats
14143 blocks of \TeX\ material as they occur in the input file without trying
14144 to expand \MP\ macros. Thus we need a special version of |get_next|
14145 that does not expand macros and such but does handle \&{btex},
14146 \&{verbatimtex}, etc.
14148 The special version of |get_next| is called |get_t_next|. It works by flushing
14149 \&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}\allowbreak
14150 $\,\ldots\,$\&{etex} blocks, switching to the \.{MPX} file when it sees
14151 \&{btex}, and switching back when it sees \&{mpxbreak}.
14157 mp_primitive(mp, "btex",start_tex,btex_code);
14158 @:btex_}{\&{btex} primitive@>
14159 mp_primitive(mp, "verbatimtex",start_tex,verbatim_code);
14160 @:verbatimtex_}{\&{verbatimtex} primitive@>
14161 mp_primitive(mp, "etex",etex_marker,0); mp->eqtb[frozen_etex]=mp->eqtb[mp->cur_sym];
14162 @:etex_}{\&{etex} primitive@>
14163 mp_primitive(mp, "mpxbreak",mpx_break,0); mp->eqtb[frozen_mpx_break]=mp->eqtb[mp->cur_sym];
14164 @:mpx_break_}{\&{mpxbreak} primitive@>
14166 @ @<Cases of |print_cmd...@>=
14167 case start_tex: if ( m==btex_code ) mp_print(mp, "btex");
14168 else mp_print(mp, "verbatimtex"); break;
14169 case etex_marker: mp_print(mp, "etex"); break;
14170 case mpx_break: mp_print(mp, "mpxbreak"); break;
14172 @ Actually, |get_t_next| is a macro that avoids procedure overhead except
14173 in the unusual case where \&{btex}, \&{verbatimtex}, \&{etex}, or \&{mpxbreak}
14176 @d get_t_next {mp_get_next(mp); if ( mp->cur_cmd<=max_pre_command ) mp_t_next(mp); }
14179 void mp_start_mpx_input (MP mp);
14182 void mp_t_next (MP mp) {
14183 int old_status; /* saves the |scanner_status| */
14184 integer old_info; /* saves the |warning_info| */
14185 while ( mp->cur_cmd<=max_pre_command ) {
14186 if ( mp->cur_cmd==mpx_break ) {
14187 if ( ! file_state || (mp->mpx_name[index]==absent) ) {
14188 @<Complain about a misplaced \&{mpxbreak}@>;
14190 mp_end_mpx_reading(mp);
14193 } else if ( mp->cur_cmd==start_tex ) {
14194 if ( token_state || (name<=max_spec_src) ) {
14195 @<Complain that we are not reading a file@>;
14196 } else if ( mpx_reading ) {
14197 @<Complain that \.{MPX} files cannot contain \TeX\ material@>;
14198 } else if ( (mp->cur_mod!=verbatim_code)&&
14199 (mp->mpx_name[index]!=mpx_finished) ) {
14200 if ( ! mp_begin_mpx_reading(mp) ) mp_start_mpx_input(mp);
14205 @<Complain about a misplaced \&{etex}@>;
14207 goto COMMON_ENDING;
14209 @<Flush the \TeX\ material@>;
14215 @ We could be in the middle of an operation such as skipping false conditional
14216 text when \TeX\ material is encountered, so we must be careful to save the
14219 @<Flush the \TeX\ material@>=
14220 old_status=mp->scanner_status;
14221 old_info=mp->warning_info;
14222 mp->scanner_status=tex_flushing;
14223 mp->warning_info=line;
14224 do { mp_get_next(mp); } while (mp->cur_cmd!=etex_marker);
14225 mp->scanner_status=old_status;
14226 mp->warning_info=old_info
14228 @ @<Complain that \.{MPX} files cannot contain \TeX\ material@>=
14229 { print_err("An mpx file cannot contain btex or verbatimtex blocks");
14230 help4("This file contains picture expressions for btex...etex")
14231 ("blocks. Such files are normally generated automatically")
14232 ("but this one seems to be messed up. I'll just keep going")
14233 ("and hope for the best.");
14237 @ @<Complain that we are not reading a file@>=
14238 { print_err("You can only use `btex' or `verbatimtex' in a file");
14239 help3("I'll have to ignore this preprocessor command because it")
14240 ("only works when there is a file to preprocess. You might")
14241 ("want to delete everything up to the next `etex`.");
14245 @ @<Complain about a misplaced \&{mpxbreak}@>=
14246 { print_err("Misplaced mpxbreak");
14247 help2("I'll ignore this preprocessor command because it")
14248 ("doesn't belong here");
14252 @ @<Complain about a misplaced \&{etex}@>=
14253 { print_err("Extra etex will be ignored");
14254 help1("There is no btex or verbatimtex for this to match");
14258 @* \[31] Scanning macro definitions.
14259 \MP\ has a variety of ways to tuck tokens away into token lists for later
14260 use: Macros can be defined with \&{def}, \&{vardef}, \&{primarydef}, etc.;
14261 repeatable code can be defined with \&{for}, \&{forever}, \&{forsuffixes}.
14262 All such operations are handled by the routines in this part of the program.
14264 The modifier part of each command code is zero for the ``ending delimiters''
14265 like \&{enddef} and \&{endfor}.
14267 @d start_def 1 /* command modifier for \&{def} */
14268 @d var_def 2 /* command modifier for \&{vardef} */
14269 @d end_def 0 /* command modifier for \&{enddef} */
14270 @d start_forever 1 /* command modifier for \&{forever} */
14271 @d end_for 0 /* command modifier for \&{endfor} */
14274 mp_primitive(mp, "def",macro_def,start_def);
14275 @:def_}{\&{def} primitive@>
14276 mp_primitive(mp, "vardef",macro_def,var_def);
14277 @:var_def_}{\&{vardef} primitive@>
14278 mp_primitive(mp, "primarydef",macro_def,secondary_primary_macro);
14279 @:primary_def_}{\&{primarydef} primitive@>
14280 mp_primitive(mp, "secondarydef",macro_def,tertiary_secondary_macro);
14281 @:secondary_def_}{\&{secondarydef} primitive@>
14282 mp_primitive(mp, "tertiarydef",macro_def,expression_tertiary_macro);
14283 @:tertiary_def_}{\&{tertiarydef} primitive@>
14284 mp_primitive(mp, "enddef",macro_def,end_def); mp->eqtb[frozen_end_def]=mp->eqtb[mp->cur_sym];
14285 @:end_def_}{\&{enddef} primitive@>
14287 mp_primitive(mp, "for",iteration,expr_base);
14288 @:for_}{\&{for} primitive@>
14289 mp_primitive(mp, "forsuffixes",iteration,suffix_base);
14290 @:for_suffixes_}{\&{forsuffixes} primitive@>
14291 mp_primitive(mp, "forever",iteration,start_forever);
14292 @:forever_}{\&{forever} primitive@>
14293 mp_primitive(mp, "endfor",iteration,end_for); mp->eqtb[frozen_end_for]=mp->eqtb[mp->cur_sym];
14294 @:end_for_}{\&{endfor} primitive@>
14296 @ @<Cases of |print_cmd...@>=
14298 if ( m<=var_def ) {
14299 if ( m==start_def ) mp_print(mp, "def");
14300 else if ( m<start_def ) mp_print(mp, "enddef");
14301 else mp_print(mp, "vardef");
14302 } else if ( m==secondary_primary_macro ) {
14303 mp_print(mp, "primarydef");
14304 } else if ( m==tertiary_secondary_macro ) {
14305 mp_print(mp, "secondarydef");
14307 mp_print(mp, "tertiarydef");
14311 if ( m<=start_forever ) {
14312 if ( m==start_forever ) mp_print(mp, "forever");
14313 else mp_print(mp, "endfor");
14314 } else if ( m==expr_base ) {
14315 mp_print(mp, "for");
14317 mp_print(mp, "forsuffixes");
14321 @ Different macro-absorbing operations have different syntaxes, but they
14322 also have a lot in common. There is a list of special symbols that are to
14323 be replaced by parameter tokens; there is a special command code that
14324 ends the definition; the quotation conventions are identical. Therefore
14325 it makes sense to have most of the work done by a single subroutine. That
14326 subroutine is called |scan_toks|.
14328 The first parameter to |scan_toks| is the command code that will
14329 terminate scanning (either |macro_def| or |iteration|).
14331 The second parameter, |subst_list|, points to a (possibly empty) list
14332 of two-word nodes whose |info| and |value| fields specify symbol tokens
14333 before and after replacement. The list will be returned to free storage
14336 The third parameter is simply appended to the token list that is built.
14337 And the final parameter tells how many of the special operations
14338 \.{\#\AT!}, \.{\AT!}, and \.{\AT!\#} are to be replaced by suffix parameters.
14339 When such parameters are present, they are called \.{(SUFFIX0)},
14340 \.{(SUFFIX1)}, and \.{(SUFFIX2)}.
14342 @c pointer mp_scan_toks (MP mp,command_code terminator, pointer
14343 subst_list, pointer tail_end, small_number suffix_count) {
14344 pointer p; /* tail of the token list being built */
14345 pointer q; /* temporary for link management */
14346 integer balance; /* left delimiters minus right delimiters */
14347 p=hold_head; balance=1; link(hold_head)=null;
14350 if ( mp->cur_sym>0 ) {
14351 @<Substitute for |cur_sym|, if it's on the |subst_list|@>;
14352 if ( mp->cur_cmd==terminator ) {
14353 @<Adjust the balance; |break| if it's zero@>;
14354 } else if ( mp->cur_cmd==macro_special ) {
14355 @<Handle quoted symbols, \.{\#\AT!}, \.{\AT!}, or \.{\AT!\#}@>;
14358 link(p)=mp_cur_tok(mp); p=link(p);
14360 link(p)=tail_end; mp_flush_node_list(mp, subst_list);
14361 return link(hold_head);
14364 @ @<Substitute for |cur_sym|...@>=
14367 while ( q!=null ) {
14368 if ( info(q)==mp->cur_sym ) {
14369 mp->cur_sym=value(q); mp->cur_cmd=relax; break;
14375 @ @<Adjust the balance; |break| if it's zero@>=
14376 if ( mp->cur_mod>0 ) {
14384 @ Four commands are intended to be used only within macro texts: \&{quote},
14385 \.{\#\AT!}, \.{\AT!}, and \.{\AT!\#}. They are variants of a single command
14386 code called |macro_special|.
14388 @d quote 0 /* |macro_special| modifier for \&{quote} */
14389 @d macro_prefix 1 /* |macro_special| modifier for \.{\#\AT!} */
14390 @d macro_at 2 /* |macro_special| modifier for \.{\AT!} */
14391 @d macro_suffix 3 /* |macro_special| modifier for \.{\AT!\#} */
14394 mp_primitive(mp, "quote",macro_special,quote);
14395 @:quote_}{\&{quote} primitive@>
14396 mp_primitive(mp, "#@@",macro_special,macro_prefix);
14397 @:]]]\#\AT!_}{\.{\#\AT!} primitive@>
14398 mp_primitive(mp, "@@",macro_special,macro_at);
14399 @:]]]\AT!_}{\.{\AT!} primitive@>
14400 mp_primitive(mp, "@@#",macro_special,macro_suffix);
14401 @:]]]\AT!\#_}{\.{\AT!\#} primitive@>
14403 @ @<Cases of |print_cmd...@>=
14404 case macro_special:
14406 case macro_prefix: mp_print(mp, "#@@"); break;
14407 case macro_at: mp_print_char(mp, '@@'); break;
14408 case macro_suffix: mp_print(mp, "@@#"); break;
14409 default: mp_print(mp, "quote"); break;
14413 @ @<Handle quoted...@>=
14415 if ( mp->cur_mod==quote ) { get_t_next; }
14416 else if ( mp->cur_mod<=suffix_count )
14417 mp->cur_sym=suffix_base-1+mp->cur_mod;
14420 @ Here is a routine that's used whenever a token will be redefined. If
14421 the user's token is unredefinable, the `|frozen_inaccessible|' token is
14422 substituted; the latter is redefinable but essentially impossible to use,
14423 hence \MP's tables won't get fouled up.
14425 @c void mp_get_symbol (MP mp) { /* sets |cur_sym| to a safe symbol */
14428 if ( (mp->cur_sym==0)||(mp->cur_sym>frozen_inaccessible) ) {
14429 print_err("Missing symbolic token inserted");
14430 @.Missing symbolic token...@>
14431 help3("Sorry: You can\'t redefine a number, string, or expr.")
14432 ("I've inserted an inaccessible symbol so that your")
14433 ("definition will be completed without mixing me up too badly.");
14434 if ( mp->cur_sym>0 )
14435 mp->help_line[2]="Sorry: You can\'t redefine my error-recovery tokens.";
14436 else if ( mp->cur_cmd==string_token )
14437 delete_str_ref(mp->cur_mod);
14438 mp->cur_sym=frozen_inaccessible; mp_ins_error(mp); goto RESTART;
14442 @ Before we actually redefine a symbolic token, we need to clear away its
14443 former value, if it was a variable. The following stronger version of
14444 |get_symbol| does that.
14446 @c void mp_get_clear_symbol (MP mp) {
14447 mp_get_symbol(mp); mp_clear_symbol(mp, mp->cur_sym,false);
14450 @ Here's another little subroutine; it checks that an equals sign
14451 or assignment sign comes along at the proper place in a macro definition.
14453 @c void mp_check_equals (MP mp) {
14454 if ( mp->cur_cmd!=equals ) if ( mp->cur_cmd!=assignment ) {
14455 mp_missing_err(mp, "=");
14457 help5("The next thing in this `def' should have been `=',")
14458 ("because I've already looked at the definition heading.")
14459 ("But don't worry; I'll pretend that an equals sign")
14460 ("was present. Everything from here to `enddef'")
14461 ("will be the replacement text of this macro.");
14466 @ A \&{primarydef}, \&{secondarydef}, or \&{tertiarydef} is rather easily
14467 handled now that we have |scan_toks|. In this case there are
14468 two parameters, which will be \.{EXPR0} and \.{EXPR1} (i.e.,
14469 |expr_base| and |expr_base+1|).
14471 @c void mp_make_op_def (MP mp) {
14472 command_code m; /* the type of definition */
14473 pointer p,q,r; /* for list manipulation */
14475 mp_get_symbol(mp); q=mp_get_node(mp, token_node_size);
14476 info(q)=mp->cur_sym; value(q)=expr_base;
14477 mp_get_clear_symbol(mp); mp->warning_info=mp->cur_sym;
14478 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
14479 info(p)=mp->cur_sym; value(p)=expr_base+1; link(p)=q;
14480 get_t_next; mp_check_equals(mp);
14481 mp->scanner_status=op_defining; q=mp_get_avail(mp); ref_count(q)=null;
14482 r=mp_get_avail(mp); link(q)=r; info(r)=general_macro;
14483 link(r)=mp_scan_toks(mp, macro_def,p,null,0);
14484 mp->scanner_status=normal; eq_type(mp->warning_info)=m;
14485 equiv(mp->warning_info)=q; mp_get_x_next(mp);
14488 @ Parameters to macros are introduced by the keywords \&{expr},
14489 \&{suffix}, \&{text}, \&{primary}, \&{secondary}, and \&{tertiary}.
14492 mp_primitive(mp, "expr",param_type,expr_base);
14493 @:expr_}{\&{expr} primitive@>
14494 mp_primitive(mp, "suffix",param_type,suffix_base);
14495 @:suffix_}{\&{suffix} primitive@>
14496 mp_primitive(mp, "text",param_type,text_base);
14497 @:text_}{\&{text} primitive@>
14498 mp_primitive(mp, "primary",param_type,primary_macro);
14499 @:primary_}{\&{primary} primitive@>
14500 mp_primitive(mp, "secondary",param_type,secondary_macro);
14501 @:secondary_}{\&{secondary} primitive@>
14502 mp_primitive(mp, "tertiary",param_type,tertiary_macro);
14503 @:tertiary_}{\&{tertiary} primitive@>
14505 @ @<Cases of |print_cmd...@>=
14507 if ( m>=expr_base ) {
14508 if ( m==expr_base ) mp_print(mp, "expr");
14509 else if ( m==suffix_base ) mp_print(mp, "suffix");
14510 else mp_print(mp, "text");
14511 } else if ( m<secondary_macro ) {
14512 mp_print(mp, "primary");
14513 } else if ( m==secondary_macro ) {
14514 mp_print(mp, "secondary");
14516 mp_print(mp, "tertiary");
14520 @ Let's turn next to the more complex processing associated with \&{def}
14521 and \&{vardef}. When the following procedure is called, |cur_mod|
14522 should be either |start_def| or |var_def|.
14524 @c @<Declare the procedure called |check_delimiter|@>
14525 @<Declare the function called |scan_declared_variable|@>
14526 void mp_scan_def (MP mp) {
14527 int m; /* the type of definition */
14528 int n; /* the number of special suffix parameters */
14529 int k; /* the total number of parameters */
14530 int c; /* the kind of macro we're defining */
14531 pointer r; /* parameter-substitution list */
14532 pointer q; /* tail of the macro token list */
14533 pointer p; /* temporary storage */
14534 halfword base; /* |expr_base|, |suffix_base|, or |text_base| */
14535 pointer l_delim,r_delim; /* matching delimiters */
14536 m=mp->cur_mod; c=general_macro; link(hold_head)=null;
14537 q=mp_get_avail(mp); ref_count(q)=null; r=null;
14538 @<Scan the token or variable to be defined;
14539 set |n|, |scanner_status|, and |warning_info|@>;
14541 if ( mp->cur_cmd==left_delimiter ) {
14542 @<Absorb delimited parameters, putting them into lists |q| and |r|@>;
14544 if ( mp->cur_cmd==param_type ) {
14545 @<Absorb undelimited parameters, putting them into list |r|@>;
14547 mp_check_equals(mp);
14548 p=mp_get_avail(mp); info(p)=c; link(q)=p;
14549 @<Attach the replacement text to the tail of node |p|@>;
14550 mp->scanner_status=normal; mp_get_x_next(mp);
14553 @ We don't put `|frozen_end_group|' into the replacement text of
14554 a \&{vardef}, because the user may want to redefine `\.{endgroup}'.
14556 @<Attach the replacement text to the tail of node |p|@>=
14557 if ( m==start_def ) {
14558 link(p)=mp_scan_toks(mp, macro_def,r,null,n);
14560 q=mp_get_avail(mp); info(q)=mp->bg_loc; link(p)=q;
14561 p=mp_get_avail(mp); info(p)=mp->eg_loc;
14562 link(q)=mp_scan_toks(mp, macro_def,r,p,n);
14564 if ( mp->warning_info==bad_vardef )
14565 mp_flush_token_list(mp, value(bad_vardef))
14569 int eg_loc; /* hash addresses of `\.{begingroup}' and `\.{endgroup}' */
14571 @ @<Scan the token or variable to be defined;...@>=
14572 if ( m==start_def ) {
14573 mp_get_clear_symbol(mp); mp->warning_info=mp->cur_sym; get_t_next;
14574 mp->scanner_status=op_defining; n=0;
14575 eq_type(mp->warning_info)=defined_macro; equiv(mp->warning_info)=q;
14577 p=mp_scan_declared_variable(mp);
14578 mp_flush_variable(mp, equiv(info(p)),link(p),true);
14579 mp->warning_info=mp_find_variable(mp, p); mp_flush_list(mp, p);
14580 if ( mp->warning_info==null ) @<Change to `\.{a bad variable}'@>;
14581 mp->scanner_status=var_defining; n=2;
14582 if ( mp->cur_cmd==macro_special ) if ( mp->cur_mod==macro_suffix ) {/* \.{\AT!\#} */
14585 type(mp->warning_info)=mp_unsuffixed_macro-2+n; value(mp->warning_info)=q;
14586 } /* |mp_suffixed_macro=mp_unsuffixed_macro+1| */
14588 @ @<Change to `\.{a bad variable}'@>=
14590 print_err("This variable already starts with a macro");
14591 @.This variable already...@>
14592 help2("After `vardef a' you can\'t say `vardef a.b'.")
14593 ("So I'll have to discard this definition.");
14594 mp_error(mp); mp->warning_info=bad_vardef;
14597 @ @<Initialize table entries...@>=
14598 name_type(bad_vardef)=mp_root; link(bad_vardef)=frozen_bad_vardef;
14599 equiv(frozen_bad_vardef)=bad_vardef; eq_type(frozen_bad_vardef)=tag_token;
14601 @ @<Absorb delimited parameters, putting them into lists |q| and |r|@>=
14603 l_delim=mp->cur_sym; r_delim=mp->cur_mod; get_t_next;
14604 if ( (mp->cur_cmd==param_type)&&(mp->cur_mod>=expr_base) ) {
14607 print_err("Missing parameter type; `expr' will be assumed");
14608 @.Missing parameter type@>
14609 help1("You should've had `expr' or `suffix' or `text' here.");
14610 mp_back_error(mp); base=expr_base;
14612 @<Absorb parameter tokens for type |base|@>;
14613 mp_check_delimiter(mp, l_delim,r_delim);
14615 } while (mp->cur_cmd==left_delimiter)
14617 @ @<Absorb parameter tokens for type |base|@>=
14619 link(q)=mp_get_avail(mp); q=link(q); info(q)=base+k;
14620 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
14621 value(p)=base+k; info(p)=mp->cur_sym;
14622 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14623 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
14624 incr(k); link(p)=r; r=p; get_t_next;
14625 } while (mp->cur_cmd==comma)
14627 @ @<Absorb undelimited parameters, putting them into list |r|@>=
14629 p=mp_get_node(mp, token_node_size);
14630 if ( mp->cur_mod<expr_base ) {
14631 c=mp->cur_mod; value(p)=expr_base+k;
14633 value(p)=mp->cur_mod+k;
14634 if ( mp->cur_mod==expr_base ) c=expr_macro;
14635 else if ( mp->cur_mod==suffix_base ) c=suffix_macro;
14638 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14639 incr(k); mp_get_symbol(mp); info(p)=mp->cur_sym; link(p)=r; r=p; get_t_next;
14640 if ( c==expr_macro ) if ( mp->cur_cmd==of_token ) {
14641 c=of_macro; p=mp_get_node(mp, token_node_size);
14642 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14643 value(p)=expr_base+k; mp_get_symbol(mp); info(p)=mp->cur_sym;
14644 link(p)=r; r=p; get_t_next;
14648 @* \[32] Expanding the next token.
14649 Only a few command codes |<min_command| can possibly be returned by
14650 |get_t_next|; in increasing order, they are
14651 |if_test|, |fi_or_else|, |input|, |iteration|, |repeat_loop|,
14652 |exit_test|, |relax|, |scan_tokens|, |expand_after|, and |defined_macro|.
14654 \MP\ usually gets the next token of input by saying |get_x_next|. This is
14655 like |get_t_next| except that it keeps getting more tokens until
14656 finding |cur_cmd>=min_command|. In other words, |get_x_next| expands
14657 macros and removes conditionals or iterations or input instructions that
14660 It follows that |get_x_next| might invoke itself recursively. In fact,
14661 there is massive recursion, since macro expansion can involve the
14662 scanning of arbitrarily complex expressions, which in turn involve
14663 macro expansion and conditionals, etc.
14666 Therefore it's necessary to declare a whole bunch of |forward|
14667 procedures at this point, and to insert some other procedures
14668 that will be invoked by |get_x_next|.
14671 void mp_scan_primary (MP mp);
14672 void mp_scan_secondary (MP mp);
14673 void mp_scan_tertiary (MP mp);
14674 void mp_scan_expression (MP mp);
14675 void mp_scan_suffix (MP mp);
14676 @<Declare the procedure called |macro_call|@>
14677 void mp_get_boolean (MP mp);
14678 void mp_pass_text (MP mp);
14679 void mp_conditional (MP mp);
14680 void mp_start_input (MP mp);
14681 void mp_begin_iteration (MP mp);
14682 void mp_resume_iteration (MP mp);
14683 void mp_stop_iteration (MP mp);
14685 @ An auxiliary subroutine called |expand| is used by |get_x_next|
14686 when it has to do exotic expansion commands.
14688 @c void mp_expand (MP mp) {
14689 pointer p; /* for list manipulation */
14690 size_t k; /* something that we hope is |<=buf_size| */
14691 pool_pointer j; /* index into |str_pool| */
14692 if ( mp->internal[mp_tracing_commands]>unity )
14693 if ( mp->cur_cmd!=defined_macro )
14695 switch (mp->cur_cmd) {
14697 mp_conditional(mp); /* this procedure is discussed in Part 36 below */
14700 @<Terminate the current conditional and skip to \&{fi}@>;
14703 @<Initiate or terminate input from a file@>;
14706 if ( mp->cur_mod==end_for ) {
14707 @<Scold the user for having an extra \&{endfor}@>;
14709 mp_begin_iteration(mp); /* this procedure is discussed in Part 37 below */
14716 @<Exit a loop if the proper time has come@>;
14721 @<Expand the token after the next token@>;
14724 @<Put a string into the input buffer@>;
14726 case defined_macro:
14727 mp_macro_call(mp, mp->cur_mod,null,mp->cur_sym);
14729 }; /* there are no other cases */
14732 @ @<Scold the user...@>=
14734 print_err("Extra `endfor'");
14736 help2("I'm not currently working on a for loop,")
14737 ("so I had better not try to end anything.");
14741 @ The processing of \&{input} involves the |start_input| subroutine,
14742 which will be declared later; the processing of \&{endinput} is trivial.
14745 mp_primitive(mp, "input",input,0);
14746 @:input_}{\&{input} primitive@>
14747 mp_primitive(mp, "endinput",input,1);
14748 @:end_input_}{\&{endinput} primitive@>
14750 @ @<Cases of |print_cmd_mod|...@>=
14752 if ( m==0 ) mp_print(mp, "input");
14753 else mp_print(mp, "endinput");
14756 @ @<Initiate or terminate input...@>=
14757 if ( mp->cur_mod>0 ) mp->force_eof=true;
14758 else mp_start_input(mp)
14760 @ We'll discuss the complicated parts of loop operations later. For now
14761 it suffices to know that there's a global variable called |loop_ptr|
14762 that will be |null| if no loop is in progress.
14765 { while ( token_state &&(loc==null) )
14766 mp_end_token_list(mp); /* conserve stack space */
14767 if ( mp->loop_ptr==null ) {
14768 print_err("Lost loop");
14770 help2("I'm confused; after exiting from a loop, I still seem")
14771 ("to want to repeat it. I'll try to forget the problem.");
14774 mp_resume_iteration(mp); /* this procedure is in Part 37 below */
14778 @ @<Exit a loop if the proper time has come@>=
14779 { mp_get_boolean(mp);
14780 if ( mp->internal[mp_tracing_commands]>unity )
14781 mp_show_cmd_mod(mp, nullary,mp->cur_exp);
14782 if ( mp->cur_exp==true_code ) {
14783 if ( mp->loop_ptr==null ) {
14784 print_err("No loop is in progress");
14785 @.No loop is in progress@>
14786 help1("Why say `exitif' when there's nothing to exit from?");
14787 if ( mp->cur_cmd==semicolon ) mp_error(mp); else mp_back_error(mp);
14789 @<Exit prematurely from an iteration@>;
14791 } else if ( mp->cur_cmd!=semicolon ) {
14792 mp_missing_err(mp, ";");
14794 help2("After `exitif <boolean exp>' I expect to see a semicolon.")
14795 ("I shall pretend that one was there."); mp_back_error(mp);
14799 @ Here we use the fact that |forever_text| is the only |token_type| that
14800 is less than |loop_text|.
14802 @<Exit prematurely...@>=
14805 if ( file_state ) {
14806 mp_end_file_reading(mp);
14808 if ( token_type<=loop_text ) p=start;
14809 mp_end_token_list(mp);
14812 if ( p!=info(mp->loop_ptr) ) mp_fatal_error(mp, "*** (loop confusion)");
14814 mp_stop_iteration(mp); /* this procedure is in Part 34 below */
14817 @ @<Expand the token after the next token@>=
14819 p=mp_cur_tok(mp); get_t_next;
14820 if ( mp->cur_cmd<min_command ) mp_expand(mp);
14821 else mp_back_input(mp);
14825 @ @<Put a string into the input buffer@>=
14826 { mp_get_x_next(mp); mp_scan_primary(mp);
14827 if ( mp->cur_type!=mp_string_type ) {
14828 mp_disp_err(mp, null,"Not a string");
14830 help2("I'm going to flush this expression, since")
14831 ("scantokens should be followed by a known string.");
14832 mp_put_get_flush_error(mp, 0);
14835 if ( length(mp->cur_exp)>0 )
14836 @<Pretend we're reading a new one-line file@>;
14840 @ @<Pretend we're reading a new one-line file@>=
14841 { mp_begin_file_reading(mp); name=is_scantok;
14842 k=mp->first+length(mp->cur_exp);
14843 if ( k>=mp->max_buf_stack ) {
14844 while ( k>=mp->buf_size ) {
14845 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
14847 mp->max_buf_stack=k+1;
14849 j=mp->str_start[mp->cur_exp]; limit=k;
14850 while ( mp->first<(size_t)limit ) {
14851 mp->buffer[mp->first]=mp->str_pool[j]; incr(j); incr(mp->first);
14853 mp->buffer[limit]='%'; mp->first=limit+1; loc=start;
14854 mp_flush_cur_exp(mp, 0);
14857 @ Here finally is |get_x_next|.
14859 The expression scanning routines to be considered later
14860 communicate via the global quantities |cur_type| and |cur_exp|;
14861 we must be very careful to save and restore these quantities while
14862 macros are being expanded.
14866 void mp_get_x_next (MP mp);
14868 @ @c void mp_get_x_next (MP mp) {
14869 pointer save_exp; /* a capsule to save |cur_type| and |cur_exp| */
14871 if ( mp->cur_cmd<min_command ) {
14872 save_exp=mp_stash_cur_exp(mp);
14874 if ( mp->cur_cmd==defined_macro )
14875 mp_macro_call(mp, mp->cur_mod,null,mp->cur_sym);
14879 } while (mp->cur_cmd<min_command);
14880 mp_unstash_cur_exp(mp, save_exp); /* that restores |cur_type| and |cur_exp| */
14884 @ Now let's consider the |macro_call| procedure, which is used to start up
14885 all user-defined macros. Since the arguments to a macro might be expressions,
14886 |macro_call| is recursive.
14889 The first parameter to |macro_call| points to the reference count of the
14890 token list that defines the macro. The second parameter contains any
14891 arguments that have already been parsed (see below). The third parameter
14892 points to the symbolic token that names the macro. If the third parameter
14893 is |null|, the macro was defined by \&{vardef}, so its name can be
14894 reconstructed from the prefix and ``at'' arguments found within the
14897 What is this second parameter? It's simply a linked list of one-word items,
14898 whose |info| fields point to the arguments. In other words, if |arg_list=null|,
14899 no arguments have been scanned yet; otherwise |info(arg_list)| points to
14900 the first scanned argument, and |link(arg_list)| points to the list of
14901 further arguments (if any).
14903 Arguments of type \&{expr} are so-called capsules, which we will
14904 discuss later when we concentrate on expressions; they can be
14905 recognized easily because their |link| field is |void|. Arguments of type
14906 \&{suffix} and \&{text} are token lists without reference counts.
14908 @ After argument scanning is complete, the arguments are moved to the
14909 |param_stack|. (They can't be put on that stack any sooner, because
14910 the stack is growing and shrinking in unpredictable ways as more arguments
14911 are being acquired.) Then the macro body is fed to the scanner; i.e.,
14912 the replacement text of the macro is placed at the top of the \MP's
14913 input stack, so that |get_t_next| will proceed to read it next.
14915 @<Declare the procedure called |macro_call|@>=
14916 @<Declare the procedure called |print_macro_name|@>
14917 @<Declare the procedure called |print_arg|@>
14918 @<Declare the procedure called |scan_text_arg|@>
14919 void mp_macro_call (MP mp,pointer def_ref, pointer arg_list,
14920 pointer macro_name) ;
14923 void mp_macro_call (MP mp,pointer def_ref, pointer arg_list,
14924 pointer macro_name) {
14925 /* invokes a user-defined control sequence */
14926 pointer r; /* current node in the macro's token list */
14927 pointer p,q; /* for list manipulation */
14928 integer n; /* the number of arguments */
14929 pointer tail = 0; /* tail of the argument list */
14930 pointer l_delim=0,r_delim=0; /* a delimiter pair */
14931 r=link(def_ref); add_mac_ref(def_ref);
14932 if ( arg_list==null ) {
14935 @<Determine the number |n| of arguments already supplied,
14936 and set |tail| to the tail of |arg_list|@>;
14938 if ( mp->internal[mp_tracing_macros]>0 ) {
14939 @<Show the text of the macro being expanded, and the existing arguments@>;
14941 @<Scan the remaining arguments, if any; set |r| to the first token
14942 of the replacement text@>;
14943 @<Feed the arguments and replacement text to the scanner@>;
14946 @ @<Show the text of the macro...@>=
14947 mp_begin_diagnostic(mp); mp_print_ln(mp);
14948 mp_print_macro_name(mp, arg_list,macro_name);
14949 if ( n==3 ) mp_print(mp, "@@#"); /* indicate a suffixed macro */
14950 mp_show_macro(mp, def_ref,null,100000);
14951 if ( arg_list!=null ) {
14955 mp_print_arg(mp, q,n,0);
14956 incr(n); p=link(p);
14959 mp_end_diagnostic(mp, false)
14962 @ @<Declare the procedure called |print_macro_name|@>=
14963 void mp_print_macro_name (MP mp,pointer a, pointer n);
14966 void mp_print_macro_name (MP mp,pointer a, pointer n) {
14967 pointer p,q; /* they traverse the first part of |a| */
14973 mp_print_text(info(info(link(a))));
14976 while ( link(q)!=null ) q=link(q);
14977 link(q)=info(link(a));
14978 mp_show_token_list(mp, p,null,1000,0);
14984 @ @<Declare the procedure called |print_arg|@>=
14985 void mp_print_arg (MP mp,pointer q, integer n, pointer b) ;
14988 void mp_print_arg (MP mp,pointer q, integer n, pointer b) {
14989 if ( link(q)==mp_void ) mp_print_nl(mp, "(EXPR");
14990 else if ( (b<text_base)&&(b!=text_macro) ) mp_print_nl(mp, "(SUFFIX");
14991 else mp_print_nl(mp, "(TEXT");
14992 mp_print_int(mp, n); mp_print(mp, ")<-");
14993 if ( link(q)==mp_void ) mp_print_exp(mp, q,1);
14994 else mp_show_token_list(mp, q,null,1000,0);
14997 @ @<Determine the number |n| of arguments already supplied...@>=
14999 n=1; tail=arg_list;
15000 while ( link(tail)!=null ) {
15001 incr(n); tail=link(tail);
15005 @ @<Scan the remaining arguments, if any; set |r|...@>=
15006 mp->cur_cmd=comma+1; /* anything |<>comma| will do */
15007 while ( info(r)>=expr_base ) {
15008 @<Scan the delimited argument represented by |info(r)|@>;
15011 if ( mp->cur_cmd==comma ) {
15012 print_err("Too many arguments to ");
15013 @.Too many arguments...@>
15014 mp_print_macro_name(mp, arg_list,macro_name); mp_print_char(mp, ';');
15015 mp_print_nl(mp, " Missing `"); mp_print_text(r_delim);
15017 mp_print(mp, "' has been inserted");
15018 help3("I'm going to assume that the comma I just read was a")
15019 ("right delimiter, and then I'll begin expanding the macro.")
15020 ("You might want to delete some tokens before continuing.");
15023 if ( info(r)!=general_macro ) {
15024 @<Scan undelimited argument(s)@>;
15028 @ At this point, the reader will find it advisable to review the explanation
15029 of token list format that was presented earlier, paying special attention to
15030 the conventions that apply only at the beginning of a macro's token list.
15032 On the other hand, the reader will have to take the expression-parsing
15033 aspects of the following program on faith; we will explain |cur_type|
15034 and |cur_exp| later. (Several things in this program depend on each other,
15035 and it's necessary to jump into the circle somewhere.)
15037 @<Scan the delimited argument represented by |info(r)|@>=
15038 if ( mp->cur_cmd!=comma ) {
15040 if ( mp->cur_cmd!=left_delimiter ) {
15041 print_err("Missing argument to ");
15042 @.Missing argument...@>
15043 mp_print_macro_name(mp, arg_list,macro_name);
15044 help3("That macro has more parameters than you thought.")
15045 ("I'll continue by pretending that each missing argument")
15046 ("is either zero or null.");
15047 if ( info(r)>=suffix_base ) {
15048 mp->cur_exp=null; mp->cur_type=mp_token_list;
15050 mp->cur_exp=0; mp->cur_type=mp_known;
15052 mp_back_error(mp); mp->cur_cmd=right_delimiter;
15055 l_delim=mp->cur_sym; r_delim=mp->cur_mod;
15057 @<Scan the argument represented by |info(r)|@>;
15058 if ( mp->cur_cmd!=comma )
15059 @<Check that the proper right delimiter was present@>;
15061 @<Append the current expression to |arg_list|@>
15063 @ @<Check that the proper right delim...@>=
15064 if ( (mp->cur_cmd!=right_delimiter)||(mp->cur_mod!=l_delim) ) {
15065 if ( info(link(r))>=expr_base ) {
15066 mp_missing_err(mp, ",");
15068 help3("I've finished reading a macro argument and am about to")
15069 ("read another; the arguments weren't delimited correctly.")
15070 ("You might want to delete some tokens before continuing.");
15071 mp_back_error(mp); mp->cur_cmd=comma;
15073 mp_missing_err(mp, str(text(r_delim)));
15075 help2("I've gotten to the end of the macro parameter list.")
15076 ("You might want to delete some tokens before continuing.");
15081 @ A \&{suffix} or \&{text} parameter will have been scanned as
15082 a token list pointed to by |cur_exp|, in which case we will have
15083 |cur_type=token_list|.
15085 @<Append the current expression to |arg_list|@>=
15087 p=mp_get_avail(mp);
15088 if ( mp->cur_type==mp_token_list ) info(p)=mp->cur_exp;
15089 else info(p)=mp_stash_cur_exp(mp);
15090 if ( mp->internal[mp_tracing_macros]>0 ) {
15091 mp_begin_diagnostic(mp); mp_print_arg(mp, info(p),n,info(r));
15092 mp_end_diagnostic(mp, false);
15094 if ( arg_list==null ) arg_list=p;
15099 @ @<Scan the argument represented by |info(r)|@>=
15100 if ( info(r)>=text_base ) {
15101 mp_scan_text_arg(mp, l_delim,r_delim);
15104 if ( info(r)>=suffix_base ) mp_scan_suffix(mp);
15105 else mp_scan_expression(mp);
15108 @ The parameters to |scan_text_arg| are either a pair of delimiters
15109 or zero; the latter case is for undelimited text arguments, which
15110 end with the first semicolon or \&{endgroup} or \&{end} that is not
15111 contained in a group.
15113 @<Declare the procedure called |scan_text_arg|@>=
15114 void mp_scan_text_arg (MP mp,pointer l_delim, pointer r_delim) ;
15117 void mp_scan_text_arg (MP mp,pointer l_delim, pointer r_delim) {
15118 integer balance; /* excess of |l_delim| over |r_delim| */
15119 pointer p; /* list tail */
15120 mp->warning_info=l_delim; mp->scanner_status=absorbing;
15121 p=hold_head; balance=1; link(hold_head)=null;
15124 if ( l_delim==0 ) {
15125 @<Adjust the balance for an undelimited argument; |break| if done@>;
15127 @<Adjust the balance for a delimited argument; |break| if done@>;
15129 link(p)=mp_cur_tok(mp); p=link(p);
15131 mp->cur_exp=link(hold_head); mp->cur_type=mp_token_list;
15132 mp->scanner_status=normal;
15135 @ @<Adjust the balance for a delimited argument...@>=
15136 if ( mp->cur_cmd==right_delimiter ) {
15137 if ( mp->cur_mod==l_delim ) {
15139 if ( balance==0 ) break;
15141 } else if ( mp->cur_cmd==left_delimiter ) {
15142 if ( mp->cur_mod==r_delim ) incr(balance);
15145 @ @<Adjust the balance for an undelimited...@>=
15146 if ( end_of_statement ) { /* |cur_cmd=semicolon|, |end_group|, or |stop| */
15147 if ( balance==1 ) { break; }
15148 else { if ( mp->cur_cmd==end_group ) decr(balance); }
15149 } else if ( mp->cur_cmd==begin_group ) {
15153 @ @<Scan undelimited argument(s)@>=
15155 if ( info(r)<text_macro ) {
15157 if ( info(r)!=suffix_macro ) {
15158 if ( (mp->cur_cmd==equals)||(mp->cur_cmd==assignment) ) mp_get_x_next(mp);
15162 case primary_macro:mp_scan_primary(mp); break;
15163 case secondary_macro:mp_scan_secondary(mp); break;
15164 case tertiary_macro:mp_scan_tertiary(mp); break;
15165 case expr_macro:mp_scan_expression(mp); break;
15167 @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>;
15170 @<Scan a suffix with optional delimiters@>;
15172 case text_macro:mp_scan_text_arg(mp, 0,0); break;
15173 } /* there are no other cases */
15175 @<Append the current expression to |arg_list|@>;
15178 @ @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>=
15180 mp_scan_expression(mp); p=mp_get_avail(mp); info(p)=mp_stash_cur_exp(mp);
15181 if ( mp->internal[mp_tracing_macros]>0 ) {
15182 mp_begin_diagnostic(mp); mp_print_arg(mp, info(p),n,0);
15183 mp_end_diagnostic(mp, false);
15185 if ( arg_list==null ) arg_list=p; else link(tail)=p;
15187 if ( mp->cur_cmd!=of_token ) {
15188 mp_missing_err(mp, "of"); mp_print(mp, " for ");
15190 mp_print_macro_name(mp, arg_list,macro_name);
15191 help1("I've got the first argument; will look now for the other.");
15194 mp_get_x_next(mp); mp_scan_primary(mp);
15197 @ @<Scan a suffix with optional delimiters@>=
15199 if ( mp->cur_cmd!=left_delimiter ) {
15202 l_delim=mp->cur_sym; r_delim=mp->cur_mod; mp_get_x_next(mp);
15204 mp_scan_suffix(mp);
15205 if ( l_delim!=null ) {
15206 if ((mp->cur_cmd!=right_delimiter)||(mp->cur_mod!=l_delim) ) {
15207 mp_missing_err(mp, str(text(r_delim)));
15209 help2("I've gotten to the end of the macro parameter list.")
15210 ("You might want to delete some tokens before continuing.");
15217 @ Before we put a new token list on the input stack, it is wise to clean off
15218 all token lists that have recently been depleted. Then a user macro that ends
15219 with a call to itself will not require unbounded stack space.
15221 @<Feed the arguments and replacement text to the scanner@>=
15222 while ( token_state &&(loc==null) ) mp_end_token_list(mp); /* conserve stack space */
15223 if ( mp->param_ptr+n>mp->max_param_stack ) {
15224 mp->max_param_stack=mp->param_ptr+n;
15225 if ( mp->max_param_stack>mp->param_size )
15226 mp_overflow(mp, "parameter stack size",mp->param_size);
15227 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
15229 mp_begin_token_list(mp, def_ref,macro); name=macro_name; loc=r;
15233 mp->param_stack[mp->param_ptr]=info(p); incr(mp->param_ptr); p=link(p);
15235 mp_flush_list(mp, arg_list);
15238 @ It's sometimes necessary to put a single argument onto |param_stack|.
15239 The |stack_argument| subroutine does this.
15241 @c void mp_stack_argument (MP mp,pointer p) {
15242 if ( mp->param_ptr==mp->max_param_stack ) {
15243 incr(mp->max_param_stack);
15244 if ( mp->max_param_stack>mp->param_size )
15245 mp_overflow(mp, "parameter stack size",mp->param_size);
15246 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
15248 mp->param_stack[mp->param_ptr]=p; incr(mp->param_ptr);
15251 @* \[33] Conditional processing.
15252 Let's consider now the way \&{if} commands are handled.
15254 Conditions can be inside conditions, and this nesting has a stack
15255 that is independent of other stacks.
15256 Four global variables represent the top of the condition stack:
15257 |cond_ptr| points to pushed-down entries, if~any; |cur_if| tells whether
15258 we are processing \&{if} or \&{elseif}; |if_limit| specifies
15259 the largest code of a |fi_or_else| command that is syntactically legal;
15260 and |if_line| is the line number at which the current conditional began.
15262 If no conditions are currently in progress, the condition stack has the
15263 special state |cond_ptr=null|, |if_limit=normal|, |cur_if=0|, |if_line=0|.
15264 Otherwise |cond_ptr| points to a two-word node; the |type|, |name_type|, and
15265 |link| fields of the first word contain |if_limit|, |cur_if|, and
15266 |cond_ptr| at the next level, and the second word contains the
15267 corresponding |if_line|.
15269 @d if_node_size 2 /* number of words in stack entry for conditionals */
15270 @d if_line_field(A) mp->mem[(A)+1].cint
15271 @d if_code 1 /* code for \&{if} being evaluated */
15272 @d fi_code 2 /* code for \&{fi} */
15273 @d else_code 3 /* code for \&{else} */
15274 @d else_if_code 4 /* code for \&{elseif} */
15277 pointer cond_ptr; /* top of the condition stack */
15278 integer if_limit; /* upper bound on |fi_or_else| codes */
15279 small_number cur_if; /* type of conditional being worked on */
15280 integer if_line; /* line where that conditional began */
15283 mp->cond_ptr=null; mp->if_limit=normal; mp->cur_if=0; mp->if_line=0;
15286 mp_primitive(mp, "if",if_test,if_code);
15287 @:if_}{\&{if} primitive@>
15288 mp_primitive(mp, "fi",fi_or_else,fi_code); mp->eqtb[frozen_fi]=mp->eqtb[mp->cur_sym];
15289 @:fi_}{\&{fi} primitive@>
15290 mp_primitive(mp, "else",fi_or_else,else_code);
15291 @:else_}{\&{else} primitive@>
15292 mp_primitive(mp, "elseif",fi_or_else,else_if_code);
15293 @:else_if_}{\&{elseif} primitive@>
15295 @ @<Cases of |print_cmd_mod|...@>=
15299 case if_code:mp_print(mp, "if"); break;
15300 case fi_code:mp_print(mp, "fi"); break;
15301 case else_code:mp_print(mp, "else"); break;
15302 default: mp_print(mp, "elseif"); break;
15306 @ Here is a procedure that ignores text until coming to an \&{elseif},
15307 \&{else}, or \&{fi} at level zero of $\&{if}\ldots\&{fi}$
15308 nesting. After it has acted, |cur_mod| will indicate the token that
15311 \MP's smallest two command codes are |if_test| and |fi_or_else|; this
15312 makes the skipping process a bit simpler.
15315 void mp_pass_text (MP mp) {
15317 mp->scanner_status=skipping;
15318 mp->warning_info=mp_true_line(mp);
15321 if ( mp->cur_cmd<=fi_or_else ) {
15322 if ( mp->cur_cmd<fi_or_else ) {
15326 if ( mp->cur_mod==fi_code ) decr(l);
15329 @<Decrease the string reference count,
15330 if the current token is a string@>;
15333 mp->scanner_status=normal;
15336 @ @<Decrease the string reference count...@>=
15337 if ( mp->cur_cmd==string_token ) { delete_str_ref(mp->cur_mod); }
15339 @ When we begin to process a new \&{if}, we set |if_limit:=if_code|; then
15340 if \&{elseif} or \&{else} or \&{fi} occurs before the current \&{if}
15341 condition has been evaluated, a colon will be inserted.
15342 A construction like `\.{if fi}' would otherwise get \MP\ confused.
15344 @<Push the condition stack@>=
15345 { p=mp_get_node(mp, if_node_size); link(p)=mp->cond_ptr; type(p)=mp->if_limit;
15346 name_type(p)=mp->cur_if; if_line_field(p)=mp->if_line;
15347 mp->cond_ptr=p; mp->if_limit=if_code; mp->if_line=mp_true_line(mp);
15348 mp->cur_if=if_code;
15351 @ @<Pop the condition stack@>=
15352 { p=mp->cond_ptr; mp->if_line=if_line_field(p);
15353 mp->cur_if=name_type(p); mp->if_limit=type(p); mp->cond_ptr=link(p);
15354 mp_free_node(mp, p,if_node_size);
15357 @ Here's a procedure that changes the |if_limit| code corresponding to
15358 a given value of |cond_ptr|.
15360 @c void mp_change_if_limit (MP mp,small_number l, pointer p) {
15362 if ( p==mp->cond_ptr ) {
15363 mp->if_limit=l; /* that's the easy case */
15367 if ( q==null ) mp_confusion(mp, "if");
15368 @:this can't happen if}{\quad if@>
15369 if ( link(q)==p ) {
15377 @ The user is supposed to put colons into the proper parts of conditional
15378 statements. Therefore, \MP\ has to check for their presence.
15381 void mp_check_colon (MP mp) {
15382 if ( mp->cur_cmd!=colon ) {
15383 mp_missing_err(mp, ":");
15385 help2("There should've been a colon after the condition.")
15386 ("I shall pretend that one was there.");;
15391 @ A condition is started when the |get_x_next| procedure encounters
15392 an |if_test| command; in that case |get_x_next| calls |conditional|,
15393 which is a recursive procedure.
15396 @c void mp_conditional (MP mp) {
15397 pointer save_cond_ptr; /* |cond_ptr| corresponding to this conditional */
15398 int new_if_limit; /* future value of |if_limit| */
15399 pointer p; /* temporary register */
15400 @<Push the condition stack@>;
15401 save_cond_ptr=mp->cond_ptr;
15403 mp_get_boolean(mp); new_if_limit=else_if_code;
15404 if ( mp->internal[mp_tracing_commands]>unity ) {
15405 @<Display the boolean value of |cur_exp|@>;
15408 mp_check_colon(mp);
15409 if ( mp->cur_exp==true_code ) {
15410 mp_change_if_limit(mp, new_if_limit,save_cond_ptr);
15411 return; /* wait for \&{elseif}, \&{else}, or \&{fi} */
15413 @<Skip to \&{elseif} or \&{else} or \&{fi}, then |goto done|@>;
15415 mp->cur_if=mp->cur_mod; mp->if_line=mp_true_line(mp);
15416 if ( mp->cur_mod==fi_code ) {
15417 @<Pop the condition stack@>
15418 } else if ( mp->cur_mod==else_if_code ) {
15421 mp->cur_exp=true_code; new_if_limit=fi_code; mp_get_x_next(mp);
15426 @ In a construction like `\&{if} \&{if} \&{true}: $0=1$: \\{foo}
15427 \&{else}: \\{bar} \&{fi}', the first \&{else}
15428 that we come to after learning that the \&{if} is false is not the
15429 \&{else} we're looking for. Hence the following curious logic is needed.
15431 @<Skip to \&{elseif}...@>=
15434 if ( mp->cond_ptr==save_cond_ptr ) goto DONE;
15435 else if ( mp->cur_mod==fi_code ) @<Pop the condition stack@>;
15439 @ @<Display the boolean value...@>=
15440 { mp_begin_diagnostic(mp);
15441 if ( mp->cur_exp==true_code ) mp_print(mp, "{true}");
15442 else mp_print(mp, "{false}");
15443 mp_end_diagnostic(mp, false);
15446 @ The processing of conditionals is complete except for the following
15447 code, which is actually part of |get_x_next|. It comes into play when
15448 \&{elseif}, \&{else}, or \&{fi} is scanned.
15450 @<Terminate the current conditional and skip to \&{fi}@>=
15451 if ( mp->cur_mod>mp->if_limit ) {
15452 if ( mp->if_limit==if_code ) { /* condition not yet evaluated */
15453 mp_missing_err(mp, ":");
15455 mp_back_input(mp); mp->cur_sym=frozen_colon; mp_ins_error(mp);
15457 print_err("Extra "); mp_print_cmd_mod(mp, fi_or_else,mp->cur_mod);
15461 help1("I'm ignoring this; it doesn't match any if.");
15465 while ( mp->cur_mod!=fi_code ) mp_pass_text(mp); /* skip to \&{fi} */
15466 @<Pop the condition stack@>;
15469 @* \[34] Iterations.
15470 To bring our treatment of |get_x_next| to a close, we need to consider what
15471 \MP\ does when it sees \&{for}, \&{forsuffixes}, and \&{forever}.
15473 There's a global variable |loop_ptr| that keeps track of the \&{for} loops
15474 that are currently active. If |loop_ptr=null|, no loops are in progress;
15475 otherwise |info(loop_ptr)| points to the iterative text of the current
15476 (innermost) loop, and |link(loop_ptr)| points to the data for any other
15477 loops that enclose the current one.
15479 A loop-control node also has two other fields, called |loop_type| and
15480 |loop_list|, whose contents depend on the type of loop:
15482 \yskip\indent|loop_type(loop_ptr)=null| means that |loop_list(loop_ptr)|
15483 points to a list of one-word nodes whose |info| fields point to the
15484 remaining argument values of a suffix list and expression list.
15486 \yskip\indent|loop_type(loop_ptr)=mp_void| means that the current loop is
15489 \yskip\indent|loop_type(loop_ptr)=progression_flag| means that
15490 |p=loop_list(loop_ptr)| points to a ``progression node'' and |value(p)|,
15491 |step_size(p)|, and |final_value(p)| contain the data for an arithmetic
15494 \yskip\indent|loop_type(loop_ptr)=p>mp_void| means that |p| points to an edge
15495 header and |loop_list(loop_ptr)| points into the graphical object list for
15498 \yskip\noindent In the case of a progression node, the first word is not used
15499 because the link field of words in the dynamic memory area cannot be arbitrary.
15501 @d loop_list_loc(A) ((A)+1) /* where the |loop_list| field resides */
15502 @d loop_type(A) info(loop_list_loc((A))) /* the type of \&{for} loop */
15503 @d loop_list(A) link(loop_list_loc((A))) /* the remaining list elements */
15504 @d loop_node_size 2 /* the number of words in a loop control node */
15505 @d progression_node_size 4 /* the number of words in a progression node */
15506 @d step_size(A) mp->mem[(A)+2].sc /* the step size in an arithmetic progression */
15507 @d final_value(A) mp->mem[(A)+3].sc /* the final value in an arithmetic progression */
15508 @d progression_flag (null+2)
15509 /* |loop_type| value when |loop_list| points to a progression node */
15512 pointer loop_ptr; /* top of the loop-control-node stack */
15517 @ If the expressions that define an arithmetic progression in
15518 a \&{for} loop don't have known numeric values, the |bad_for|
15519 subroutine screams at the user.
15521 @c void mp_bad_for (MP mp, const char * s) {
15522 mp_disp_err(mp, null,"Improper "); /* show the bad expression above the message */
15523 @.Improper...replaced by 0@>
15524 mp_print(mp, s); mp_print(mp, " has been replaced by 0");
15525 help4("When you say `for x=a step b until c',")
15526 ("the initial value `a' and the step size `b'")
15527 ("and the final value `c' must have known numeric values.")
15528 ("I'm zeroing this one. Proceed, with fingers crossed.");
15529 mp_put_get_flush_error(mp, 0);
15532 @ Here's what \MP\ does when \&{for}, \&{forsuffixes}, or \&{forever}
15533 has just been scanned. (This code requires slight familiarity with
15534 expression-parsing routines that we have not yet discussed; but it seems
15535 to belong in the present part of the program, even though the original author
15536 didn't write it until later. The reader may wish to come back to it.)
15538 @c void mp_begin_iteration (MP mp) {
15539 halfword m; /* |expr_base| (\&{for}) or |suffix_base| (\&{forsuffixes}) */
15540 halfword n; /* hash address of the current symbol */
15541 pointer s; /* the new loop-control node */
15542 pointer p; /* substitution list for |scan_toks| */
15543 pointer q; /* link manipulation register */
15544 pointer pp; /* a new progression node */
15545 m=mp->cur_mod; n=mp->cur_sym; s=mp_get_node(mp, loop_node_size);
15546 if ( m==start_forever ){
15547 loop_type(s)=mp_void; p=null; mp_get_x_next(mp);
15549 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
15550 info(p)=mp->cur_sym; value(p)=m;
15552 if ( mp->cur_cmd==within_token ) {
15553 @<Set up a picture iteration@>;
15555 @<Check for the |"="| or |":="| in a loop header@>;
15556 @<Scan the values to be used in the loop@>;
15559 @<Check for the presence of a colon@>;
15560 @<Scan the loop text and put it on the loop control stack@>;
15561 mp_resume_iteration(mp);
15564 @ @<Check for the |"="| or |":="| in a loop header@>=
15565 if ( (mp->cur_cmd!=equals)&&(mp->cur_cmd!=assignment) ) {
15566 mp_missing_err(mp, "=");
15568 help3("The next thing in this loop should have been `=' or `:='.")
15569 ("But don't worry; I'll pretend that an equals sign")
15570 ("was present, and I'll look for the values next.");
15574 @ @<Check for the presence of a colon@>=
15575 if ( mp->cur_cmd!=colon ) {
15576 mp_missing_err(mp, ":");
15578 help3("The next thing in this loop should have been a `:'.")
15579 ("So I'll pretend that a colon was present;")
15580 ("everything from here to `endfor' will be iterated.");
15584 @ We append a special |frozen_repeat_loop| token in place of the
15585 `\&{endfor}' at the end of the loop. This will come through \MP's scanner
15586 at the proper time to cause the loop to be repeated.
15588 (If the user tries some shenanigan like `\&{for} $\ldots$ \&{let} \&{endfor}',
15589 he will be foiled by the |get_symbol| routine, which keeps frozen
15590 tokens unchanged. Furthermore the |frozen_repeat_loop| is an \&{outer}
15591 token, so it won't be lost accidentally.)
15593 @ @<Scan the loop text...@>=
15594 q=mp_get_avail(mp); info(q)=frozen_repeat_loop;
15595 mp->scanner_status=loop_defining; mp->warning_info=n;
15596 info(s)=mp_scan_toks(mp, iteration,p,q,0); mp->scanner_status=normal;
15597 link(s)=mp->loop_ptr; mp->loop_ptr=s
15599 @ @<Initialize table...@>=
15600 eq_type(frozen_repeat_loop)=repeat_loop+outer_tag;
15601 text(frozen_repeat_loop)=intern(" ENDFOR");
15603 @ The loop text is inserted into \MP's scanning apparatus by the
15604 |resume_iteration| routine.
15606 @c void mp_resume_iteration (MP mp) {
15607 pointer p,q; /* link registers */
15608 p=loop_type(mp->loop_ptr);
15609 if ( p==progression_flag ) {
15610 p=loop_list(mp->loop_ptr); /* now |p| points to a progression node */
15611 mp->cur_exp=value(p);
15612 if ( @<The arithmetic progression has ended@> ) {
15613 mp_stop_iteration(mp);
15616 mp->cur_type=mp_known; q=mp_stash_cur_exp(mp); /* make |q| an \&{expr} argument */
15617 value(p)=mp->cur_exp+step_size(p); /* set |value(p)| for the next iteration */
15618 } else if ( p==null ) {
15619 p=loop_list(mp->loop_ptr);
15621 mp_stop_iteration(mp);
15624 loop_list(mp->loop_ptr)=link(p); q=info(p); free_avail(p);
15625 } else if ( p==mp_void ) {
15626 mp_begin_token_list(mp, info(mp->loop_ptr),forever_text); return;
15628 @<Make |q| a capsule containing the next picture component from
15629 |loop_list(loop_ptr)| or |goto not_found|@>;
15631 mp_begin_token_list(mp, info(mp->loop_ptr),loop_text);
15632 mp_stack_argument(mp, q);
15633 if ( mp->internal[mp_tracing_commands]>unity ) {
15634 @<Trace the start of a loop@>;
15638 mp_stop_iteration(mp);
15641 @ @<The arithmetic progression has ended@>=
15642 ((step_size(p)>0)&&(mp->cur_exp>final_value(p)))||
15643 ((step_size(p)<0)&&(mp->cur_exp<final_value(p)))
15645 @ @<Trace the start of a loop@>=
15647 mp_begin_diagnostic(mp); mp_print_nl(mp, "{loop value=");
15649 if ( (q!=null)&&(link(q)==mp_void) ) mp_print_exp(mp, q,1);
15650 else mp_show_token_list(mp, q,null,50,0);
15651 mp_print_char(mp, '}'); mp_end_diagnostic(mp, false);
15654 @ @<Make |q| a capsule containing the next picture component from...@>=
15655 { q=loop_list(mp->loop_ptr);
15656 if ( q==null ) goto NOT_FOUND;
15657 skip_component(q) goto NOT_FOUND;
15658 mp->cur_exp=mp_copy_objects(mp, loop_list(mp->loop_ptr),q);
15659 mp_init_bbox(mp, mp->cur_exp);
15660 mp->cur_type=mp_picture_type;
15661 loop_list(mp->loop_ptr)=q;
15662 q=mp_stash_cur_exp(mp);
15665 @ A level of loop control disappears when |resume_iteration| has decided
15666 not to resume, or when an \&{exitif} construction has removed the loop text
15667 from the input stack.
15669 @c void mp_stop_iteration (MP mp) {
15670 pointer p,q; /* the usual */
15671 p=loop_type(mp->loop_ptr);
15672 if ( p==progression_flag ) {
15673 mp_free_node(mp, loop_list(mp->loop_ptr),progression_node_size);
15674 } else if ( p==null ){
15675 q=loop_list(mp->loop_ptr);
15676 while ( q!=null ) {
15679 if ( link(p)==mp_void ) { /* it's an \&{expr} parameter */
15680 mp_recycle_value(mp, p); mp_free_node(mp, p,value_node_size);
15682 mp_flush_token_list(mp, p); /* it's a \&{suffix} or \&{text} parameter */
15685 p=q; q=link(q); free_avail(p);
15687 } else if ( p>progression_flag ) {
15688 delete_edge_ref(p);
15690 p=mp->loop_ptr; mp->loop_ptr=link(p); mp_flush_token_list(mp, info(p));
15691 mp_free_node(mp, p,loop_node_size);
15694 @ Now that we know all about loop control, we can finish up
15695 the missing portion of |begin_iteration| and we'll be done.
15697 The following code is performed after the `\.=' has been scanned in
15698 a \&{for} construction (if |m=expr_base|) or a \&{forsuffixes} construction
15699 (if |m=suffix_base|).
15701 @<Scan the values to be used in the loop@>=
15702 loop_type(s)=null; q=loop_list_loc(s); link(q)=null; /* |link(q)=loop_list(s)| */
15705 if ( m!=expr_base ) {
15706 mp_scan_suffix(mp);
15708 if ( mp->cur_cmd>=colon ) if ( mp->cur_cmd<=comma )
15710 mp_scan_expression(mp);
15711 if ( mp->cur_cmd==step_token ) if ( q==loop_list_loc(s) ) {
15712 @<Prepare for step-until construction and |break|@>;
15714 mp->cur_exp=mp_stash_cur_exp(mp);
15716 link(q)=mp_get_avail(mp); q=link(q);
15717 info(q)=mp->cur_exp; mp->cur_type=mp_vacuous;
15720 } while (mp->cur_cmd==comma)
15722 @ @<Prepare for step-until construction and |break|@>=
15724 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "initial value");
15725 pp=mp_get_node(mp, progression_node_size); value(pp)=mp->cur_exp;
15726 mp_get_x_next(mp); mp_scan_expression(mp);
15727 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "step size");
15728 step_size(pp)=mp->cur_exp;
15729 if ( mp->cur_cmd!=until_token ) {
15730 mp_missing_err(mp, "until");
15731 @.Missing `until'@>
15732 help2("I assume you meant to say `until' after `step'.")
15733 ("So I'll look for the final value and colon next.");
15736 mp_get_x_next(mp); mp_scan_expression(mp);
15737 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "final value");
15738 final_value(pp)=mp->cur_exp; loop_list(s)=pp;
15739 loop_type(s)=progression_flag;
15743 @ The last case is when we have just seen ``\&{within}'', and we need to
15744 parse a picture expression and prepare to iterate over it.
15746 @<Set up a picture iteration@>=
15747 { mp_get_x_next(mp);
15748 mp_scan_expression(mp);
15749 @<Make sure the current expression is a known picture@>;
15750 loop_type(s)=mp->cur_exp; mp->cur_type=mp_vacuous;
15751 q=link(dummy_loc(mp->cur_exp));
15753 if ( is_start_or_stop(q) )
15754 if ( mp_skip_1component(mp, q)==null ) q=link(q);
15758 @ @<Make sure the current expression is a known picture@>=
15759 if ( mp->cur_type!=mp_picture_type ) {
15760 mp_disp_err(mp, null,"Improper iteration spec has been replaced by nullpicture");
15761 help1("When you say `for x in p', p must be a known picture.");
15762 mp_put_get_flush_error(mp, mp_get_node(mp, edge_header_size));
15763 mp_init_edges(mp, mp->cur_exp); mp->cur_type=mp_picture_type;
15766 @* \[35] File names.
15767 It's time now to fret about file names. Besides the fact that different
15768 operating systems treat files in different ways, we must cope with the
15769 fact that completely different naming conventions are used by different
15770 groups of people. The following programs show what is required for one
15771 particular operating system; similar routines for other systems are not
15772 difficult to devise.
15773 @^system dependencies@>
15775 \MP\ assumes that a file name has three parts: the name proper; its
15776 ``extension''; and a ``file area'' where it is found in an external file
15777 system. The extension of an input file is assumed to be
15778 `\.{.mp}' unless otherwise specified; it is `\.{.log}' on the
15779 transcript file that records each run of \MP; it is `\.{.tfm}' on the font
15780 metric files that describe characters in any fonts created by \MP; it is
15781 `\.{.ps}' or `.{\it nnn}' for some number {\it nnn} on the \ps\ output files;
15782 and it is `\.{.mem}' on the mem files written by \.{INIMP} to initialize \MP.
15783 The file area can be arbitrary on input files, but files are usually
15784 output to the user's current area. If an input file cannot be
15785 found on the specified area, \MP\ will look for it on a special system
15786 area; this special area is intended for commonly used input files.
15788 Simple uses of \MP\ refer only to file names that have no explicit
15789 extension or area. For example, a person usually says `\.{input} \.{cmr10}'
15790 instead of `\.{input} \.{cmr10.new}'. Simple file
15791 names are best, because they make the \MP\ source files portable;
15792 whenever a file name consists entirely of letters and digits, it should be
15793 treated in the same way by all implementations of \MP. However, users
15794 need the ability to refer to other files in their environment, especially
15795 when responding to error messages concerning unopenable files; therefore
15796 we want to let them use the syntax that appears in their favorite
15799 @ \MP\ uses the same conventions that have proved to be satisfactory for
15800 \TeX\ and \MF. In order to isolate the system-dependent aspects of file names,
15801 @^system dependencies@>
15802 the system-independent parts of \MP\ are expressed in terms
15803 of three system-dependent
15804 procedures called |begin_name|, |more_name|, and |end_name|. In
15805 essence, if the user-specified characters of the file name are $c_1\ldots c_n$,
15806 the system-independent driver program does the operations
15807 $$|begin_name|;\,|more_name|(c_1);\,\ldots\,;\,|more_name|(c_n);
15809 These three procedures communicate with each other via global variables.
15810 Afterwards the file name will appear in the string pool as three strings
15811 called |cur_name|\penalty10000\hskip-.05em,
15812 |cur_area|, and |cur_ext|; the latter two are null (i.e.,
15813 |""|), unless they were explicitly specified by the user.
15815 Actually the situation is slightly more complicated, because \MP\ needs
15816 to know when the file name ends. The |more_name| routine is a function
15817 (with side effects) that returns |true| on the calls |more_name|$(c_1)$,
15818 \dots, |more_name|$(c_{n-1})$. The final call |more_name|$(c_n)$
15819 returns |false|; or, it returns |true| and $c_n$ is the last character
15820 on the current input line. In other words,
15821 |more_name| is supposed to return |true| unless it is sure that the
15822 file name has been completely scanned; and |end_name| is supposed to be able
15823 to finish the assembly of |cur_name|, |cur_area|, and |cur_ext| regardless of
15824 whether $|more_name|(c_n)$ returned |true| or |false|.
15827 char * cur_name; /* name of file just scanned */
15828 char * cur_area; /* file area just scanned, or \.{""} */
15829 char * cur_ext; /* file extension just scanned, or \.{""} */
15831 @ It is easier to maintain reference counts if we assign initial values.
15834 mp->cur_name=xstrdup("");
15835 mp->cur_area=xstrdup("");
15836 mp->cur_ext=xstrdup("");
15838 @ @<Dealloc variables@>=
15839 xfree(mp->cur_area);
15840 xfree(mp->cur_name);
15841 xfree(mp->cur_ext);
15843 @ The file names we shall deal with for illustrative purposes have the
15844 following structure: If the name contains `\.>' or `\.:', the file area
15845 consists of all characters up to and including the final such character;
15846 otherwise the file area is null. If the remaining file name contains
15847 `\..', the file extension consists of all such characters from the first
15848 remaining `\..' to the end, otherwise the file extension is null.
15849 @^system dependencies@>
15851 We can scan such file names easily by using two global variables that keep track
15852 of the occurrences of area and extension delimiters. Note that these variables
15853 cannot be of type |pool_pointer| because a string pool compaction could occur
15854 while scanning a file name.
15857 integer area_delimiter;
15858 /* most recent `\.>' or `\.:' relative to |str_start[str_ptr]| */
15859 integer ext_delimiter; /* the relevant `\..', if any */
15861 @ Here now is the first of the system-dependent routines for file name scanning.
15862 @^system dependencies@>
15864 The file name length is limited to |file_name_size|. That is good, because
15865 in the current configuration we cannot call |mp_do_compaction| while a name
15866 is being scanned, |mp->area_delimiter| and |mp->ext_delimiter| are direct
15867 offsets into |mp->str_pool|. I am not in a great hurry to fix this, because
15868 calling |str_room()| just once is more efficient anyway. TODO.
15870 @<Declare subroutines for parsing file names@>=
15871 void mp_begin_name (MP mp) {
15872 xfree(mp->cur_name);
15873 xfree(mp->cur_area);
15874 xfree(mp->cur_ext);
15875 mp->area_delimiter=-1;
15876 mp->ext_delimiter=-1;
15877 str_room(file_name_size);
15880 @ And here's the second.
15881 @^system dependencies@>
15883 @<Declare subroutines for parsing file names@>=
15884 boolean mp_more_name (MP mp, ASCII_code c) {
15888 if ( (c=='>')||(c==':') ) {
15889 mp->area_delimiter=mp->pool_ptr;
15890 mp->ext_delimiter=-1;
15891 } else if ( (c=='.')&&(mp->ext_delimiter<0) ) {
15892 mp->ext_delimiter=mp->pool_ptr;
15894 append_char(c); /* contribute |c| to the current string */
15900 @^system dependencies@>
15902 @d copy_pool_segment(A,B,C) {
15903 A = xmalloc(C+1,sizeof(char));
15904 strncpy(A,(char *)(mp->str_pool+B),C);
15907 @<Declare subroutines for parsing file names@>=
15908 void mp_end_name (MP mp) {
15909 pool_pointer s; /* length of area, name, and extension */
15912 s = mp->str_start[mp->str_ptr];
15913 if ( mp->area_delimiter<0 ) {
15914 mp->cur_area=xstrdup("");
15916 len = mp->area_delimiter-s;
15917 copy_pool_segment(mp->cur_area,s,len);
15920 if ( mp->ext_delimiter<0 ) {
15921 mp->cur_ext=xstrdup("");
15922 len = mp->pool_ptr-s;
15924 copy_pool_segment(mp->cur_ext,mp->ext_delimiter,(mp->pool_ptr-mp->ext_delimiter));
15925 len = mp->ext_delimiter-s;
15927 copy_pool_segment(mp->cur_name,s,len);
15928 mp->pool_ptr=s; /* don't need this partial string */
15931 @ Conversely, here is a routine that takes three strings and prints a file
15932 name that might have produced them. (The routine is system dependent, because
15933 some operating systems put the file area last instead of first.)
15934 @^system dependencies@>
15936 @<Basic printing...@>=
15937 void mp_print_file_name (MP mp, char * n, char * a, char * e) {
15938 mp_print(mp, a); mp_print(mp, n); mp_print(mp, e);
15941 @ Another system-dependent routine is needed to convert three internal
15943 to the |name_of_file| value that is used to open files. The present code
15944 allows both lowercase and uppercase letters in the file name.
15945 @^system dependencies@>
15947 @d append_to_name(A) { c=(A);
15948 if ( k<file_name_size ) {
15949 mp->name_of_file[k]=xchr(c);
15954 @<Declare subroutines for parsing file names@>=
15955 void mp_pack_file_name (MP mp, const char *n, const char *a, const char *e) {
15956 integer k; /* number of positions filled in |name_of_file| */
15957 ASCII_code c; /* character being packed */
15958 const char *j; /* a character index */
15962 for (j=a;*j;j++) { append_to_name(*j); }
15964 for (j=n;*j;j++) { append_to_name(*j); }
15966 for (j=e;*j;j++) { append_to_name(*j); }
15968 mp->name_of_file[k]=0;
15972 @ @<Internal library declarations@>=
15973 void mp_pack_file_name (MP mp, const char *n, const char *a, const char *e) ;
15975 @ A messier routine is also needed, since mem file names must be scanned
15976 before \MP's string mechanism has been initialized. We shall use the
15977 global variable |MP_mem_default| to supply the text for default system areas
15978 and extensions related to mem files.
15979 @^system dependencies@>
15981 @d mem_default_length 9 /* length of the |MP_mem_default| string */
15982 @d mem_ext_length 4 /* length of its `\.{.mem}' part */
15983 @d mem_extension ".mem" /* the extension, as a \.{WEB} constant */
15986 char *MP_mem_default;
15988 @ @<Option variables@>=
15989 char *mem_name; /* for commandline */
15991 @ @<Allocate or initialize ...@>=
15992 mp->MP_mem_default = xstrdup("plain.mem");
15994 mp->mem_name = xstrdup(opt->mem_name);
15995 if (mp->mem_name) {
15996 int l = strlen(mp->mem_name);
15998 char *test = strstr(mp->mem_name,".mem");
15999 if (test == mp->mem_name+l-4) {
16006 @ @<Dealloc variables@>=
16007 xfree(mp->MP_mem_default);
16008 xfree(mp->mem_name);
16010 @ @<Check the ``constant'' values for consistency@>=
16011 if ( mem_default_length>file_name_size ) mp->bad=20;
16013 @ Here is the messy routine that was just mentioned. It sets |name_of_file|
16014 from the first |n| characters of |MP_mem_default|, followed by
16015 |buffer[a..b-1]|, followed by the last |mem_ext_length| characters of
16018 We dare not give error messages here, since \MP\ calls this routine before
16019 the |error| routine is ready to roll. Instead, we simply drop excess characters,
16020 since the error will be detected in another way when a strange file name
16022 @^system dependencies@>
16024 @c void mp_pack_buffered_name (MP mp,small_number n, integer a,
16026 integer k; /* number of positions filled in |name_of_file| */
16027 ASCII_code c; /* character being packed */
16028 integer j; /* index into |buffer| or |MP_mem_default| */
16029 if ( n+b-a+1+mem_ext_length>file_name_size )
16030 b=a+file_name_size-n-1-mem_ext_length;
16032 for (j=0;j<n;j++) {
16033 append_to_name(xord((int)mp->MP_mem_default[j]));
16035 for (j=a;j<b;j++) {
16036 append_to_name(mp->buffer[j]);
16038 for (j=mem_default_length-mem_ext_length;
16039 j<mem_default_length;j++) {
16040 append_to_name(xord((int)mp->MP_mem_default[j]));
16042 mp->name_of_file[k]=0;
16046 @ Here is the only place we use |pack_buffered_name|. This part of the program
16047 becomes active when a ``virgin'' \MP\ is trying to get going, just after
16048 the preliminary initialization, or when the user is substituting another
16049 mem file by typing `\.\&' after the initial `\.{**}' prompt. The buffer
16050 contains the first line of input in |buffer[loc..(last-1)]|, where
16051 |loc<last| and |buffer[loc]<>" "|.
16054 boolean mp_open_mem_file (MP mp) ;
16057 boolean mp_open_mem_file (MP mp) {
16058 int j; /* the first space after the file name */
16059 if (mp->mem_name!=NULL) {
16060 int l = strlen(mp->mem_name);
16061 char *s = xstrdup (mp->mem_name);
16063 char *test = strstr(s,".mem");
16064 if (test == NULL || test != s+l-4) {
16065 s = xrealloc (s, l+5, 1);
16066 strcat (s, ".mem");
16069 s = xrealloc (s, l+5, 1);
16070 strcat (s, ".mem");
16072 mp->mem_file = (mp->open_file)(mp,s, "r", mp_filetype_memfile);
16074 if ( mp->mem_file ) return true;
16077 if ( mp->buffer[loc]=='&' ) {
16078 incr(loc); j=loc; mp->buffer[mp->last]=' ';
16079 while ( mp->buffer[j]!=' ' ) incr(j);
16080 mp_pack_buffered_name(mp, 0,loc,j); /* try first without the system file area */
16081 if ( mp_w_open_in(mp, &mp->mem_file) ) goto FOUND;
16083 wterm_ln("Sorry, I can\'t find that mem file; will try PLAIN.");
16084 @.Sorry, I can't find...@>
16087 /* now pull out all the stops: try for the system \.{plain} file */
16088 mp_pack_buffered_name(mp, mem_default_length-mem_ext_length,0,0);
16089 if ( ! mp_w_open_in(mp, &mp->mem_file) ) {
16091 wterm_ln("I can\'t find the PLAIN mem file!\n");
16092 @.I can't find PLAIN...@>
16097 loc=j; return true;
16100 @ Operating systems often make it possible to determine the exact name (and
16101 possible version number) of a file that has been opened. The following routine,
16102 which simply makes a \MP\ string from the value of |name_of_file|, should
16103 ideally be changed to deduce the full name of file~|f|, which is the file
16104 most recently opened, if it is possible to do this.
16105 @^system dependencies@>
16108 #define mp_a_make_name_string(A,B) mp_make_name_string(A)
16109 #define mp_b_make_name_string(A,B) mp_make_name_string(A)
16110 #define mp_w_make_name_string(A,B) mp_make_name_string(A)
16113 str_number mp_make_name_string (MP mp) {
16114 int k; /* index into |name_of_file| */
16115 str_room(mp->name_length);
16116 for (k=0;k<mp->name_length;k++) {
16117 append_char(xord((int)mp->name_of_file[k]));
16119 return mp_make_string(mp);
16122 @ Now let's consider the ``driver''
16123 routines by which \MP\ deals with file names
16124 in a system-independent manner. First comes a procedure that looks for a
16125 file name in the input by taking the information from the input buffer.
16126 (We can't use |get_next|, because the conversion to tokens would
16127 destroy necessary information.)
16129 This procedure doesn't allow semicolons or percent signs to be part of
16130 file names, because of other conventions of \MP.
16131 {\sl The {\logos METAFONT\/}book} doesn't
16132 use semicolons or percents immediately after file names, but some users
16133 no doubt will find it natural to do so; therefore system-dependent
16134 changes to allow such characters in file names should probably
16135 be made with reluctance, and only when an entire file name that
16136 includes special characters is ``quoted'' somehow.
16137 @^system dependencies@>
16139 @c void mp_scan_file_name (MP mp) {
16141 while ( mp->buffer[loc]==' ' ) incr(loc);
16143 if ( (mp->buffer[loc]==';')||(mp->buffer[loc]=='%') ) break;
16144 if ( ! mp_more_name(mp, mp->buffer[loc]) ) break;
16150 @ Here is another version that takes its input from a string.
16152 @<Declare subroutines for parsing file names@>=
16153 void mp_str_scan_file (MP mp, str_number s) {
16154 pool_pointer p,q; /* current position and stopping point */
16156 p=mp->str_start[s]; q=str_stop(s);
16158 if ( ! mp_more_name(mp, mp->str_pool[p]) ) break;
16164 @ And one that reads from a |char*|.
16166 @<Declare subroutines for parsing file names@>=
16167 void mp_ptr_scan_file (MP mp, char *s) {
16168 char *p, *q; /* current position and stopping point */
16170 p=s; q=p+strlen(s);
16172 if ( ! mp_more_name(mp, *p)) break;
16179 @ The global variable |job_name| contains the file name that was first
16180 \&{input} by the user. This name is extended by `\.{.log}' and `\.{ps}' and
16181 `\.{.mem}' and `\.{.tfm}' in order to make the names of \MP's output files.
16184 boolean log_opened; /* has the transcript file been opened? */
16185 char *log_name; /* full name of the log file */
16187 @ @<Option variables@>=
16188 char *job_name; /* principal file name */
16190 @ Initially |job_name=NULL|; it becomes nonzero as soon as the true name is known.
16191 We have |job_name=NULL| if and only if the `\.{log}' file has not been opened,
16192 except of course for a short time just after |job_name| has become nonzero.
16194 @<Allocate or ...@>=
16195 mp->job_name=mp_xstrdup(mp, opt->job_name);
16196 if (opt->noninteractive && opt->ini_version) {
16197 if (mp->job_name == NULL)
16198 mp->job_name=mp_xstrdup(mp,mp->mem_name);
16199 int l = strlen(mp->job_name);
16201 char *test = strstr(mp->job_name,".mem");
16202 if (test == mp->job_name+l-4) {
16207 mp->log_opened=false;
16209 @ @<Dealloc variables@>=
16210 xfree(mp->job_name);
16212 @ Here is a routine that manufactures the output file names, assuming that
16213 |job_name<>0|. It ignores and changes the current settings of |cur_area|
16216 @d pack_cur_name mp_pack_file_name(mp, mp->cur_name,mp->cur_area,mp->cur_ext)
16219 void mp_pack_job_name (MP mp, const char *s) ;
16222 void mp_pack_job_name (MP mp, const char *s) { /* |s = ".log"|, |".mem"|, |".ps"|, or .\\{nnn} */
16223 xfree(mp->cur_name); mp->cur_name=xstrdup(mp->job_name);
16224 xfree(mp->cur_area); mp->cur_area=xstrdup("");
16225 xfree(mp->cur_ext); mp->cur_ext=xstrdup(s);
16229 @ If some trouble arises when \MP\ tries to open a file, the following
16230 routine calls upon the user to supply another file name. Parameter~|s|
16231 is used in the error message to identify the type of file; parameter~|e|
16232 is the default extension if none is given. Upon exit from the routine,
16233 variables |cur_name|, |cur_area|, |cur_ext|, and |name_of_file| are
16234 ready for another attempt at file opening.
16237 void mp_prompt_file_name (MP mp, const char * s, const char * e) ;
16239 @ @c void mp_prompt_file_name (MP mp, const char * s, const char * e) {
16240 size_t k; /* index into |buffer| */
16241 char * saved_cur_name;
16242 if ( mp->interaction==mp_scroll_mode )
16244 if (strcmp(s,"input file name")==0) {
16245 print_err("I can\'t find file `");
16246 @.I can't find file x@>
16248 print_err("I can\'t write on file `");
16250 @.I can't write on file x@>
16251 mp_print_file_name(mp, mp->cur_name,mp->cur_area,mp->cur_ext);
16252 mp_print(mp, "'.");
16253 if (strcmp(e,"")==0)
16254 mp_show_context(mp);
16255 mp_print_nl(mp, "Please type another "); mp_print(mp, s);
16257 if ( mp->interaction<mp_scroll_mode )
16258 mp_fatal_error(mp, "*** (job aborted, file error in nonstop mode)");
16259 @.job aborted, file error...@>
16260 saved_cur_name = xstrdup(mp->cur_name);
16261 clear_terminal; prompt_input(": "); @<Scan file name in the buffer@>;
16262 if (strcmp(mp->cur_ext,"")==0)
16263 mp->cur_ext=xstrdup(e);
16264 if (strlen(mp->cur_name)==0) {
16265 mp->cur_name=saved_cur_name;
16267 xfree(saved_cur_name);
16272 @ @<Scan file name in the buffer@>=
16274 mp_begin_name(mp); k=mp->first;
16275 while ( (mp->buffer[k]==' ')&&(k<mp->last) ) incr(k);
16277 if ( k==mp->last ) break;
16278 if ( ! mp_more_name(mp, mp->buffer[k]) ) break;
16284 @ The |open_log_file| routine is used to open the transcript file and to help
16285 it catch up to what has previously been printed on the terminal.
16287 @c void mp_open_log_file (MP mp) {
16288 int old_setting; /* previous |selector| setting */
16289 int k; /* index into |months| and |buffer| */
16290 int l; /* end of first input line */
16291 integer m; /* the current month */
16292 const char *months="JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC";
16293 /* abbreviations of month names */
16294 old_setting=mp->selector;
16295 if ( mp->job_name==NULL ) {
16296 mp->job_name=xstrdup("mpout");
16298 mp_pack_job_name(mp,".log");
16299 while ( ! mp_a_open_out(mp, &mp->log_file, mp_filetype_log) ) {
16300 @<Try to get a different log file name@>;
16302 mp->log_name=xstrdup(mp->name_of_file);
16303 mp->selector=log_only; mp->log_opened=true;
16304 @<Print the banner line, including the date and time@>;
16305 mp->input_stack[mp->input_ptr]=mp->cur_input;
16306 /* make sure bottom level is in memory */
16307 if (!mp->noninteractive) {
16308 mp_print_nl(mp, "**");
16310 l=mp->input_stack[0].limit_field-1; /* last position of first line */
16311 for (k=0;k<=l;k++) mp_print_str(mp, mp->buffer[k]);
16312 mp_print_ln(mp); /* now the transcript file contains the first line of input */
16314 mp->selector=old_setting+2; /* |log_only| or |term_and_log| */
16317 @ @<Dealloc variables@>=
16318 xfree(mp->log_name);
16320 @ Sometimes |open_log_file| is called at awkward moments when \MP\ is
16321 unable to print error messages or even to |show_context|.
16322 The |prompt_file_name| routine can result in a |fatal_error|, but the |error|
16323 routine will not be invoked because |log_opened| will be false.
16325 The normal idea of |mp_batch_mode| is that nothing at all should be written
16326 on the terminal. However, in the unusual case that
16327 no log file could be opened, we make an exception and allow
16328 an explanatory message to be seen.
16330 Incidentally, the program always refers to the log file as a `\.{transcript
16331 file}', because some systems cannot use the extension `\.{.log}' for
16334 @<Try to get a different log file name@>=
16336 mp->selector=term_only;
16337 mp_prompt_file_name(mp, "transcript file name",".log");
16340 @ @<Print the banner...@>=
16343 mp_print(mp, mp->mem_ident); mp_print(mp, " ");
16344 mp_print_int(mp, mp_round_unscaled(mp, mp->internal[mp_day]));
16345 mp_print_char(mp, ' ');
16346 m=mp_round_unscaled(mp, mp->internal[mp_month]);
16347 for (k=3*m-3;k<3*m;k++) { wlog_chr(months[k]); }
16348 mp_print_char(mp, ' ');
16349 mp_print_int(mp, mp_round_unscaled(mp, mp->internal[mp_year]));
16350 mp_print_char(mp, ' ');
16351 m=mp_round_unscaled(mp, mp->internal[mp_time]);
16352 mp_print_dd(mp, m / 60); mp_print_char(mp, ':'); mp_print_dd(mp, m % 60);
16355 @ The |try_extension| function tries to open an input file determined by
16356 |cur_name|, |cur_area|, and the argument |ext|. It returns |false| if it
16357 can't find the file in |cur_area| or the appropriate system area.
16359 @c boolean mp_try_extension (MP mp, const char *ext) {
16360 mp_pack_file_name(mp, mp->cur_name,mp->cur_area, ext);
16361 in_name=xstrdup(mp->cur_name);
16362 in_area=xstrdup(mp->cur_area);
16363 if ( mp_a_open_in(mp, &cur_file, mp_filetype_program) ) {
16366 mp_pack_file_name(mp, mp->cur_name,NULL,ext);
16367 return mp_a_open_in(mp, &cur_file, mp_filetype_program);
16371 @ Let's turn now to the procedure that is used to initiate file reading
16372 when an `\.{input}' command is being processed.
16374 @c void mp_start_input (MP mp) { /* \MP\ will \.{input} something */
16375 char *fname = NULL;
16376 @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>;
16378 mp_begin_file_reading(mp); /* set up |cur_file| and new level of input */
16379 if ( strlen(mp->cur_ext)==0 ) {
16380 if ( mp_try_extension(mp, ".mp") ) break;
16381 else if ( mp_try_extension(mp, "") ) break;
16382 else if ( mp_try_extension(mp, ".mf") ) break;
16383 /* |else do_nothing; | */
16384 } else if ( mp_try_extension(mp, mp->cur_ext) ) {
16387 mp_end_file_reading(mp); /* remove the level that didn't work */
16388 mp_prompt_file_name(mp, "input file name","");
16390 name=mp_a_make_name_string(mp, cur_file);
16391 fname = xstrdup(mp->name_of_file);
16392 if ( mp->job_name==NULL ) {
16393 mp->job_name=xstrdup(mp->cur_name);
16394 mp_open_log_file(mp);
16395 } /* |open_log_file| doesn't |show_context|, so |limit|
16396 and |loc| needn't be set to meaningful values yet */
16397 if ( ((int)mp->term_offset+(int)strlen(fname)) > (mp->max_print_line-2)) mp_print_ln(mp);
16398 else if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_char(mp, ' ');
16399 mp_print_char(mp, '('); incr(mp->open_parens); mp_print(mp, fname);
16402 @<Flush |name| and replace it with |cur_name| if it won't be needed@>;
16403 @<Read the first line of the new file@>;
16406 @ This code should be omitted if |a_make_name_string| returns something other
16407 than just a copy of its argument and the full file name is needed for opening
16408 \.{MPX} files or implementing the switch-to-editor option.
16409 @^system dependencies@>
16411 @<Flush |name| and replace it with |cur_name| if it won't be needed@>=
16412 mp_flush_string(mp, name); name=rts(mp->cur_name); xfree(mp->cur_name)
16414 @ If the file is empty, it is considered to contain a single blank line,
16415 so there is no need to test the return value.
16417 @<Read the first line...@>=
16420 (void)mp_input_ln(mp, cur_file );
16421 mp_firm_up_the_line(mp);
16422 mp->buffer[limit]='%'; mp->first=limit+1; loc=start;
16425 @ @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>=
16426 while ( token_state &&(loc==null) ) mp_end_token_list(mp);
16427 if ( token_state ) {
16428 print_err("File names can't appear within macros");
16429 @.File names can't...@>
16430 help3("Sorry...I've converted what follows to tokens,")
16431 ("possibly garbaging the name you gave.")
16432 ("Please delete the tokens and insert the name again.");
16435 if ( file_state ) {
16436 mp_scan_file_name(mp);
16438 xfree(mp->cur_name); mp->cur_name=xstrdup("");
16439 xfree(mp->cur_ext); mp->cur_ext =xstrdup("");
16440 xfree(mp->cur_area); mp->cur_area=xstrdup("");
16443 @ The following simple routine starts reading the \.{MPX} file associated
16444 with the current input file.
16446 @c void mp_start_mpx_input (MP mp) {
16447 char *origname = NULL; /* a copy of nameoffile */
16448 mp_pack_file_name(mp, in_name, in_area, ".mpx");
16449 @<Try to make sure |name_of_file| refers to a valid \.{MPX} file and
16450 |goto not_found| if there is a problem@>;
16451 mp_begin_file_reading(mp);
16452 if ( ! mp_a_open_in(mp, &cur_file, mp_filetype_program) ) {
16453 mp_end_file_reading(mp);
16456 name=mp_a_make_name_string(mp, cur_file);
16457 mp->mpx_name[index]=name; add_str_ref(name);
16458 @<Read the first line of the new file@>;
16462 @<Explain that the \.{MPX} file can't be read and |succumb|@>;
16466 @ This should ideally be changed to do whatever is necessary to create the
16467 \.{MPX} file given by |name_of_file| if it does not exist or if it is out
16468 of date. This requires invoking \.{MPtoTeX} on the |origname| and passing
16469 the results through \TeX\ and \.{DVItoMP}. (It is possible to use a
16470 completely different typesetting program if suitable postprocessor is
16471 available to perform the function of \.{DVItoMP}.)
16472 @^system dependencies@>
16474 @ @<Exported types@>=
16475 typedef int (*mp_run_make_mpx_command)(MP mp, char *origname, char *mtxname);
16477 @ @<Option variables@>=
16478 mp_run_make_mpx_command run_make_mpx;
16480 @ @<Allocate or initialize ...@>=
16481 set_callback_option(run_make_mpx);
16483 @ @<Internal library declarations@>=
16484 int mp_run_make_mpx (MP mp, char *origname, char *mtxname);
16486 @ The default does nothing.
16488 int mp_run_make_mpx (MP mp, char *origname, char *mtxname) {
16495 @ @<Try to make sure |name_of_file| refers to a valid \.{MPX} file and
16496 |goto not_found| if there is a problem@>=
16497 origname = mp_xstrdup(mp,mp->name_of_file);
16498 *(origname+strlen(origname)-1)=0; /* drop the x */
16499 if (!(mp->run_make_mpx)(mp, origname, mp->name_of_file))
16502 @ @<Explain that the \.{MPX} file can't be read and |succumb|@>=
16503 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
16504 mp_print_nl(mp, ">> ");
16505 mp_print(mp, origname);
16506 mp_print_nl(mp, ">> ");
16507 mp_print(mp, mp->name_of_file);
16508 mp_print_nl(mp, "! Unable to make mpx file");
16509 help4("The two files given above are one of your source files")
16510 ("and an auxiliary file I need to read to find out what your")
16511 ("btex..etex blocks mean. If you don't know why I had trouble,")
16512 ("try running it manually through MPtoTeX, TeX, and DVItoMP");
16515 @ The last file-opening commands are for files accessed via the \&{readfrom}
16516 @:read_from_}{\&{readfrom} primitive@>
16517 operator and the \&{write} command. Such files are stored in separate arrays.
16518 @:write_}{\&{write} primitive@>
16520 @<Types in the outer block@>=
16521 typedef unsigned int readf_index; /* |0..max_read_files| */
16522 typedef unsigned int write_index; /* |0..max_write_files| */
16525 readf_index max_read_files; /* maximum number of simultaneously open \&{readfrom} files */
16526 void ** rd_file; /* \&{readfrom} files */
16527 char ** rd_fname; /* corresponding file name or 0 if file not open */
16528 readf_index read_files; /* number of valid entries in the above arrays */
16529 write_index max_write_files; /* maximum number of simultaneously open \&{write} */
16530 void ** wr_file; /* \&{write} files */
16531 char ** wr_fname; /* corresponding file name or 0 if file not open */
16532 write_index write_files; /* number of valid entries in the above arrays */
16534 @ @<Allocate or initialize ...@>=
16535 mp->max_read_files=8;
16536 mp->rd_file = xmalloc((mp->max_read_files+1),sizeof(void *));
16537 mp->rd_fname = xmalloc((mp->max_read_files+1),sizeof(char *));
16538 memset(mp->rd_fname, 0, sizeof(char *)*(mp->max_read_files+1));
16540 mp->max_write_files=8;
16541 mp->wr_file = xmalloc((mp->max_write_files+1),sizeof(void *));
16542 mp->wr_fname = xmalloc((mp->max_write_files+1),sizeof(char *));
16543 memset(mp->wr_fname, 0, sizeof(char *)*(mp->max_write_files+1));
16547 @ This routine starts reading the file named by string~|s| without setting
16548 |loc|, |limit|, or |name|. It returns |false| if the file is empty or cannot
16549 be opened. Otherwise it updates |rd_file[n]| and |rd_fname[n]|.
16551 @c boolean mp_start_read_input (MP mp,char *s, readf_index n) {
16552 mp_ptr_scan_file(mp, s);
16554 mp_begin_file_reading(mp);
16555 if ( ! mp_a_open_in(mp, &mp->rd_file[n], (mp_filetype_text+n)) )
16557 if ( ! mp_input_ln(mp, mp->rd_file[n] ) ) {
16558 (mp->close_file)(mp,mp->rd_file[n]);
16561 mp->rd_fname[n]=xstrdup(mp->name_of_file);
16564 mp_end_file_reading(mp);
16568 @ Open |wr_file[n]| using file name~|s| and update |wr_fname[n]|.
16571 void mp_open_write_file (MP mp, char *s, readf_index n) ;
16573 @ @c void mp_open_write_file (MP mp,char *s, readf_index n) {
16574 mp_ptr_scan_file(mp, s);
16576 while ( ! mp_a_open_out(mp, &mp->wr_file[n], (mp_filetype_text+n)) )
16577 mp_prompt_file_name(mp, "file name for write output","");
16578 mp->wr_fname[n]=xstrdup(mp->name_of_file);
16582 @* \[36] Introduction to the parsing routines.
16583 We come now to the central nervous system that sparks many of \MP's activities.
16584 By evaluating expressions, from their primary constituents to ever larger
16585 subexpressions, \MP\ builds the structures that ultimately define complete
16586 pictures or fonts of type.
16588 Four mutually recursive subroutines are involved in this process: We call them
16589 $$\hbox{|scan_primary|, |scan_secondary|, |scan_tertiary|,
16590 and |scan_expression|.}$$
16592 Each of them is parameterless and begins with the first token to be scanned
16593 already represented in |cur_cmd|, |cur_mod|, and |cur_sym|. After execution,
16594 the value of the primary or secondary or tertiary or expression that was
16595 found will appear in the global variables |cur_type| and |cur_exp|. The
16596 token following the expression will be represented in |cur_cmd|, |cur_mod|,
16599 Technically speaking, the parsing algorithms are ``LL(1),'' more or less;
16600 backup mechanisms have been added in order to provide reasonable error
16604 small_number cur_type; /* the type of the expression just found */
16605 integer cur_exp; /* the value of the expression just found */
16610 @ Many different kinds of expressions are possible, so it is wise to have
16611 precise descriptions of what |cur_type| and |cur_exp| mean in all cases:
16614 |cur_type=mp_vacuous| means that this expression didn't turn out to have a
16615 value at all, because it arose from a \&{begingroup}$\,\ldots\,$\&{endgroup}
16616 construction in which there was no expression before the \&{endgroup}.
16617 In this case |cur_exp| has some irrelevant value.
16620 |cur_type=mp_boolean_type| means that |cur_exp| is either |true_code|
16624 |cur_type=mp_unknown_boolean| means that |cur_exp| points to a capsule
16626 a ring of equivalent booleans whose value has not yet been defined.
16629 |cur_type=mp_string_type| means that |cur_exp| is a string number (i.e., an
16630 integer in the range |0<=cur_exp<str_ptr|). That string's reference count
16631 includes this particular reference.
16634 |cur_type=mp_unknown_string| means that |cur_exp| points to a capsule
16636 a ring of equivalent strings whose value has not yet been defined.
16639 |cur_type=mp_pen_type| means that |cur_exp| points to a node in a pen. Nobody
16640 else points to any of the nodes in this pen. The pen may be polygonal or
16644 |cur_type=mp_unknown_pen| means that |cur_exp| points to a capsule
16646 a ring of equivalent pens whose value has not yet been defined.
16649 |cur_type=mp_path_type| means that |cur_exp| points to a the first node of
16650 a path; nobody else points to this particular path. The control points of
16651 the path will have been chosen.
16654 |cur_type=mp_unknown_path| means that |cur_exp| points to a capsule
16656 a ring of equivalent paths whose value has not yet been defined.
16659 |cur_type=mp_picture_type| means that |cur_exp| points to an edge header node.
16660 There may be other pointers to this particular set of edges. The header node
16661 contains a reference count that includes this particular reference.
16664 |cur_type=mp_unknown_picture| means that |cur_exp| points to a capsule
16666 a ring of equivalent pictures whose value has not yet been defined.
16669 |cur_type=mp_transform_type| means that |cur_exp| points to a |mp_transform_type|
16670 capsule node. The |value| part of this capsule
16671 points to a transform node that contains six numeric values,
16672 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16675 |cur_type=mp_color_type| means that |cur_exp| points to a |color_type|
16676 capsule node. The |value| part of this capsule
16677 points to a color node that contains three numeric values,
16678 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16681 |cur_type=mp_cmykcolor_type| means that |cur_exp| points to a |mp_cmykcolor_type|
16682 capsule node. The |value| part of this capsule
16683 points to a color node that contains four numeric values,
16684 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16687 |cur_type=mp_pair_type| means that |cur_exp| points to a capsule
16688 node whose type is |mp_pair_type|. The |value| part of this capsule
16689 points to a pair node that contains two numeric values,
16690 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16693 |cur_type=mp_known| means that |cur_exp| is a |scaled| value.
16696 |cur_type=mp_dependent| means that |cur_exp| points to a capsule node whose type
16697 is |dependent|. The |dep_list| field in this capsule points to the associated
16701 |cur_type=mp_proto_dependent| means that |cur_exp| points to a |mp_proto_dependent|
16702 capsule node. The |dep_list| field in this capsule
16703 points to the associated dependency list.
16706 |cur_type=independent| means that |cur_exp| points to a capsule node
16707 whose type is |independent|. This somewhat unusual case can arise, for
16708 example, in the expression
16709 `$x+\&{begingroup}\penalty0\,\&{string}\,x; 0\,\&{endgroup}$'.
16712 |cur_type=mp_token_list| means that |cur_exp| points to a linked list of
16715 \smallskip\noindent
16716 The possible settings of |cur_type| have been listed here in increasing
16717 numerical order. Notice that |cur_type| will never be |mp_numeric_type| or
16718 |suffixed_macro| or |mp_unsuffixed_macro|, although variables of those types
16719 are allowed. Conversely, \MP\ has no variables of type |mp_vacuous| or
16722 @ Capsules are two-word nodes that have a similar meaning
16723 to |cur_type| and |cur_exp|. Such nodes have |name_type=capsule|,
16724 and their |type| field is one of the possibilities for |cur_type| listed above.
16725 Also |link<=void| in capsules that aren't part of a token list.
16727 The |value| field of a capsule is, in most cases, the value that
16728 corresponds to its |type|, as |cur_exp| corresponds to |cur_type|.
16729 However, when |cur_exp| would point to a capsule,
16730 no extra layer of indirection is present; the |value|
16731 field is what would have been called |value(cur_exp)| if it had not been
16732 encapsulated. Furthermore, if the type is |dependent| or
16733 |mp_proto_dependent|, the |value| field of a capsule is replaced by
16734 |dep_list| and |prev_dep| fields, since dependency lists in capsules are
16735 always part of the general |dep_list| structure.
16737 The |get_x_next| routine is careful not to change the values of |cur_type|
16738 and |cur_exp| when it gets an expanded token. However, |get_x_next| might
16739 call a macro, which might parse an expression, which might execute lots of
16740 commands in a group; hence it's possible that |cur_type| might change
16741 from, say, |mp_unknown_boolean| to |mp_boolean_type|, or from |dependent| to
16742 |known| or |independent|, during the time |get_x_next| is called. The
16743 programs below are careful to stash sensitive intermediate results in
16744 capsules, so that \MP's generality doesn't cause trouble.
16746 Here's a procedure that illustrates these conventions. It takes
16747 the contents of $(|cur_type|\kern-.3pt,|cur_exp|\kern-.3pt)$
16748 and stashes them away in a
16749 capsule. It is not used when |cur_type=mp_token_list|.
16750 After the operation, |cur_type=mp_vacuous|; hence there is no need to
16751 copy path lists or to update reference counts, etc.
16753 The special link |mp_void| is put on the capsule returned by
16754 |stash_cur_exp|, because this procedure is used to store macro parameters
16755 that must be easily distinguishable from token lists.
16757 @<Declare the stashing/unstashing routines@>=
16758 pointer mp_stash_cur_exp (MP mp) {
16759 pointer p; /* the capsule that will be returned */
16760 switch (mp->cur_type) {
16761 case unknown_types:
16762 case mp_transform_type:
16763 case mp_color_type:
16766 case mp_proto_dependent:
16767 case mp_independent:
16768 case mp_cmykcolor_type:
16772 p=mp_get_node(mp, value_node_size); name_type(p)=mp_capsule;
16773 type(p)=mp->cur_type; value(p)=mp->cur_exp;
16776 mp->cur_type=mp_vacuous; link(p)=mp_void;
16780 @ The inverse of |stash_cur_exp| is the following procedure, which
16781 deletes an unnecessary capsule and puts its contents into |cur_type|
16784 The program steps of \MP\ can be divided into two categories: those in
16785 which |cur_type| and |cur_exp| are ``alive'' and those in which they are
16786 ``dead,'' in the sense that |cur_type| and |cur_exp| contain relevant
16787 information or not. It's important not to ignore them when they're alive,
16788 and it's important not to pay attention to them when they're dead.
16790 There's also an intermediate category: If |cur_type=mp_vacuous|, then
16791 |cur_exp| is irrelevant, hence we can proceed without caring if |cur_type|
16792 and |cur_exp| are alive or dead. In such cases we say that |cur_type|
16793 and |cur_exp| are {\sl dormant}. It is permissible to call |get_x_next|
16794 only when they are alive or dormant.
16796 The \\{stash} procedure above assumes that |cur_type| and |cur_exp|
16797 are alive or dormant. The \\{unstash} procedure assumes that they are
16798 dead or dormant; it resuscitates them.
16800 @<Declare the stashing/unstashing...@>=
16801 void mp_unstash_cur_exp (MP mp,pointer p) ;
16804 void mp_unstash_cur_exp (MP mp,pointer p) {
16805 mp->cur_type=type(p);
16806 switch (mp->cur_type) {
16807 case unknown_types:
16808 case mp_transform_type:
16809 case mp_color_type:
16812 case mp_proto_dependent:
16813 case mp_independent:
16814 case mp_cmykcolor_type:
16818 mp->cur_exp=value(p);
16819 mp_free_node(mp, p,value_node_size);
16824 @ The following procedure prints the values of expressions in an
16825 abbreviated format. If its first parameter |p| is null, the value of
16826 |(cur_type,cur_exp)| is displayed; otherwise |p| should be a capsule
16827 containing the desired value. The second parameter controls the amount of
16828 output. If it is~0, dependency lists will be abbreviated to
16829 `\.{linearform}' unless they consist of a single term. If it is greater
16830 than~1, complicated structures (pens, pictures, and paths) will be displayed
16834 @<Declare subroutines for printing expressions@>=
16835 @<Declare the procedure called |print_dp|@>
16836 @<Declare the stashing/unstashing routines@>
16837 void mp_print_exp (MP mp,pointer p, small_number verbosity) {
16838 boolean restore_cur_exp; /* should |cur_exp| be restored? */
16839 small_number t; /* the type of the expression */
16840 pointer q; /* a big node being displayed */
16841 integer v=0; /* the value of the expression */
16843 restore_cur_exp=false;
16845 p=mp_stash_cur_exp(mp); restore_cur_exp=true;
16848 if ( t<mp_dependent ) v=value(p); else if ( t<mp_independent ) v=dep_list(p);
16849 @<Print an abbreviated value of |v| with format depending on |t|@>;
16850 if ( restore_cur_exp ) mp_unstash_cur_exp(mp, p);
16853 @ @<Print an abbreviated value of |v| with format depending on |t|@>=
16855 case mp_vacuous:mp_print(mp, "mp_vacuous"); break;
16856 case mp_boolean_type:
16857 if ( v==true_code ) mp_print(mp, "true"); else mp_print(mp, "false");
16859 case unknown_types: case mp_numeric_type:
16860 @<Display a variable that's been declared but not defined@>;
16862 case mp_string_type:
16863 mp_print_char(mp, '"'); mp_print_str(mp, v); mp_print_char(mp, '"');
16865 case mp_pen_type: case mp_path_type: case mp_picture_type:
16866 @<Display a complex type@>;
16868 case mp_transform_type: case mp_color_type: case mp_pair_type: case mp_cmykcolor_type:
16869 if ( v==null ) mp_print_type(mp, t);
16870 else @<Display a big node@>;
16872 case mp_known:mp_print_scaled(mp, v); break;
16873 case mp_dependent: case mp_proto_dependent:
16874 mp_print_dp(mp, t,v,verbosity);
16876 case mp_independent:mp_print_variable_name(mp, p); break;
16877 default: mp_confusion(mp, "exp"); break;
16878 @:this can't happen exp}{\quad exp@>
16881 @ @<Display a big node@>=
16883 mp_print_char(mp, '('); q=v+mp->big_node_size[t];
16885 if ( type(v)==mp_known ) mp_print_scaled(mp, value(v));
16886 else if ( type(v)==mp_independent ) mp_print_variable_name(mp, v);
16887 else mp_print_dp(mp, type(v),dep_list(v),verbosity);
16889 if ( v!=q ) mp_print_char(mp, ',');
16891 mp_print_char(mp, ')');
16894 @ Values of type \&{picture}, \&{path}, and \&{pen} are displayed verbosely
16895 in the log file only, unless the user has given a positive value to
16898 @<Display a complex type@>=
16899 if ( verbosity<=1 ) {
16900 mp_print_type(mp, t);
16902 if ( mp->selector==term_and_log )
16903 if ( mp->internal[mp_tracing_online]<=0 ) {
16904 mp->selector=term_only;
16905 mp_print_type(mp, t); mp_print(mp, " (see the transcript file)");
16906 mp->selector=term_and_log;
16909 case mp_pen_type:mp_print_pen(mp, v,"",false); break;
16910 case mp_path_type:mp_print_path(mp, v,"",false); break;
16911 case mp_picture_type:mp_print_edges(mp, v,"",false); break;
16912 } /* there are no other cases */
16915 @ @<Declare the procedure called |print_dp|@>=
16916 void mp_print_dp (MP mp,small_number t, pointer p,
16917 small_number verbosity) {
16918 pointer q; /* the node following |p| */
16920 if ( (info(q)==null) || (verbosity>0) ) mp_print_dependency(mp, p,t);
16921 else mp_print(mp, "linearform");
16924 @ The displayed name of a variable in a ring will not be a capsule unless
16925 the ring consists entirely of capsules.
16927 @<Display a variable that's been declared but not defined@>=
16928 { mp_print_type(mp, t);
16930 { mp_print_char(mp, ' ');
16931 while ( (name_type(v)==mp_capsule) && (v!=p) ) v=value(v);
16932 mp_print_variable_name(mp, v);
16936 @ When errors are detected during parsing, it is often helpful to
16937 display an expression just above the error message, using |exp_err|
16938 or |disp_err| instead of |print_err|.
16940 @d exp_err(A) mp_disp_err(mp, null,(A)) /* displays the current expression */
16942 @<Declare subroutines for printing expressions@>=
16943 void mp_disp_err (MP mp,pointer p, const char *s) {
16944 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
16945 mp_print_nl(mp, ">> ");
16947 mp_print_exp(mp, p,1); /* ``medium verbose'' printing of the expression */
16949 mp_print_nl(mp, "! "); mp_print(mp, s);
16954 @ If |cur_type| and |cur_exp| contain relevant information that should
16955 be recycled, we will use the following procedure, which changes |cur_type|
16956 to |known| and stores a given value in |cur_exp|. We can think of |cur_type|
16957 and |cur_exp| as either alive or dormant after this has been done,
16958 because |cur_exp| will not contain a pointer value.
16960 @ @c void mp_flush_cur_exp (MP mp,scaled v) {
16961 switch (mp->cur_type) {
16962 case unknown_types: case mp_transform_type: case mp_color_type: case mp_pair_type:
16963 case mp_dependent: case mp_proto_dependent: case mp_independent: case mp_cmykcolor_type:
16964 mp_recycle_value(mp, mp->cur_exp);
16965 mp_free_node(mp, mp->cur_exp,value_node_size);
16967 case mp_string_type:
16968 delete_str_ref(mp->cur_exp); break;
16969 case mp_pen_type: case mp_path_type:
16970 mp_toss_knot_list(mp, mp->cur_exp); break;
16971 case mp_picture_type:
16972 delete_edge_ref(mp->cur_exp); break;
16976 mp->cur_type=mp_known; mp->cur_exp=v;
16979 @ There's a much more general procedure that is capable of releasing
16980 the storage associated with any two-word value packet.
16982 @<Declare the recycling subroutines@>=
16983 void mp_recycle_value (MP mp,pointer p) ;
16985 @ @c void mp_recycle_value (MP mp,pointer p) {
16986 small_number t; /* a type code */
16987 integer vv; /* another value */
16988 pointer q,r,s,pp; /* link manipulation registers */
16989 integer v=0; /* a value */
16991 if ( t<mp_dependent ) v=value(p);
16993 case undefined: case mp_vacuous: case mp_boolean_type: case mp_known:
16994 case mp_numeric_type:
16996 case unknown_types:
16997 mp_ring_delete(mp, p); break;
16998 case mp_string_type:
16999 delete_str_ref(v); break;
17000 case mp_path_type: case mp_pen_type:
17001 mp_toss_knot_list(mp, v); break;
17002 case mp_picture_type:
17003 delete_edge_ref(v); break;
17004 case mp_cmykcolor_type: case mp_pair_type: case mp_color_type:
17005 case mp_transform_type:
17006 @<Recycle a big node@>; break;
17007 case mp_dependent: case mp_proto_dependent:
17008 @<Recycle a dependency list@>; break;
17009 case mp_independent:
17010 @<Recycle an independent variable@>; break;
17011 case mp_token_list: case mp_structured:
17012 mp_confusion(mp, "recycle"); break;
17013 @:this can't happen recycle}{\quad recycle@>
17014 case mp_unsuffixed_macro: case mp_suffixed_macro:
17015 mp_delete_mac_ref(mp, value(p)); break;
17016 } /* there are no other cases */
17020 @ @<Recycle a big node@>=
17022 q=v+mp->big_node_size[t];
17024 q=q-2; mp_recycle_value(mp, q);
17026 mp_free_node(mp, v,mp->big_node_size[t]);
17029 @ @<Recycle a dependency list@>=
17032 while ( info(q)!=null ) q=link(q);
17033 link(prev_dep(p))=link(q);
17034 prev_dep(link(q))=prev_dep(p);
17035 link(q)=null; mp_flush_node_list(mp, dep_list(p));
17038 @ When an independent variable disappears, it simply fades away, unless
17039 something depends on it. In the latter case, a dependent variable whose
17040 coefficient of dependence is maximal will take its place.
17041 The relevant algorithm is due to Ignacio~A. Zabala, who implemented it
17042 as part of his Ph.D. thesis (Stanford University, December 1982).
17043 @^Zabala Salelles, Ignacio Andr\'es@>
17045 For example, suppose that variable $x$ is being recycled, and that the
17046 only variables depending on~$x$ are $y=2x+a$ and $z=x+b$. In this case
17047 we want to make $y$ independent and $z=.5y-.5a+b$; no other variables
17048 will depend on~$y$. If $\\{tracingequations}>0$ in this situation,
17049 we will print `\.{\#\#\# -2x=-y+a}'.
17051 There's a slight complication, however: An independent variable $x$
17052 can occur both in dependency lists and in proto-dependency lists.
17053 This makes it necessary to be careful when deciding which coefficient
17056 Furthermore, this complication is not so slight when
17057 a proto-dependent variable is chosen to become independent. For example,
17058 suppose that $y=2x+100a$ is proto-dependent while $z=x+b$ is dependent;
17059 then we must change $z=.5y-50a+b$ to a proto-dependency, because of the
17060 large coefficient `50'.
17062 In order to deal with these complications without wasting too much time,
17063 we shall link together the occurrences of~$x$ among all the linear
17064 dependencies, maintaining separate lists for the dependent and
17065 proto-dependent cases.
17067 @<Recycle an independent variable@>=
17069 mp->max_c[mp_dependent]=0; mp->max_c[mp_proto_dependent]=0;
17070 mp->max_link[mp_dependent]=null; mp->max_link[mp_proto_dependent]=null;
17072 while ( q!=dep_head ) {
17073 s=value_loc(q); /* now |link(s)=dep_list(q)| */
17076 if ( info(r)==null ) break;
17077 if ( info(r)!=p ) {
17080 t=type(q); link(s)=link(r); info(r)=q;
17081 if ( abs(value(r))>mp->max_c[t] ) {
17082 @<Record a new maximum coefficient of type |t|@>;
17084 link(r)=mp->max_link[t]; mp->max_link[t]=r;
17090 if ( (mp->max_c[mp_dependent]>0)||(mp->max_c[mp_proto_dependent]>0) ) {
17091 @<Choose a dependent variable to take the place of the disappearing
17092 independent variable, and change all remaining dependencies
17097 @ The code for independency removal makes use of three two-word arrays.
17100 integer max_c[mp_proto_dependent+1]; /* max coefficient magnitude */
17101 pointer max_ptr[mp_proto_dependent+1]; /* where |p| occurs with |max_c| */
17102 pointer max_link[mp_proto_dependent+1]; /* other occurrences of |p| */
17104 @ @<Record a new maximum coefficient...@>=
17106 if ( mp->max_c[t]>0 ) {
17107 link(mp->max_ptr[t])=mp->max_link[t]; mp->max_link[t]=mp->max_ptr[t];
17109 mp->max_c[t]=abs(value(r)); mp->max_ptr[t]=r;
17112 @ @<Choose a dependent...@>=
17114 if ( (mp->max_c[mp_dependent] / 010000) >= mp->max_c[mp_proto_dependent] )
17117 t=mp_proto_dependent;
17118 @<Determine the dependency list |s| to substitute for the independent
17120 t=mp_dependent+mp_proto_dependent-t; /* complement |t| */
17121 if ( mp->max_c[t]>0 ) { /* we need to pick up an unchosen dependency */
17122 link(mp->max_ptr[t])=mp->max_link[t]; mp->max_link[t]=mp->max_ptr[t];
17124 if ( t!=mp_dependent ) { @<Substitute new dependencies in place of |p|@>; }
17125 else { @<Substitute new proto-dependencies in place of |p|@>;}
17126 mp_flush_node_list(mp, s);
17127 if ( mp->fix_needed ) mp_fix_dependencies(mp);
17131 @ Let |s=max_ptr[t]|. At this point we have $|value|(s)=\pm|max_c|[t]$,
17132 and |info(s)| points to the dependent variable~|pp| of type~|t| from
17133 whose dependency list we have removed node~|s|. We must reinsert
17134 node~|s| into the dependency list, with coefficient $-1.0$, and with
17135 |pp| as the new independent variable. Since |pp| will have a larger serial
17136 number than any other variable, we can put node |s| at the head of the
17139 @<Determine the dep...@>=
17140 s=mp->max_ptr[t]; pp=info(s); v=value(s);
17141 if ( t==mp_dependent ) value(s)=-fraction_one; else value(s)=-unity;
17142 r=dep_list(pp); link(s)=r;
17143 while ( info(r)!=null ) r=link(r);
17144 q=link(r); link(r)=null;
17145 prev_dep(q)=prev_dep(pp); link(prev_dep(pp))=q;
17147 if ( mp->cur_exp==pp ) if ( mp->cur_type==t ) mp->cur_type=mp_independent;
17148 if ( mp->internal[mp_tracing_equations]>0 ) {
17149 @<Show the transformed dependency@>;
17152 @ Now $(-v)$ times the formerly independent variable~|p| is being replaced
17153 by the dependency list~|s|.
17155 @<Show the transformed...@>=
17156 if ( mp_interesting(mp, p) ) {
17157 mp_begin_diagnostic(mp); mp_print_nl(mp, "### ");
17158 @:]]]\#\#\#_}{\.{\#\#\#}@>
17159 if ( v>0 ) mp_print_char(mp, '-');
17160 if ( t==mp_dependent ) vv=mp_round_fraction(mp, mp->max_c[mp_dependent]);
17161 else vv=mp->max_c[mp_proto_dependent];
17162 if ( vv!=unity ) mp_print_scaled(mp, vv);
17163 mp_print_variable_name(mp, p);
17164 while ( value(p) % s_scale>0 ) {
17165 mp_print(mp, "*4"); value(p)=value(p)-2;
17167 if ( t==mp_dependent ) mp_print_char(mp, '='); else mp_print(mp, " = ");
17168 mp_print_dependency(mp, s,t);
17169 mp_end_diagnostic(mp, false);
17172 @ Finally, there are dependent and proto-dependent variables whose
17173 dependency lists must be brought up to date.
17175 @<Substitute new dependencies...@>=
17176 for (t=mp_dependent;t<=mp_proto_dependent;t++){
17178 while ( r!=null ) {
17180 dep_list(q)=mp_p_plus_fq(mp, dep_list(q),
17181 mp_make_fraction(mp, value(r),-v),s,t,mp_dependent);
17182 if ( dep_list(q)==mp->dep_final ) mp_make_known(mp, q,mp->dep_final);
17183 q=r; r=link(r); mp_free_node(mp, q,dep_node_size);
17187 @ @<Substitute new proto...@>=
17188 for (t=mp_dependent;t<=mp_proto_dependent;t++) {
17190 while ( r!=null ) {
17192 if ( t==mp_dependent ) { /* for safety's sake, we change |q| to |mp_proto_dependent| */
17193 if ( mp->cur_exp==q ) if ( mp->cur_type==mp_dependent )
17194 mp->cur_type=mp_proto_dependent;
17195 dep_list(q)=mp_p_over_v(mp, dep_list(q),unity,
17196 mp_dependent,mp_proto_dependent);
17197 type(q)=mp_proto_dependent;
17198 value(r)=mp_round_fraction(mp, value(r));
17200 dep_list(q)=mp_p_plus_fq(mp, dep_list(q),
17201 mp_make_scaled(mp, value(r),-v),s,
17202 mp_proto_dependent,mp_proto_dependent);
17203 if ( dep_list(q)==mp->dep_final )
17204 mp_make_known(mp, q,mp->dep_final);
17205 q=r; r=link(r); mp_free_node(mp, q,dep_node_size);
17209 @ Here are some routines that provide handy combinations of actions
17210 that are often needed during error recovery. For example,
17211 `|flush_error|' flushes the current expression, replaces it by
17212 a given value, and calls |error|.
17214 Errors often are detected after an extra token has already been scanned.
17215 The `\\{put\_get}' routines put that token back before calling |error|;
17216 then they get it back again. (Or perhaps they get another token, if
17217 the user has changed things.)
17220 void mp_flush_error (MP mp,scaled v);
17221 void mp_put_get_error (MP mp);
17222 void mp_put_get_flush_error (MP mp,scaled v) ;
17225 void mp_flush_error (MP mp,scaled v) {
17226 mp_error(mp); mp_flush_cur_exp(mp, v);
17228 void mp_put_get_error (MP mp) {
17229 mp_back_error(mp); mp_get_x_next(mp);
17231 void mp_put_get_flush_error (MP mp,scaled v) {
17232 mp_put_get_error(mp);
17233 mp_flush_cur_exp(mp, v);
17236 @ A global variable |var_flag| is set to a special command code
17237 just before \MP\ calls |scan_expression|, if the expression should be
17238 treated as a variable when this command code immediately follows. For
17239 example, |var_flag| is set to |assignment| at the beginning of a
17240 statement, because we want to know the {\sl location\/} of a variable at
17241 the left of `\.{:=}', not the {\sl value\/} of that variable.
17243 The |scan_expression| subroutine calls |scan_tertiary|,
17244 which calls |scan_secondary|, which calls |scan_primary|, which sets
17245 |var_flag:=0|. In this way each of the scanning routines ``knows''
17246 when it has been called with a special |var_flag|, but |var_flag| is
17249 A variable preceding a command that equals |var_flag| is converted to a
17250 token list rather than a value. Furthermore, an `\.{=}' sign following an
17251 expression with |var_flag=assignment| is not considered to be a relation
17252 that produces boolean expressions.
17256 int var_flag; /* command that wants a variable */
17261 @* \[37] Parsing primary expressions.
17262 The first parsing routine, |scan_primary|, is also the most complicated one,
17263 since it involves so many different cases. But each case---with one
17264 exception---is fairly simple by itself.
17266 When |scan_primary| begins, the first token of the primary to be scanned
17267 should already appear in |cur_cmd|, |cur_mod|, and |cur_sym|. The values
17268 of |cur_type| and |cur_exp| should be either dead or dormant, as explained
17269 earlier. If |cur_cmd| is not between |min_primary_command| and
17270 |max_primary_command|, inclusive, a syntax error will be signaled.
17272 @<Declare the basic parsing subroutines@>=
17273 void mp_scan_primary (MP mp) {
17274 pointer p,q,r; /* for list manipulation */
17275 quarterword c; /* a primitive operation code */
17276 int my_var_flag; /* initial value of |my_var_flag| */
17277 pointer l_delim,r_delim; /* hash addresses of a delimiter pair */
17278 @<Other local variables for |scan_primary|@>;
17279 my_var_flag=mp->var_flag; mp->var_flag=0;
17282 @<Supply diagnostic information, if requested@>;
17283 switch (mp->cur_cmd) {
17284 case left_delimiter:
17285 @<Scan a delimited primary@>; break;
17287 @<Scan a grouped primary@>; break;
17289 @<Scan a string constant@>; break;
17290 case numeric_token:
17291 @<Scan a primary that starts with a numeric token@>; break;
17293 @<Scan a nullary operation@>; break;
17294 case unary: case type_name: case cycle: case plus_or_minus:
17295 @<Scan a unary operation@>; break;
17296 case primary_binary:
17297 @<Scan a binary operation with `\&{of}' between its operands@>; break;
17299 @<Convert a suffix to a string@>; break;
17300 case internal_quantity:
17301 @<Scan an internal numeric quantity@>; break;
17302 case capsule_token:
17303 mp_make_exp_copy(mp, mp->cur_mod); break;
17305 @<Scan a variable primary; |goto restart| if it turns out to be a macro@>; break;
17307 mp_bad_exp(mp, "A primary"); goto RESTART; break;
17308 @.A primary expression...@>
17310 mp_get_x_next(mp); /* the routines |goto done| if they don't want this */
17312 if ( mp->cur_cmd==left_bracket ) {
17313 if ( mp->cur_type>=mp_known ) {
17314 @<Scan a mediation construction@>;
17321 @ Errors at the beginning of expressions are flagged by |bad_exp|.
17323 @c void mp_bad_exp (MP mp, const char * s) {
17325 print_err(s); mp_print(mp, " expression can't begin with `");
17326 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod);
17327 mp_print_char(mp, '\'');
17328 help4("I'm afraid I need some sort of value in order to continue,")
17329 ("so I've tentatively inserted `0'. You may want to")
17330 ("delete this zero and insert something else;")
17331 ("see Chapter 27 of The METAFONTbook for an example.");
17332 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
17333 mp_back_input(mp); mp->cur_sym=0; mp->cur_cmd=numeric_token;
17334 mp->cur_mod=0; mp_ins_error(mp);
17335 save_flag=mp->var_flag; mp->var_flag=0; mp_get_x_next(mp);
17336 mp->var_flag=save_flag;
17339 @ @<Supply diagnostic information, if requested@>=
17341 if ( mp->panicking ) mp_check_mem(mp, false);
17343 if ( mp->interrupt!=0 ) if ( mp->OK_to_interrupt ) {
17344 mp_back_input(mp); check_interrupt; mp_get_x_next(mp);
17347 @ @<Scan a delimited primary@>=
17349 l_delim=mp->cur_sym; r_delim=mp->cur_mod;
17350 mp_get_x_next(mp); mp_scan_expression(mp);
17351 if ( (mp->cur_cmd==comma) && (mp->cur_type>=mp_known) ) {
17352 @<Scan the rest of a delimited set of numerics@>;
17354 mp_check_delimiter(mp, l_delim,r_delim);
17358 @ The |stash_in| subroutine puts the current (numeric) expression into a field
17359 within a ``big node.''
17361 @c void mp_stash_in (MP mp,pointer p) {
17362 pointer q; /* temporary register */
17363 type(p)=mp->cur_type;
17364 if ( mp->cur_type==mp_known ) {
17365 value(p)=mp->cur_exp;
17367 if ( mp->cur_type==mp_independent ) {
17368 @<Stash an independent |cur_exp| into a big node@>;
17370 mp->mem[value_loc(p)]=mp->mem[value_loc(mp->cur_exp)];
17371 /* |dep_list(p):=dep_list(cur_exp)| and |prev_dep(p):=prev_dep(cur_exp)| */
17372 link(prev_dep(p))=p;
17374 mp_free_node(mp, mp->cur_exp,value_node_size);
17376 mp->cur_type=mp_vacuous;
17379 @ In rare cases the current expression can become |independent|. There
17380 may be many dependency lists pointing to such an independent capsule,
17381 so we can't simply move it into place within a big node. Instead,
17382 we copy it, then recycle it.
17384 @ @<Stash an independent |cur_exp|...@>=
17386 q=mp_single_dependency(mp, mp->cur_exp);
17387 if ( q==mp->dep_final ){
17388 type(p)=mp_known; value(p)=0; mp_free_node(mp, q,dep_node_size);
17390 type(p)=mp_dependent; mp_new_dep(mp, p,q);
17392 mp_recycle_value(mp, mp->cur_exp);
17395 @ This code uses the fact that |red_part_loc| and |green_part_loc|
17396 are synonymous with |x_part_loc| and |y_part_loc|.
17398 @<Scan the rest of a delimited set of numerics@>=
17400 p=mp_stash_cur_exp(mp);
17401 mp_get_x_next(mp); mp_scan_expression(mp);
17402 @<Make sure the second part of a pair or color has a numeric type@>;
17403 q=mp_get_node(mp, value_node_size); name_type(q)=mp_capsule;
17404 if ( mp->cur_cmd==comma ) type(q)=mp_color_type;
17405 else type(q)=mp_pair_type;
17406 mp_init_big_node(mp, q); r=value(q);
17407 mp_stash_in(mp, y_part_loc(r));
17408 mp_unstash_cur_exp(mp, p);
17409 mp_stash_in(mp, x_part_loc(r));
17410 if ( mp->cur_cmd==comma ) {
17411 @<Scan the last of a triplet of numerics@>;
17413 if ( mp->cur_cmd==comma ) {
17414 type(q)=mp_cmykcolor_type;
17415 mp_init_big_node(mp, q); t=value(q);
17416 mp->mem[cyan_part_loc(t)]=mp->mem[red_part_loc(r)];
17417 value(cyan_part_loc(t))=value(red_part_loc(r));
17418 mp->mem[magenta_part_loc(t)]=mp->mem[green_part_loc(r)];
17419 value(magenta_part_loc(t))=value(green_part_loc(r));
17420 mp->mem[yellow_part_loc(t)]=mp->mem[blue_part_loc(r)];
17421 value(yellow_part_loc(t))=value(blue_part_loc(r));
17422 mp_recycle_value(mp, r);
17424 @<Scan the last of a quartet of numerics@>;
17426 mp_check_delimiter(mp, l_delim,r_delim);
17427 mp->cur_type=type(q);
17431 @ @<Make sure the second part of a pair or color has a numeric type@>=
17432 if ( mp->cur_type<mp_known ) {
17433 exp_err("Nonnumeric ypart has been replaced by 0");
17434 @.Nonnumeric...replaced by 0@>
17435 help4("I've started to scan a pair `(a,b)' or a color `(a,b,c)';")
17436 ("but after finding a nice `a' I found a `b' that isn't")
17437 ("of numeric type. So I've changed that part to zero.")
17438 ("(The b that I didn't like appears above the error message.)");
17439 mp_put_get_flush_error(mp, 0);
17442 @ @<Scan the last of a triplet of numerics@>=
17444 mp_get_x_next(mp); mp_scan_expression(mp);
17445 if ( mp->cur_type<mp_known ) {
17446 exp_err("Nonnumeric third part has been replaced by 0");
17447 @.Nonnumeric...replaced by 0@>
17448 help3("I've just scanned a color `(a,b,c)' or cmykcolor(a,b,c,d); but the `c'")
17449 ("isn't of numeric type. So I've changed that part to zero.")
17450 ("(The c that I didn't like appears above the error message.)");
17451 mp_put_get_flush_error(mp, 0);
17453 mp_stash_in(mp, blue_part_loc(r));
17456 @ @<Scan the last of a quartet of numerics@>=
17458 mp_get_x_next(mp); mp_scan_expression(mp);
17459 if ( mp->cur_type<mp_known ) {
17460 exp_err("Nonnumeric blackpart has been replaced by 0");
17461 @.Nonnumeric...replaced by 0@>
17462 help3("I've just scanned a cmykcolor `(c,m,y,k)'; but the `k' isn't")
17463 ("of numeric type. So I've changed that part to zero.")
17464 ("(The k that I didn't like appears above the error message.)");
17465 mp_put_get_flush_error(mp, 0);
17467 mp_stash_in(mp, black_part_loc(r));
17470 @ The local variable |group_line| keeps track of the line
17471 where a \&{begingroup} command occurred; this will be useful
17472 in an error message if the group doesn't actually end.
17474 @<Other local variables for |scan_primary|@>=
17475 integer group_line; /* where a group began */
17477 @ @<Scan a grouped primary@>=
17479 group_line=mp_true_line(mp);
17480 if ( mp->internal[mp_tracing_commands]>0 ) show_cur_cmd_mod;
17481 save_boundary_item(p);
17483 mp_do_statement(mp); /* ends with |cur_cmd>=semicolon| */
17484 } while (mp->cur_cmd==semicolon);
17485 if ( mp->cur_cmd!=end_group ) {
17486 print_err("A group begun on line ");
17487 @.A group...never ended@>
17488 mp_print_int(mp, group_line);
17489 mp_print(mp, " never ended");
17490 help2("I saw a `begingroup' back there that hasn't been matched")
17491 ("by `endgroup'. So I've inserted `endgroup' now.");
17492 mp_back_error(mp); mp->cur_cmd=end_group;
17495 /* this might change |cur_type|, if independent variables are recycled */
17496 if ( mp->internal[mp_tracing_commands]>0 ) show_cur_cmd_mod;
17499 @ @<Scan a string constant@>=
17501 mp->cur_type=mp_string_type; mp->cur_exp=mp->cur_mod;
17504 @ Later we'll come to procedures that perform actual operations like
17505 addition, square root, and so on; our purpose now is to do the parsing.
17506 But we might as well mention those future procedures now, so that the
17507 suspense won't be too bad:
17510 |do_nullary(c)| does primitive operations that have no operands (e.g.,
17511 `\&{true}' or `\&{pencircle}');
17514 |do_unary(c)| applies a primitive operation to the current expression;
17517 |do_binary(p,c)| applies a primitive operation to the capsule~|p|
17518 and the current expression.
17520 @<Scan a nullary operation@>=mp_do_nullary(mp, mp->cur_mod)
17522 @ @<Scan a unary operation@>=
17524 c=mp->cur_mod; mp_get_x_next(mp); mp_scan_primary(mp);
17525 mp_do_unary(mp, c); goto DONE;
17528 @ A numeric token might be a primary by itself, or it might be the
17529 numerator of a fraction composed solely of numeric tokens, or it might
17530 multiply the primary that follows (provided that the primary doesn't begin
17531 with a plus sign or a minus sign). The code here uses the facts that
17532 |max_primary_command=plus_or_minus| and
17533 |max_primary_command-1=numeric_token|. If a fraction is found that is less
17534 than unity, we try to retain higher precision when we use it in scalar
17537 @<Other local variables for |scan_primary|@>=
17538 scaled num,denom; /* for primaries that are fractions, like `1/2' */
17540 @ @<Scan a primary that starts with a numeric token@>=
17542 mp->cur_exp=mp->cur_mod; mp->cur_type=mp_known; mp_get_x_next(mp);
17543 if ( mp->cur_cmd!=slash ) {
17547 if ( mp->cur_cmd!=numeric_token ) {
17549 mp->cur_cmd=slash; mp->cur_mod=over; mp->cur_sym=frozen_slash;
17552 num=mp->cur_exp; denom=mp->cur_mod;
17553 if ( denom==0 ) { @<Protest division by zero@>; }
17554 else { mp->cur_exp=mp_make_scaled(mp, num,denom); }
17555 check_arith; mp_get_x_next(mp);
17557 if ( mp->cur_cmd>=min_primary_command ) {
17558 if ( mp->cur_cmd<numeric_token ) { /* in particular, |cur_cmd<>plus_or_minus| */
17559 p=mp_stash_cur_exp(mp); mp_scan_primary(mp);
17560 if ( (abs(num)>=abs(denom))||(mp->cur_type<mp_color_type) ) {
17561 mp_do_binary(mp, p,times);
17563 mp_frac_mult(mp, num,denom);
17564 mp_free_node(mp, p,value_node_size);
17571 @ @<Protest division...@>=
17573 print_err("Division by zero");
17574 @.Division by zero@>
17575 help1("I'll pretend that you meant to divide by 1."); mp_error(mp);
17578 @ @<Scan a binary operation with `\&{of}' between its operands@>=
17580 c=mp->cur_mod; mp_get_x_next(mp); mp_scan_expression(mp);
17581 if ( mp->cur_cmd!=of_token ) {
17582 mp_missing_err(mp, "of"); mp_print(mp, " for ");
17583 mp_print_cmd_mod(mp, primary_binary,c);
17585 help1("I've got the first argument; will look now for the other.");
17588 p=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_primary(mp);
17589 mp_do_binary(mp, p,c); goto DONE;
17592 @ @<Convert a suffix to a string@>=
17594 mp_get_x_next(mp); mp_scan_suffix(mp);
17595 mp->old_setting=mp->selector; mp->selector=new_string;
17596 mp_show_token_list(mp, mp->cur_exp,null,100000,0);
17597 mp_flush_token_list(mp, mp->cur_exp);
17598 mp->cur_exp=mp_make_string(mp); mp->selector=mp->old_setting;
17599 mp->cur_type=mp_string_type;
17603 @ If an internal quantity appears all by itself on the left of an
17604 assignment, we return a token list of length one, containing the address
17605 of the internal quantity plus |hash_end|. (This accords with the conventions
17606 of the save stack, as described earlier.)
17608 @<Scan an internal...@>=
17611 if ( my_var_flag==assignment ) {
17613 if ( mp->cur_cmd==assignment ) {
17614 mp->cur_exp=mp_get_avail(mp);
17615 info(mp->cur_exp)=q+hash_end; mp->cur_type=mp_token_list;
17620 mp->cur_type=mp_known; mp->cur_exp=mp->internal[q];
17623 @ The most difficult part of |scan_primary| has been saved for last, since
17624 it was necessary to build up some confidence first. We can now face the task
17625 of scanning a variable.
17627 As we scan a variable, we build a token list containing the relevant
17628 names and subscript values, simultaneously following along in the
17629 ``collective'' structure to see if we are actually dealing with a macro
17630 instead of a value.
17632 The local variables |pre_head| and |post_head| will point to the beginning
17633 of the prefix and suffix lists; |tail| will point to the end of the list
17634 that is currently growing.
17636 Another local variable, |tt|, contains partial information about the
17637 declared type of the variable-so-far. If |tt>=mp_unsuffixed_macro|, the
17638 relation |tt=type(q)| will always hold. If |tt=undefined|, the routine
17639 doesn't bother to update its information about type. And if
17640 |undefined<tt<mp_unsuffixed_macro|, the precise value of |tt| isn't critical.
17642 @ @<Other local variables for |scan_primary|@>=
17643 pointer pre_head,post_head,tail;
17644 /* prefix and suffix list variables */
17645 small_number tt; /* approximation to the type of the variable-so-far */
17646 pointer t; /* a token */
17647 pointer macro_ref = 0; /* reference count for a suffixed macro */
17649 @ @<Scan a variable primary...@>=
17651 fast_get_avail(pre_head); tail=pre_head; post_head=null; tt=mp_vacuous;
17653 t=mp_cur_tok(mp); link(tail)=t;
17654 if ( tt!=undefined ) {
17655 @<Find the approximate type |tt| and corresponding~|q|@>;
17656 if ( tt>=mp_unsuffixed_macro ) {
17657 @<Either begin an unsuffixed macro call or
17658 prepare for a suffixed one@>;
17661 mp_get_x_next(mp); tail=t;
17662 if ( mp->cur_cmd==left_bracket ) {
17663 @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>;
17665 if ( mp->cur_cmd>max_suffix_token ) break;
17666 if ( mp->cur_cmd<min_suffix_token ) break;
17667 } /* now |cur_cmd| is |internal_quantity|, |tag_token|, or |numeric_token| */
17668 @<Handle unusual cases that masquerade as variables, and |goto restart|
17669 or |goto done| if appropriate;
17670 otherwise make a copy of the variable and |goto done|@>;
17673 @ @<Either begin an unsuffixed macro call or...@>=
17676 if ( tt>mp_unsuffixed_macro ) { /* |tt=mp_suffixed_macro| */
17677 post_head=mp_get_avail(mp); tail=post_head; link(tail)=t;
17678 tt=undefined; macro_ref=value(q); add_mac_ref(macro_ref);
17680 @<Set up unsuffixed macro call and |goto restart|@>;
17684 @ @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>=
17686 mp_get_x_next(mp); mp_scan_expression(mp);
17687 if ( mp->cur_cmd!=right_bracket ) {
17688 @<Put the left bracket and the expression back to be rescanned@>;
17690 if ( mp->cur_type!=mp_known ) mp_bad_subscript(mp);
17691 mp->cur_cmd=numeric_token; mp->cur_mod=mp->cur_exp; mp->cur_sym=0;
17695 @ The left bracket that we thought was introducing a subscript might have
17696 actually been the left bracket in a mediation construction like `\.{x[a,b]}'.
17697 So we don't issue an error message at this point; but we do want to back up
17698 so as to avoid any embarrassment about our incorrect assumption.
17700 @<Put the left bracket and the expression back to be rescanned@>=
17702 mp_back_input(mp); /* that was the token following the current expression */
17703 mp_back_expr(mp); mp->cur_cmd=left_bracket;
17704 mp->cur_mod=0; mp->cur_sym=frozen_left_bracket;
17707 @ Here's a routine that puts the current expression back to be read again.
17709 @c void mp_back_expr (MP mp) {
17710 pointer p; /* capsule token */
17711 p=mp_stash_cur_exp(mp); link(p)=null; back_list(p);
17714 @ Unknown subscripts lead to the following error message.
17716 @c void mp_bad_subscript (MP mp) {
17717 exp_err("Improper subscript has been replaced by zero");
17718 @.Improper subscript...@>
17719 help3("A bracketed subscript must have a known numeric value;")
17720 ("unfortunately, what I found was the value that appears just")
17721 ("above this error message. So I'll try a zero subscript.");
17722 mp_flush_error(mp, 0);
17725 @ Every time we call |get_x_next|, there's a chance that the variable we've
17726 been looking at will disappear. Thus, we cannot safely keep |q| pointing
17727 into the variable structure; we need to start searching from the root each time.
17729 @<Find the approximate type |tt| and corresponding~|q|@>=
17732 p=link(pre_head); q=info(p); tt=undefined;
17733 if ( eq_type(q) % outer_tag==tag_token ) {
17735 if ( q==null ) goto DONE2;
17739 tt=type(q); goto DONE2;
17741 if ( type(q)!=mp_structured ) goto DONE2;
17742 q=link(attr_head(q)); /* the |collective_subscript| attribute */
17743 if ( p>=mp->hi_mem_min ) { /* it's not a subscript */
17744 do { q=link(q); } while (! (attr_loc(q)>=info(p)));
17745 if ( attr_loc(q)>info(p) ) goto DONE2;
17753 @ How do things stand now? Well, we have scanned an entire variable name,
17754 including possible subscripts and/or attributes; |cur_cmd|, |cur_mod|, and
17755 |cur_sym| represent the token that follows. If |post_head=null|, a
17756 token list for this variable name starts at |link(pre_head)|, with all
17757 subscripts evaluated. But if |post_head<>null|, the variable turned out
17758 to be a suffixed macro; |pre_head| is the head of the prefix list, while
17759 |post_head| is the head of a token list containing both `\.{\AT!}' and
17762 Our immediate problem is to see if this variable still exists. (Variable
17763 structures can change drastically whenever we call |get_x_next|; users
17764 aren't supposed to do this, but the fact that it is possible means that
17765 we must be cautious.)
17767 The following procedure prints an error message when a variable
17768 unexpectedly disappears. Its help message isn't quite right for
17769 our present purposes, but we'll be able to fix that up.
17772 void mp_obliterated (MP mp,pointer q) {
17773 print_err("Variable "); mp_show_token_list(mp, q,null,1000,0);
17774 mp_print(mp, " has been obliterated");
17775 @.Variable...obliterated@>
17776 help5("It seems you did a nasty thing---probably by accident,")
17777 ("but nevertheless you nearly hornswoggled me...")
17778 ("While I was evaluating the right-hand side of this")
17779 ("command, something happened, and the left-hand side")
17780 ("is no longer a variable! So I won't change anything.");
17783 @ If the variable does exist, we also need to check
17784 for a few other special cases before deciding that a plain old ordinary
17785 variable has, indeed, been scanned.
17787 @<Handle unusual cases that masquerade as variables...@>=
17788 if ( post_head!=null ) {
17789 @<Set up suffixed macro call and |goto restart|@>;
17791 q=link(pre_head); free_avail(pre_head);
17792 if ( mp->cur_cmd==my_var_flag ) {
17793 mp->cur_type=mp_token_list; mp->cur_exp=q; goto DONE;
17795 p=mp_find_variable(mp, q);
17797 mp_make_exp_copy(mp, p);
17799 mp_obliterated(mp, q);
17800 mp->help_line[2]="While I was evaluating the suffix of this variable,";
17801 mp->help_line[1]="something was redefined, and it's no longer a variable!";
17802 mp->help_line[0]="In order to get back on my feet, I've inserted `0' instead.";
17803 mp_put_get_flush_error(mp, 0);
17805 mp_flush_node_list(mp, q);
17808 @ The only complication associated with macro calling is that the prefix
17809 and ``at'' parameters must be packaged in an appropriate list of lists.
17811 @<Set up unsuffixed macro call and |goto restart|@>=
17813 p=mp_get_avail(mp); info(pre_head)=link(pre_head); link(pre_head)=p;
17814 info(p)=t; mp_macro_call(mp, value(q),pre_head,null);
17819 @ If the ``variable'' that turned out to be a suffixed macro no longer exists,
17820 we don't care, because we have reserved a pointer (|macro_ref|) to its
17823 @<Set up suffixed macro call and |goto restart|@>=
17825 mp_back_input(mp); p=mp_get_avail(mp); q=link(post_head);
17826 info(pre_head)=link(pre_head); link(pre_head)=post_head;
17827 info(post_head)=q; link(post_head)=p; info(p)=link(q); link(q)=null;
17828 mp_macro_call(mp, macro_ref,pre_head,null); decr(ref_count(macro_ref));
17829 mp_get_x_next(mp); goto RESTART;
17832 @ Our remaining job is simply to make a copy of the value that has been
17833 found. Some cases are harder than others, but complexity arises solely
17834 because of the multiplicity of possible cases.
17836 @<Declare the procedure called |make_exp_copy|@>=
17837 @<Declare subroutines needed by |make_exp_copy|@>
17838 void mp_make_exp_copy (MP mp,pointer p) {
17839 pointer q,r,t; /* registers for list manipulation */
17841 mp->cur_type=type(p);
17842 switch (mp->cur_type) {
17843 case mp_vacuous: case mp_boolean_type: case mp_known:
17844 mp->cur_exp=value(p); break;
17845 case unknown_types:
17846 mp->cur_exp=mp_new_ring_entry(mp, p);
17848 case mp_string_type:
17849 mp->cur_exp=value(p); add_str_ref(mp->cur_exp);
17851 case mp_picture_type:
17852 mp->cur_exp=value(p);add_edge_ref(mp->cur_exp);
17855 mp->cur_exp=copy_pen(value(p));
17858 mp->cur_exp=mp_copy_path(mp, value(p));
17860 case mp_transform_type: case mp_color_type:
17861 case mp_cmykcolor_type: case mp_pair_type:
17862 @<Copy the big node |p|@>;
17864 case mp_dependent: case mp_proto_dependent:
17865 mp_encapsulate(mp, mp_copy_dep_list(mp, dep_list(p)));
17867 case mp_numeric_type:
17868 new_indep(p); goto RESTART;
17870 case mp_independent:
17871 q=mp_single_dependency(mp, p);
17872 if ( q==mp->dep_final ){
17873 mp->cur_type=mp_known; mp->cur_exp=0; mp_free_node(mp, q,dep_node_size);
17875 mp->cur_type=mp_dependent; mp_encapsulate(mp, q);
17879 mp_confusion(mp, "copy");
17880 @:this can't happen copy}{\quad copy@>
17885 @ The |encapsulate| subroutine assumes that |dep_final| is the
17886 tail of dependency list~|p|.
17888 @<Declare subroutines needed by |make_exp_copy|@>=
17889 void mp_encapsulate (MP mp,pointer p) {
17890 mp->cur_exp=mp_get_node(mp, value_node_size); type(mp->cur_exp)=mp->cur_type;
17891 name_type(mp->cur_exp)=mp_capsule; mp_new_dep(mp, mp->cur_exp,p);
17894 @ The most tedious case arises when the user refers to a
17895 \&{pair}, \&{color}, or \&{transform} variable; we must copy several fields,
17896 each of which can be |independent|, |dependent|, |mp_proto_dependent|,
17899 @<Copy the big node |p|@>=
17901 if ( value(p)==null )
17902 mp_init_big_node(mp, p);
17903 t=mp_get_node(mp, value_node_size); name_type(t)=mp_capsule; type(t)=mp->cur_type;
17904 mp_init_big_node(mp, t);
17905 q=value(p)+mp->big_node_size[mp->cur_type];
17906 r=value(t)+mp->big_node_size[mp->cur_type];
17908 q=q-2; r=r-2; mp_install(mp, r,q);
17909 } while (q!=value(p));
17913 @ The |install| procedure copies a numeric field~|q| into field~|r| of
17914 a big node that will be part of a capsule.
17916 @<Declare subroutines needed by |make_exp_copy|@>=
17917 void mp_install (MP mp,pointer r, pointer q) {
17918 pointer p; /* temporary register */
17919 if ( type(q)==mp_known ){
17920 value(r)=value(q); type(r)=mp_known;
17921 } else if ( type(q)==mp_independent ) {
17922 p=mp_single_dependency(mp, q);
17923 if ( p==mp->dep_final ) {
17924 type(r)=mp_known; value(r)=0; mp_free_node(mp, p,dep_node_size);
17926 type(r)=mp_dependent; mp_new_dep(mp, r,p);
17929 type(r)=type(q); mp_new_dep(mp, r,mp_copy_dep_list(mp, dep_list(q)));
17933 @ Expressions of the form `\.{a[b,c]}' are converted into
17934 `\.{b+a*(c-b)}', without checking the types of \.b~or~\.c,
17935 provided that \.a is numeric.
17937 @<Scan a mediation...@>=
17939 p=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_expression(mp);
17940 if ( mp->cur_cmd!=comma ) {
17941 @<Put the left bracket and the expression back...@>;
17942 mp_unstash_cur_exp(mp, p);
17944 q=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_expression(mp);
17945 if ( mp->cur_cmd!=right_bracket ) {
17946 mp_missing_err(mp, "]");
17948 help3("I've scanned an expression of the form `a[b,c',")
17949 ("so a right bracket should have come next.")
17950 ("I shall pretend that one was there.");
17953 r=mp_stash_cur_exp(mp); mp_make_exp_copy(mp, q);
17954 mp_do_binary(mp, r,minus); mp_do_binary(mp, p,times);
17955 mp_do_binary(mp, q,plus); mp_get_x_next(mp);
17959 @ Here is a comparatively simple routine that is used to scan the
17960 \&{suffix} parameters of a macro.
17962 @<Declare the basic parsing subroutines@>=
17963 void mp_scan_suffix (MP mp) {
17964 pointer h,t; /* head and tail of the list being built */
17965 pointer p; /* temporary register */
17966 h=mp_get_avail(mp); t=h;
17968 if ( mp->cur_cmd==left_bracket ) {
17969 @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>;
17971 if ( mp->cur_cmd==numeric_token ) {
17972 p=mp_new_num_tok(mp, mp->cur_mod);
17973 } else if ((mp->cur_cmd==tag_token)||(mp->cur_cmd==internal_quantity) ) {
17974 p=mp_get_avail(mp); info(p)=mp->cur_sym;
17978 link(t)=p; t=p; mp_get_x_next(mp);
17980 mp->cur_exp=link(h); free_avail(h); mp->cur_type=mp_token_list;
17983 @ @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>=
17985 mp_get_x_next(mp); mp_scan_expression(mp);
17986 if ( mp->cur_type!=mp_known ) mp_bad_subscript(mp);
17987 if ( mp->cur_cmd!=right_bracket ) {
17988 mp_missing_err(mp, "]");
17990 help3("I've seen a `[' and a subscript value, in a suffix,")
17991 ("so a right bracket should have come next.")
17992 ("I shall pretend that one was there.");
17995 mp->cur_cmd=numeric_token; mp->cur_mod=mp->cur_exp;
17998 @* \[38] Parsing secondary and higher expressions.
18000 After the intricacies of |scan_primary|\kern-1pt,
18001 the |scan_secondary| routine is
18002 refreshingly simple. It's not trivial, but the operations are relatively
18003 straightforward; the main difficulty is, again, that expressions and data
18004 structures might change drastically every time we call |get_x_next|, so a
18005 cautious approach is mandatory. For example, a macro defined by
18006 \&{primarydef} might have disappeared by the time its second argument has
18007 been scanned; we solve this by increasing the reference count of its token
18008 list, so that the macro can be called even after it has been clobbered.
18010 @<Declare the basic parsing subroutines@>=
18011 void mp_scan_secondary (MP mp) {
18012 pointer p; /* for list manipulation */
18013 halfword c,d; /* operation codes or modifiers */
18014 pointer mac_name; /* token defined with \&{primarydef} */
18016 if ((mp->cur_cmd<min_primary_command)||
18017 (mp->cur_cmd>max_primary_command) )
18018 mp_bad_exp(mp, "A secondary");
18019 @.A secondary expression...@>
18020 mp_scan_primary(mp);
18022 if ( mp->cur_cmd<=max_secondary_command &&
18023 mp->cur_cmd>=min_secondary_command ) {
18024 p=mp_stash_cur_exp(mp);
18025 c=mp->cur_mod; d=mp->cur_cmd;
18026 if ( d==secondary_primary_macro ) {
18027 mac_name=mp->cur_sym;
18031 mp_scan_primary(mp);
18032 if ( d!=secondary_primary_macro ) {
18033 mp_do_binary(mp, p,c);
18036 mp_binary_mac(mp, p,c,mac_name);
18037 decr(ref_count(c));
18045 @ The following procedure calls a macro that has two parameters,
18048 @c void mp_binary_mac (MP mp,pointer p, pointer c, pointer n) {
18049 pointer q,r; /* nodes in the parameter list */
18050 q=mp_get_avail(mp); r=mp_get_avail(mp); link(q)=r;
18051 info(q)=p; info(r)=mp_stash_cur_exp(mp);
18052 mp_macro_call(mp, c,q,n);
18055 @ The next procedure, |scan_tertiary|, is pretty much the same deal.
18057 @<Declare the basic parsing subroutines@>=
18058 void mp_scan_tertiary (MP mp) {
18059 pointer p; /* for list manipulation */
18060 halfword c,d; /* operation codes or modifiers */
18061 pointer mac_name; /* token defined with \&{secondarydef} */
18063 if ((mp->cur_cmd<min_primary_command)||
18064 (mp->cur_cmd>max_primary_command) )
18065 mp_bad_exp(mp, "A tertiary");
18066 @.A tertiary expression...@>
18067 mp_scan_secondary(mp);
18069 if ( mp->cur_cmd<=max_tertiary_command ) {
18070 if ( mp->cur_cmd>=min_tertiary_command ) {
18071 p=mp_stash_cur_exp(mp); c=mp->cur_mod; d=mp->cur_cmd;
18072 if ( d==tertiary_secondary_macro ) {
18073 mac_name=mp->cur_sym; add_mac_ref(c);
18075 mp_get_x_next(mp); mp_scan_secondary(mp);
18076 if ( d!=tertiary_secondary_macro ) {
18077 mp_do_binary(mp, p,c);
18079 mp_back_input(mp); mp_binary_mac(mp, p,c,mac_name);
18080 decr(ref_count(c)); mp_get_x_next(mp);
18088 @ Finally we reach the deepest level in our quartet of parsing routines.
18089 This one is much like the others; but it has an extra complication from
18090 paths, which materialize here.
18092 @d continue_path 25 /* a label inside of |scan_expression| */
18093 @d finish_path 26 /* another */
18095 @<Declare the basic parsing subroutines@>=
18096 void mp_scan_expression (MP mp) {
18097 pointer p,q,r,pp,qq; /* for list manipulation */
18098 halfword c,d; /* operation codes or modifiers */
18099 int my_var_flag; /* initial value of |var_flag| */
18100 pointer mac_name; /* token defined with \&{tertiarydef} */
18101 boolean cycle_hit; /* did a path expression just end with `\&{cycle}'? */
18102 scaled x,y; /* explicit coordinates or tension at a path join */
18103 int t; /* knot type following a path join */
18105 my_var_flag=mp->var_flag; mac_name=null;
18107 if ((mp->cur_cmd<min_primary_command)||
18108 (mp->cur_cmd>max_primary_command) )
18109 mp_bad_exp(mp, "An");
18110 @.An expression...@>
18111 mp_scan_tertiary(mp);
18113 if ( mp->cur_cmd<=max_expression_command )
18114 if ( mp->cur_cmd>=min_expression_command ) {
18115 if ( (mp->cur_cmd!=equals)||(my_var_flag!=assignment) ) {
18116 p=mp_stash_cur_exp(mp); c=mp->cur_mod; d=mp->cur_cmd;
18117 if ( d==expression_tertiary_macro ) {
18118 mac_name=mp->cur_sym; add_mac_ref(c);
18120 if ( (d<ampersand)||((d==ampersand)&&
18121 ((type(p)==mp_pair_type)||(type(p)==mp_path_type))) ) {
18122 @<Scan a path construction operation;
18123 but |return| if |p| has the wrong type@>;
18125 mp_get_x_next(mp); mp_scan_tertiary(mp);
18126 if ( d!=expression_tertiary_macro ) {
18127 mp_do_binary(mp, p,c);
18129 mp_back_input(mp); mp_binary_mac(mp, p,c,mac_name);
18130 decr(ref_count(c)); mp_get_x_next(mp);
18139 @ The reader should review the data structure conventions for paths before
18140 hoping to understand the next part of this code.
18142 @<Scan a path construction operation...@>=
18145 @<Convert the left operand, |p|, into a partial path ending at~|q|;
18146 but |return| if |p| doesn't have a suitable type@>;
18148 @<Determine the path join parameters;
18149 but |goto finish_path| if there's only a direction specifier@>;
18150 if ( mp->cur_cmd==cycle ) {
18151 @<Get ready to close a cycle@>;
18153 mp_scan_tertiary(mp);
18154 @<Convert the right operand, |cur_exp|,
18155 into a partial path from |pp| to~|qq|@>;
18157 @<Join the partial paths and reset |p| and |q| to the head and tail
18159 if ( mp->cur_cmd>=min_expression_command )
18160 if ( mp->cur_cmd<=ampersand ) if ( ! cycle_hit ) goto CONTINUE_PATH;
18162 @<Choose control points for the path and put the result into |cur_exp|@>;
18165 @ @<Convert the left operand, |p|, into a partial path ending at~|q|...@>=
18167 mp_unstash_cur_exp(mp, p);
18168 if ( mp->cur_type==mp_pair_type ) p=mp_new_knot(mp);
18169 else if ( mp->cur_type==mp_path_type ) p=mp->cur_exp;
18172 while ( link(q)!=p ) q=link(q);
18173 if ( left_type(p)!=mp_endpoint ) { /* open up a cycle */
18174 r=mp_copy_knot(mp, p); link(q)=r; q=r;
18176 left_type(p)=mp_open; right_type(q)=mp_open;
18179 @ A pair of numeric values is changed into a knot node for a one-point path
18180 when \MP\ discovers that the pair is part of a path.
18182 @c @<Declare the procedure called |known_pair|@>
18183 pointer mp_new_knot (MP mp) { /* convert a pair to a knot with two endpoints */
18184 pointer q; /* the new node */
18185 q=mp_get_node(mp, knot_node_size); left_type(q)=mp_endpoint;
18186 right_type(q)=mp_endpoint; originator(q)=mp_metapost_user; link(q)=q;
18187 mp_known_pair(mp); x_coord(q)=mp->cur_x; y_coord(q)=mp->cur_y;
18191 @ The |known_pair| subroutine sets |cur_x| and |cur_y| to the components
18192 of the current expression, assuming that the current expression is a
18193 pair of known numerics. Unknown components are zeroed, and the
18194 current expression is flushed.
18196 @<Declare the procedure called |known_pair|@>=
18197 void mp_known_pair (MP mp) {
18198 pointer p; /* the pair node */
18199 if ( mp->cur_type!=mp_pair_type ) {
18200 exp_err("Undefined coordinates have been replaced by (0,0)");
18201 @.Undefined coordinates...@>
18202 help5("I need x and y numbers for this part of the path.")
18203 ("The value I found (see above) was no good;")
18204 ("so I'll try to keep going by using zero instead.")
18205 ("(Chapter 27 of The METAFONTbook explains that")
18206 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18207 ("you might want to type `I ??" "?' now.)");
18208 mp_put_get_flush_error(mp, 0); mp->cur_x=0; mp->cur_y=0;
18210 p=value(mp->cur_exp);
18211 @<Make sure that both |x| and |y| parts of |p| are known;
18212 copy them into |cur_x| and |cur_y|@>;
18213 mp_flush_cur_exp(mp, 0);
18217 @ @<Make sure that both |x| and |y| parts of |p| are known...@>=
18218 if ( type(x_part_loc(p))==mp_known ) {
18219 mp->cur_x=value(x_part_loc(p));
18221 mp_disp_err(mp, x_part_loc(p),
18222 "Undefined x coordinate has been replaced by 0");
18223 @.Undefined coordinates...@>
18224 help5("I need a `known' x value for this part of the path.")
18225 ("The value I found (see above) was no good;")
18226 ("so I'll try to keep going by using zero instead.")
18227 ("(Chapter 27 of The METAFONTbook explains that")
18228 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18229 ("you might want to type `I ??" "?' now.)");
18230 mp_put_get_error(mp); mp_recycle_value(mp, x_part_loc(p)); mp->cur_x=0;
18232 if ( type(y_part_loc(p))==mp_known ) {
18233 mp->cur_y=value(y_part_loc(p));
18235 mp_disp_err(mp, y_part_loc(p),
18236 "Undefined y coordinate has been replaced by 0");
18237 help5("I need a `known' y value for this part of the path.")
18238 ("The value I found (see above) was no good;")
18239 ("so I'll try to keep going by using zero instead.")
18240 ("(Chapter 27 of The METAFONTbook explains that")
18241 ("you might want to type `I ??" "?' now.)");
18242 mp_put_get_error(mp); mp_recycle_value(mp, y_part_loc(p)); mp->cur_y=0;
18245 @ At this point |cur_cmd| is either |ampersand|, |left_brace|, or |path_join|.
18247 @<Determine the path join parameters...@>=
18248 if ( mp->cur_cmd==left_brace ) {
18249 @<Put the pre-join direction information into node |q|@>;
18252 if ( d==path_join ) {
18253 @<Determine the tension and/or control points@>;
18254 } else if ( d!=ampersand ) {
18258 if ( mp->cur_cmd==left_brace ) {
18259 @<Put the post-join direction information into |x| and |t|@>;
18260 } else if ( right_type(q)!=mp_explicit ) {
18264 @ The |scan_direction| subroutine looks at the directional information
18265 that is enclosed in braces, and also scans ahead to the following character.
18266 A type code is returned, either |open| (if the direction was $(0,0)$),
18267 or |curl| (if the direction was a curl of known value |cur_exp|), or
18268 |given| (if the direction is given by the |angle| value that now
18269 appears in |cur_exp|).
18271 There's nothing difficult about this subroutine, but the program is rather
18272 lengthy because a variety of potential errors need to be nipped in the bud.
18274 @c small_number mp_scan_direction (MP mp) {
18275 int t; /* the type of information found */
18276 scaled x; /* an |x| coordinate */
18278 if ( mp->cur_cmd==curl_command ) {
18279 @<Scan a curl specification@>;
18281 @<Scan a given direction@>;
18283 if ( mp->cur_cmd!=right_brace ) {
18284 mp_missing_err(mp, "}");
18285 @.Missing `\char`\}'@>
18286 help3("I've scanned a direction spec for part of a path,")
18287 ("so a right brace should have come next.")
18288 ("I shall pretend that one was there.");
18295 @ @<Scan a curl specification@>=
18296 { mp_get_x_next(mp); mp_scan_expression(mp);
18297 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<0) ){
18298 exp_err("Improper curl has been replaced by 1");
18300 help1("A curl must be a known, nonnegative number.");
18301 mp_put_get_flush_error(mp, unity);
18306 @ @<Scan a given direction@>=
18307 { mp_scan_expression(mp);
18308 if ( mp->cur_type>mp_pair_type ) {
18309 @<Get given directions separated by commas@>;
18313 if ( (mp->cur_x==0)&&(mp->cur_y==0) ) t=mp_open;
18314 else { t=mp_given; mp->cur_exp=mp_n_arg(mp, mp->cur_x,mp->cur_y);}
18317 @ @<Get given directions separated by commas@>=
18319 if ( mp->cur_type!=mp_known ) {
18320 exp_err("Undefined x coordinate has been replaced by 0");
18321 @.Undefined coordinates...@>
18322 help5("I need a `known' x value for this part of the path.")
18323 ("The value I found (see above) was no good;")
18324 ("so I'll try to keep going by using zero instead.")
18325 ("(Chapter 27 of The METAFONTbook explains that")
18326 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18327 ("you might want to type `I ??" "?' now.)");
18328 mp_put_get_flush_error(mp, 0);
18331 if ( mp->cur_cmd!=comma ) {
18332 mp_missing_err(mp, ",");
18334 help2("I've got the x coordinate of a path direction;")
18335 ("will look for the y coordinate next.");
18338 mp_get_x_next(mp); mp_scan_expression(mp);
18339 if ( mp->cur_type!=mp_known ) {
18340 exp_err("Undefined y coordinate has been replaced by 0");
18341 help5("I need a `known' y value for this part of the path.")
18342 ("The value I found (see above) was no good;")
18343 ("so I'll try to keep going by using zero instead.")
18344 ("(Chapter 27 of The METAFONTbook explains that")
18345 ("you might want to type `I ??" "?' now.)");
18346 mp_put_get_flush_error(mp, 0);
18348 mp->cur_y=mp->cur_exp; mp->cur_x=x;
18351 @ At this point |right_type(q)| is usually |open|, but it may have been
18352 set to some other value by a previous operation. We must maintain
18353 the value of |right_type(q)| in cases such as
18354 `\.{..\{curl2\}z\{0,0\}..}'.
18356 @<Put the pre-join...@>=
18358 t=mp_scan_direction(mp);
18359 if ( t!=mp_open ) {
18360 right_type(q)=t; right_given(q)=mp->cur_exp;
18361 if ( left_type(q)==mp_open ) {
18362 left_type(q)=t; left_given(q)=mp->cur_exp;
18363 } /* note that |left_given(q)=left_curl(q)| */
18367 @ Since |left_tension| and |left_y| share the same position in knot nodes,
18368 and since |left_given| is similarly equivalent to |left_x|, we use
18369 |x| and |y| to hold the given direction and tension information when
18370 there are no explicit control points.
18372 @<Put the post-join...@>=
18374 t=mp_scan_direction(mp);
18375 if ( right_type(q)!=mp_explicit ) x=mp->cur_exp;
18376 else t=mp_explicit; /* the direction information is superfluous */
18379 @ @<Determine the tension and/or...@>=
18382 if ( mp->cur_cmd==tension ) {
18383 @<Set explicit tensions@>;
18384 } else if ( mp->cur_cmd==controls ) {
18385 @<Set explicit control points@>;
18387 right_tension(q)=unity; y=unity; mp_back_input(mp); /* default tension */
18390 if ( mp->cur_cmd!=path_join ) {
18391 mp_missing_err(mp, "..");
18393 help1("A path join command should end with two dots.");
18400 @ @<Set explicit tensions@>=
18402 mp_get_x_next(mp); y=mp->cur_cmd;
18403 if ( mp->cur_cmd==at_least ) mp_get_x_next(mp);
18404 mp_scan_primary(mp);
18405 @<Make sure that the current expression is a valid tension setting@>;
18406 if ( y==at_least ) negate(mp->cur_exp);
18407 right_tension(q)=mp->cur_exp;
18408 if ( mp->cur_cmd==and_command ) {
18409 mp_get_x_next(mp); y=mp->cur_cmd;
18410 if ( mp->cur_cmd==at_least ) mp_get_x_next(mp);
18411 mp_scan_primary(mp);
18412 @<Make sure that the current expression is a valid tension setting@>;
18413 if ( y==at_least ) negate(mp->cur_exp);
18418 @ @d min_tension three_quarter_unit
18420 @<Make sure that the current expression is a valid tension setting@>=
18421 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<min_tension) ) {
18422 exp_err("Improper tension has been set to 1");
18423 @.Improper tension@>
18424 help1("The expression above should have been a number >=3/4.");
18425 mp_put_get_flush_error(mp, unity);
18428 @ @<Set explicit control points@>=
18430 right_type(q)=mp_explicit; t=mp_explicit; mp_get_x_next(mp); mp_scan_primary(mp);
18431 mp_known_pair(mp); right_x(q)=mp->cur_x; right_y(q)=mp->cur_y;
18432 if ( mp->cur_cmd!=and_command ) {
18433 x=right_x(q); y=right_y(q);
18435 mp_get_x_next(mp); mp_scan_primary(mp);
18436 mp_known_pair(mp); x=mp->cur_x; y=mp->cur_y;
18440 @ @<Convert the right operand, |cur_exp|, into a partial path...@>=
18442 if ( mp->cur_type!=mp_path_type ) pp=mp_new_knot(mp);
18443 else pp=mp->cur_exp;
18445 while ( link(qq)!=pp ) qq=link(qq);
18446 if ( left_type(pp)!=mp_endpoint ) { /* open up a cycle */
18447 r=mp_copy_knot(mp, pp); link(qq)=r; qq=r;
18449 left_type(pp)=mp_open; right_type(qq)=mp_open;
18452 @ If a person tries to define an entire path by saying `\.{(x,y)\&cycle}',
18453 we silently change the specification to `\.{(x,y)..cycle}', since a cycle
18454 shouldn't have length zero.
18456 @<Get ready to close a cycle@>=
18458 cycle_hit=true; mp_get_x_next(mp); pp=p; qq=p;
18459 if ( d==ampersand ) if ( p==q ) {
18460 d=path_join; right_tension(q)=unity; y=unity;
18464 @ @<Join the partial paths and reset |p| and |q|...@>=
18466 if ( d==ampersand ) {
18467 if ( (x_coord(q)!=x_coord(pp))||(y_coord(q)!=y_coord(pp)) ) {
18468 print_err("Paths don't touch; `&' will be changed to `..'");
18469 @.Paths don't touch@>
18470 help3("When you join paths `p&q', the ending point of p")
18471 ("must be exactly equal to the starting point of q.")
18472 ("So I'm going to pretend that you said `p..q' instead.");
18473 mp_put_get_error(mp); d=path_join; right_tension(q)=unity; y=unity;
18476 @<Plug an opening in |right_type(pp)|, if possible@>;
18477 if ( d==ampersand ) {
18478 @<Splice independent paths together@>;
18480 @<Plug an opening in |right_type(q)|, if possible@>;
18481 link(q)=pp; left_y(pp)=y;
18482 if ( t!=mp_open ) { left_x(pp)=x; left_type(pp)=t; };
18487 @ @<Plug an opening in |right_type(q)|...@>=
18488 if ( right_type(q)==mp_open ) {
18489 if ( (left_type(q)==mp_curl)||(left_type(q)==mp_given) ) {
18490 right_type(q)=left_type(q); right_given(q)=left_given(q);
18494 @ @<Plug an opening in |right_type(pp)|...@>=
18495 if ( right_type(pp)==mp_open ) {
18496 if ( (t==mp_curl)||(t==mp_given) ) {
18497 right_type(pp)=t; right_given(pp)=x;
18501 @ @<Splice independent paths together@>=
18503 if ( left_type(q)==mp_open ) if ( right_type(q)==mp_open ) {
18504 left_type(q)=mp_curl; left_curl(q)=unity;
18506 if ( right_type(pp)==mp_open ) if ( t==mp_open ) {
18507 right_type(pp)=mp_curl; right_curl(pp)=unity;
18509 right_type(q)=right_type(pp); link(q)=link(pp);
18510 right_x(q)=right_x(pp); right_y(q)=right_y(pp);
18511 mp_free_node(mp, pp,knot_node_size);
18512 if ( qq==pp ) qq=q;
18515 @ @<Choose control points for the path...@>=
18517 if ( d==ampersand ) p=q;
18519 left_type(p)=mp_endpoint;
18520 if ( right_type(p)==mp_open ) {
18521 right_type(p)=mp_curl; right_curl(p)=unity;
18523 right_type(q)=mp_endpoint;
18524 if ( left_type(q)==mp_open ) {
18525 left_type(q)=mp_curl; left_curl(q)=unity;
18529 mp_make_choices(mp, p);
18530 mp->cur_type=mp_path_type; mp->cur_exp=p
18532 @ Finally, we sometimes need to scan an expression whose value is
18533 supposed to be either |true_code| or |false_code|.
18535 @<Declare the basic parsing subroutines@>=
18536 void mp_get_boolean (MP mp) {
18537 mp_get_x_next(mp); mp_scan_expression(mp);
18538 if ( mp->cur_type!=mp_boolean_type ) {
18539 exp_err("Undefined condition will be treated as `false'");
18540 @.Undefined condition...@>
18541 help2("The expression shown above should have had a definite")
18542 ("true-or-false value. I'm changing it to `false'.");
18543 mp_put_get_flush_error(mp, false_code); mp->cur_type=mp_boolean_type;
18547 @* \[39] Doing the operations.
18548 The purpose of parsing is primarily to permit people to avoid piles of
18549 parentheses. But the real work is done after the structure of an expression
18550 has been recognized; that's when new expressions are generated. We
18551 turn now to the guts of \MP, which handles individual operators that
18552 have come through the parsing mechanism.
18554 We'll start with the easy ones that take no operands, then work our way
18555 up to operators with one and ultimately two arguments. In other words,
18556 we will write the three procedures |do_nullary|, |do_unary|, and |do_binary|
18557 that are invoked periodically by the expression scanners.
18559 First let's make sure that all of the primitive operators are in the
18560 hash table. Although |scan_primary| and its relatives made use of the
18561 \\{cmd} code for these operators, the \\{do} routines base everything
18562 on the \\{mod} code. For example, |do_binary| doesn't care whether the
18563 operation it performs is a |primary_binary| or |secondary_binary|, etc.
18566 mp_primitive(mp, "true",nullary,true_code);
18567 @:true_}{\&{true} primitive@>
18568 mp_primitive(mp, "false",nullary,false_code);
18569 @:false_}{\&{false} primitive@>
18570 mp_primitive(mp, "nullpicture",nullary,null_picture_code);
18571 @:null_picture_}{\&{nullpicture} primitive@>
18572 mp_primitive(mp, "nullpen",nullary,null_pen_code);
18573 @:null_pen_}{\&{nullpen} primitive@>
18574 mp_primitive(mp, "jobname",nullary,job_name_op);
18575 @:job_name_}{\&{jobname} primitive@>
18576 mp_primitive(mp, "readstring",nullary,read_string_op);
18577 @:read_string_}{\&{readstring} primitive@>
18578 mp_primitive(mp, "pencircle",nullary,pen_circle);
18579 @:pen_circle_}{\&{pencircle} primitive@>
18580 mp_primitive(mp, "normaldeviate",nullary,normal_deviate);
18581 @:normal_deviate_}{\&{normaldeviate} primitive@>
18582 mp_primitive(mp, "readfrom",unary,read_from_op);
18583 @:read_from_}{\&{readfrom} primitive@>
18584 mp_primitive(mp, "closefrom",unary,close_from_op);
18585 @:close_from_}{\&{closefrom} primitive@>
18586 mp_primitive(mp, "odd",unary,odd_op);
18587 @:odd_}{\&{odd} primitive@>
18588 mp_primitive(mp, "known",unary,known_op);
18589 @:known_}{\&{known} primitive@>
18590 mp_primitive(mp, "unknown",unary,unknown_op);
18591 @:unknown_}{\&{unknown} primitive@>
18592 mp_primitive(mp, "not",unary,not_op);
18593 @:not_}{\&{not} primitive@>
18594 mp_primitive(mp, "decimal",unary,decimal);
18595 @:decimal_}{\&{decimal} primitive@>
18596 mp_primitive(mp, "reverse",unary,reverse);
18597 @:reverse_}{\&{reverse} primitive@>
18598 mp_primitive(mp, "makepath",unary,make_path_op);
18599 @:make_path_}{\&{makepath} primitive@>
18600 mp_primitive(mp, "makepen",unary,make_pen_op);
18601 @:make_pen_}{\&{makepen} primitive@>
18602 mp_primitive(mp, "oct",unary,oct_op);
18603 @:oct_}{\&{oct} primitive@>
18604 mp_primitive(mp, "hex",unary,hex_op);
18605 @:hex_}{\&{hex} primitive@>
18606 mp_primitive(mp, "ASCII",unary,ASCII_op);
18607 @:ASCII_}{\&{ASCII} primitive@>
18608 mp_primitive(mp, "char",unary,char_op);
18609 @:char_}{\&{char} primitive@>
18610 mp_primitive(mp, "length",unary,length_op);
18611 @:length_}{\&{length} primitive@>
18612 mp_primitive(mp, "turningnumber",unary,turning_op);
18613 @:turning_number_}{\&{turningnumber} primitive@>
18614 mp_primitive(mp, "xpart",unary,x_part);
18615 @:x_part_}{\&{xpart} primitive@>
18616 mp_primitive(mp, "ypart",unary,y_part);
18617 @:y_part_}{\&{ypart} primitive@>
18618 mp_primitive(mp, "xxpart",unary,xx_part);
18619 @:xx_part_}{\&{xxpart} primitive@>
18620 mp_primitive(mp, "xypart",unary,xy_part);
18621 @:xy_part_}{\&{xypart} primitive@>
18622 mp_primitive(mp, "yxpart",unary,yx_part);
18623 @:yx_part_}{\&{yxpart} primitive@>
18624 mp_primitive(mp, "yypart",unary,yy_part);
18625 @:yy_part_}{\&{yypart} primitive@>
18626 mp_primitive(mp, "redpart",unary,red_part);
18627 @:red_part_}{\&{redpart} primitive@>
18628 mp_primitive(mp, "greenpart",unary,green_part);
18629 @:green_part_}{\&{greenpart} primitive@>
18630 mp_primitive(mp, "bluepart",unary,blue_part);
18631 @:blue_part_}{\&{bluepart} primitive@>
18632 mp_primitive(mp, "cyanpart",unary,cyan_part);
18633 @:cyan_part_}{\&{cyanpart} primitive@>
18634 mp_primitive(mp, "magentapart",unary,magenta_part);
18635 @:magenta_part_}{\&{magentapart} primitive@>
18636 mp_primitive(mp, "yellowpart",unary,yellow_part);
18637 @:yellow_part_}{\&{yellowpart} primitive@>
18638 mp_primitive(mp, "blackpart",unary,black_part);
18639 @:black_part_}{\&{blackpart} primitive@>
18640 mp_primitive(mp, "greypart",unary,grey_part);
18641 @:grey_part_}{\&{greypart} primitive@>
18642 mp_primitive(mp, "colormodel",unary,color_model_part);
18643 @:color_model_part_}{\&{colormodel} primitive@>
18644 mp_primitive(mp, "fontpart",unary,font_part);
18645 @:font_part_}{\&{fontpart} primitive@>
18646 mp_primitive(mp, "textpart",unary,text_part);
18647 @:text_part_}{\&{textpart} primitive@>
18648 mp_primitive(mp, "pathpart",unary,path_part);
18649 @:path_part_}{\&{pathpart} primitive@>
18650 mp_primitive(mp, "penpart",unary,pen_part);
18651 @:pen_part_}{\&{penpart} primitive@>
18652 mp_primitive(mp, "dashpart",unary,dash_part);
18653 @:dash_part_}{\&{dashpart} primitive@>
18654 mp_primitive(mp, "sqrt",unary,sqrt_op);
18655 @:sqrt_}{\&{sqrt} primitive@>
18656 mp_primitive(mp, "mexp",unary,m_exp_op);
18657 @:m_exp_}{\&{mexp} primitive@>
18658 mp_primitive(mp, "mlog",unary,m_log_op);
18659 @:m_log_}{\&{mlog} primitive@>
18660 mp_primitive(mp, "sind",unary,sin_d_op);
18661 @:sin_d_}{\&{sind} primitive@>
18662 mp_primitive(mp, "cosd",unary,cos_d_op);
18663 @:cos_d_}{\&{cosd} primitive@>
18664 mp_primitive(mp, "floor",unary,floor_op);
18665 @:floor_}{\&{floor} primitive@>
18666 mp_primitive(mp, "uniformdeviate",unary,uniform_deviate);
18667 @:uniform_deviate_}{\&{uniformdeviate} primitive@>
18668 mp_primitive(mp, "charexists",unary,char_exists_op);
18669 @:char_exists_}{\&{charexists} primitive@>
18670 mp_primitive(mp, "fontsize",unary,font_size);
18671 @:font_size_}{\&{fontsize} primitive@>
18672 mp_primitive(mp, "llcorner",unary,ll_corner_op);
18673 @:ll_corner_}{\&{llcorner} primitive@>
18674 mp_primitive(mp, "lrcorner",unary,lr_corner_op);
18675 @:lr_corner_}{\&{lrcorner} primitive@>
18676 mp_primitive(mp, "ulcorner",unary,ul_corner_op);
18677 @:ul_corner_}{\&{ulcorner} primitive@>
18678 mp_primitive(mp, "urcorner",unary,ur_corner_op);
18679 @:ur_corner_}{\&{urcorner} primitive@>
18680 mp_primitive(mp, "arclength",unary,arc_length);
18681 @:arc_length_}{\&{arclength} primitive@>
18682 mp_primitive(mp, "angle",unary,angle_op);
18683 @:angle_}{\&{angle} primitive@>
18684 mp_primitive(mp, "cycle",cycle,cycle_op);
18685 @:cycle_}{\&{cycle} primitive@>
18686 mp_primitive(mp, "stroked",unary,stroked_op);
18687 @:stroked_}{\&{stroked} primitive@>
18688 mp_primitive(mp, "filled",unary,filled_op);
18689 @:filled_}{\&{filled} primitive@>
18690 mp_primitive(mp, "textual",unary,textual_op);
18691 @:textual_}{\&{textual} primitive@>
18692 mp_primitive(mp, "clipped",unary,clipped_op);
18693 @:clipped_}{\&{clipped} primitive@>
18694 mp_primitive(mp, "bounded",unary,bounded_op);
18695 @:bounded_}{\&{bounded} primitive@>
18696 mp_primitive(mp, "+",plus_or_minus,plus);
18697 @:+ }{\.{+} primitive@>
18698 mp_primitive(mp, "-",plus_or_minus,minus);
18699 @:- }{\.{-} primitive@>
18700 mp_primitive(mp, "*",secondary_binary,times);
18701 @:* }{\.{*} primitive@>
18702 mp_primitive(mp, "/",slash,over); mp->eqtb[frozen_slash]=mp->eqtb[mp->cur_sym];
18703 @:/ }{\.{/} primitive@>
18704 mp_primitive(mp, "++",tertiary_binary,pythag_add);
18705 @:++_}{\.{++} primitive@>
18706 mp_primitive(mp, "+-+",tertiary_binary,pythag_sub);
18707 @:+-+_}{\.{+-+} primitive@>
18708 mp_primitive(mp, "or",tertiary_binary,or_op);
18709 @:or_}{\&{or} primitive@>
18710 mp_primitive(mp, "and",and_command,and_op);
18711 @:and_}{\&{and} primitive@>
18712 mp_primitive(mp, "<",expression_binary,less_than);
18713 @:< }{\.{<} primitive@>
18714 mp_primitive(mp, "<=",expression_binary,less_or_equal);
18715 @:<=_}{\.{<=} primitive@>
18716 mp_primitive(mp, ">",expression_binary,greater_than);
18717 @:> }{\.{>} primitive@>
18718 mp_primitive(mp, ">=",expression_binary,greater_or_equal);
18719 @:>=_}{\.{>=} primitive@>
18720 mp_primitive(mp, "=",equals,equal_to);
18721 @:= }{\.{=} primitive@>
18722 mp_primitive(mp, "<>",expression_binary,unequal_to);
18723 @:<>_}{\.{<>} primitive@>
18724 mp_primitive(mp, "substring",primary_binary,substring_of);
18725 @:substring_}{\&{substring} primitive@>
18726 mp_primitive(mp, "subpath",primary_binary,subpath_of);
18727 @:subpath_}{\&{subpath} primitive@>
18728 mp_primitive(mp, "directiontime",primary_binary,direction_time_of);
18729 @:direction_time_}{\&{directiontime} primitive@>
18730 mp_primitive(mp, "point",primary_binary,point_of);
18731 @:point_}{\&{point} primitive@>
18732 mp_primitive(mp, "precontrol",primary_binary,precontrol_of);
18733 @:precontrol_}{\&{precontrol} primitive@>
18734 mp_primitive(mp, "postcontrol",primary_binary,postcontrol_of);
18735 @:postcontrol_}{\&{postcontrol} primitive@>
18736 mp_primitive(mp, "penoffset",primary_binary,pen_offset_of);
18737 @:pen_offset_}{\&{penoffset} primitive@>
18738 mp_primitive(mp, "arctime",primary_binary,arc_time_of);
18739 @:arc_time_of_}{\&{arctime} primitive@>
18740 mp_primitive(mp, "mpversion",nullary,mp_version);
18741 @:mp_verison_}{\&{mpversion} primitive@>
18742 mp_primitive(mp, "&",ampersand,concatenate);
18743 @:!!!}{\.{\&} primitive@>
18744 mp_primitive(mp, "rotated",secondary_binary,rotated_by);
18745 @:rotated_}{\&{rotated} primitive@>
18746 mp_primitive(mp, "slanted",secondary_binary,slanted_by);
18747 @:slanted_}{\&{slanted} primitive@>
18748 mp_primitive(mp, "scaled",secondary_binary,scaled_by);
18749 @:scaled_}{\&{scaled} primitive@>
18750 mp_primitive(mp, "shifted",secondary_binary,shifted_by);
18751 @:shifted_}{\&{shifted} primitive@>
18752 mp_primitive(mp, "transformed",secondary_binary,transformed_by);
18753 @:transformed_}{\&{transformed} primitive@>
18754 mp_primitive(mp, "xscaled",secondary_binary,x_scaled);
18755 @:x_scaled_}{\&{xscaled} primitive@>
18756 mp_primitive(mp, "yscaled",secondary_binary,y_scaled);
18757 @:y_scaled_}{\&{yscaled} primitive@>
18758 mp_primitive(mp, "zscaled",secondary_binary,z_scaled);
18759 @:z_scaled_}{\&{zscaled} primitive@>
18760 mp_primitive(mp, "infont",secondary_binary,in_font);
18761 @:in_font_}{\&{infont} primitive@>
18762 mp_primitive(mp, "intersectiontimes",tertiary_binary,intersect);
18763 @:intersection_times_}{\&{intersectiontimes} primitive@>
18764 mp_primitive(mp, "envelope",primary_binary,envelope_of);
18765 @:envelope_}{\&{envelope} primitive@>
18767 @ @<Cases of |print_cmd...@>=
18770 case primary_binary:
18771 case secondary_binary:
18772 case tertiary_binary:
18773 case expression_binary:
18775 case plus_or_minus:
18780 mp_print_op(mp, m);
18783 @ OK, let's look at the simplest \\{do} procedure first.
18785 @c @<Declare nullary action procedure@>
18786 void mp_do_nullary (MP mp,quarterword c) {
18788 if ( mp->internal[mp_tracing_commands]>two )
18789 mp_show_cmd_mod(mp, nullary,c);
18791 case true_code: case false_code:
18792 mp->cur_type=mp_boolean_type; mp->cur_exp=c;
18794 case null_picture_code:
18795 mp->cur_type=mp_picture_type;
18796 mp->cur_exp=mp_get_node(mp, edge_header_size);
18797 mp_init_edges(mp, mp->cur_exp);
18799 case null_pen_code:
18800 mp->cur_type=mp_pen_type; mp->cur_exp=mp_get_pen_circle(mp, 0);
18802 case normal_deviate:
18803 mp->cur_type=mp_known; mp->cur_exp=mp_norm_rand(mp);
18806 mp->cur_type=mp_pen_type; mp->cur_exp=mp_get_pen_circle(mp, unity);
18809 if ( mp->job_name==NULL ) mp_open_log_file(mp);
18810 mp->cur_type=mp_string_type; mp->cur_exp=rts(mp->job_name);
18813 mp->cur_type=mp_string_type;
18814 mp->cur_exp=intern(metapost_version) ;
18816 case read_string_op:
18817 @<Read a string from the terminal@>;
18819 } /* there are no other cases */
18823 @ @<Read a string...@>=
18825 if ( mp->interaction<=mp_nonstop_mode )
18826 mp_fatal_error(mp, "*** (cannot readstring in nonstop modes)");
18827 mp_begin_file_reading(mp); name=is_read;
18828 limit=start; prompt_input("");
18829 mp_finish_read(mp);
18832 @ @<Declare nullary action procedure@>=
18833 void mp_finish_read (MP mp) { /* copy |buffer| line to |cur_exp| */
18835 str_room((int)mp->last-start);
18836 for (k=start;k<=mp->last-1;k++) {
18837 append_char(mp->buffer[k]);
18839 mp_end_file_reading(mp); mp->cur_type=mp_string_type;
18840 mp->cur_exp=mp_make_string(mp);
18843 @ Things get a bit more interesting when there's an operand. The
18844 operand to |do_unary| appears in |cur_type| and |cur_exp|.
18846 @c @<Declare unary action procedures@>
18847 void mp_do_unary (MP mp,quarterword c) {
18848 pointer p,q,r; /* for list manipulation */
18849 integer x; /* a temporary register */
18851 if ( mp->internal[mp_tracing_commands]>two )
18852 @<Trace the current unary operation@>;
18855 if ( mp->cur_type<mp_color_type ) mp_bad_unary(mp, plus);
18858 @<Negate the current expression@>;
18860 @<Additional cases of unary operators@>;
18861 } /* there are no other cases */
18865 @ The |nice_pair| function returns |true| if both components of a pair
18868 @<Declare unary action procedures@>=
18869 boolean mp_nice_pair (MP mp,integer p, quarterword t) {
18870 if ( t==mp_pair_type ) {
18872 if ( type(x_part_loc(p))==mp_known )
18873 if ( type(y_part_loc(p))==mp_known )
18879 @ The |nice_color_or_pair| function is analogous except that it also accepts
18880 fully known colors.
18882 @<Declare unary action procedures@>=
18883 boolean mp_nice_color_or_pair (MP mp,integer p, quarterword t) {
18884 pointer q,r; /* for scanning the big node */
18885 if ( (t!=mp_pair_type)&&(t!=mp_color_type)&&(t!=mp_cmykcolor_type) ) {
18889 r=q+mp->big_node_size[type(p)];
18892 if ( type(r)!=mp_known )
18899 @ @<Declare unary action...@>=
18900 void mp_print_known_or_unknown_type (MP mp,small_number t, integer v) {
18901 mp_print_char(mp, '(');
18902 if ( t>mp_known ) mp_print(mp, "unknown numeric");
18903 else { if ( (t==mp_pair_type)||(t==mp_color_type)||(t==mp_cmykcolor_type) )
18904 if ( ! mp_nice_color_or_pair(mp, v,t) ) mp_print(mp, "unknown ");
18905 mp_print_type(mp, t);
18907 mp_print_char(mp, ')');
18910 @ @<Declare unary action...@>=
18911 void mp_bad_unary (MP mp,quarterword c) {
18912 exp_err("Not implemented: "); mp_print_op(mp, c);
18913 @.Not implemented...@>
18914 mp_print_known_or_unknown_type(mp, mp->cur_type,mp->cur_exp);
18915 help3("I'm afraid I don't know how to apply that operation to that")
18916 ("particular type. Continue, and I'll simply return the")
18917 ("argument (shown above) as the result of the operation.");
18918 mp_put_get_error(mp);
18921 @ @<Trace the current unary operation@>=
18923 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
18924 mp_print_op(mp, c); mp_print_char(mp, '(');
18925 mp_print_exp(mp, null,0); /* show the operand, but not verbosely */
18926 mp_print(mp, ")}"); mp_end_diagnostic(mp, false);
18929 @ Negation is easy except when the current expression
18930 is of type |independent|, or when it is a pair with one or more
18931 |independent| components.
18933 It is tempting to argue that the negative of an independent variable
18934 is an independent variable, hence we don't have to do anything when
18935 negating it. The fallacy is that other dependent variables pointing
18936 to the current expression must change the sign of their
18937 coefficients if we make no change to the current expression.
18939 Instead, we work around the problem by copying the current expression
18940 and recycling it afterwards (cf.~the |stash_in| routine).
18942 @<Negate the current expression@>=
18943 switch (mp->cur_type) {
18944 case mp_color_type:
18945 case mp_cmykcolor_type:
18947 case mp_independent:
18948 q=mp->cur_exp; mp_make_exp_copy(mp, q);
18949 if ( mp->cur_type==mp_dependent ) {
18950 mp_negate_dep_list(mp, dep_list(mp->cur_exp));
18951 } else if ( mp->cur_type<=mp_pair_type ) { /* |mp_color_type| or |mp_pair_type| */
18952 p=value(mp->cur_exp);
18953 r=p+mp->big_node_size[mp->cur_type];
18956 if ( type(r)==mp_known ) negate(value(r));
18957 else mp_negate_dep_list(mp, dep_list(r));
18959 } /* if |cur_type=mp_known| then |cur_exp=0| */
18960 mp_recycle_value(mp, q); mp_free_node(mp, q,value_node_size);
18963 case mp_proto_dependent:
18964 mp_negate_dep_list(mp, dep_list(mp->cur_exp));
18967 negate(mp->cur_exp);
18970 mp_bad_unary(mp, minus);
18974 @ @<Declare unary action...@>=
18975 void mp_negate_dep_list (MP mp,pointer p) {
18978 if ( info(p)==null ) return;
18983 @ @<Additional cases of unary operators@>=
18985 if ( mp->cur_type!=mp_boolean_type ) mp_bad_unary(mp, not_op);
18986 else mp->cur_exp=true_code+false_code-mp->cur_exp;
18989 @ @d three_sixty_units 23592960 /* that's |360*unity| */
18990 @d boolean_reset(A) if ( (A) ) mp->cur_exp=true_code; else mp->cur_exp=false_code
18992 @<Additional cases of unary operators@>=
18999 case uniform_deviate:
19001 case char_exists_op:
19002 if ( mp->cur_type!=mp_known ) {
19003 mp_bad_unary(mp, c);
19006 case sqrt_op:mp->cur_exp=mp_square_rt(mp, mp->cur_exp);break;
19007 case m_exp_op:mp->cur_exp=mp_m_exp(mp, mp->cur_exp);break;
19008 case m_log_op:mp->cur_exp=mp_m_log(mp, mp->cur_exp);break;
19011 mp_n_sin_cos(mp, (mp->cur_exp % three_sixty_units)*16);
19012 if ( c==sin_d_op ) mp->cur_exp=mp_round_fraction(mp, mp->n_sin);
19013 else mp->cur_exp=mp_round_fraction(mp, mp->n_cos);
19015 case floor_op:mp->cur_exp=mp_floor_scaled(mp, mp->cur_exp);break;
19016 case uniform_deviate:mp->cur_exp=mp_unif_rand(mp, mp->cur_exp);break;
19018 boolean_reset(odd(mp_round_unscaled(mp, mp->cur_exp)));
19019 mp->cur_type=mp_boolean_type;
19021 case char_exists_op:
19022 @<Determine if a character has been shipped out@>;
19024 } /* there are no other cases */
19028 @ @<Additional cases of unary operators@>=
19030 if ( mp_nice_pair(mp, mp->cur_exp,mp->cur_type) ) {
19031 p=value(mp->cur_exp);
19032 x=mp_n_arg(mp, value(x_part_loc(p)),value(y_part_loc(p)));
19033 if ( x>=0 ) mp_flush_cur_exp(mp, (x+8)/ 16);
19034 else mp_flush_cur_exp(mp, -((-x+8)/ 16));
19036 mp_bad_unary(mp, angle_op);
19040 @ If the current expression is a pair, but the context wants it to
19041 be a path, we call |pair_to_path|.
19043 @<Declare unary action...@>=
19044 void mp_pair_to_path (MP mp) {
19045 mp->cur_exp=mp_new_knot(mp);
19046 mp->cur_type=mp_path_type;
19050 @d pict_color_type(A) ((link(dummy_loc(mp->cur_exp))!=null) &&
19051 (has_color(link(dummy_loc(mp->cur_exp)))) &&
19052 ((color_model(link(dummy_loc(mp->cur_exp)))==A)
19054 ((color_model(link(dummy_loc(mp->cur_exp)))==mp_uninitialized_model) &&
19055 (mp->internal[mp_default_color_model]/unity)==(A))))
19057 @<Additional cases of unary operators@>=
19060 if ( (mp->cur_type==mp_pair_type)||(mp->cur_type==mp_transform_type) )
19061 mp_take_part(mp, c);
19062 else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
19063 else mp_bad_unary(mp, c);
19069 if ( mp->cur_type==mp_transform_type ) mp_take_part(mp, c);
19070 else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
19071 else mp_bad_unary(mp, c);
19076 if ( mp->cur_type==mp_color_type ) mp_take_part(mp, c);
19077 else if ( mp->cur_type==mp_picture_type ) {
19078 if pict_color_type(mp_rgb_model) mp_take_pict_part(mp, c);
19079 else mp_bad_color_part(mp, c);
19081 else mp_bad_unary(mp, c);
19087 if ( mp->cur_type==mp_cmykcolor_type) mp_take_part(mp, c);
19088 else if ( mp->cur_type==mp_picture_type ) {
19089 if pict_color_type(mp_cmyk_model) mp_take_pict_part(mp, c);
19090 else mp_bad_color_part(mp, c);
19092 else mp_bad_unary(mp, c);
19095 if ( mp->cur_type==mp_known ) mp->cur_exp=value(c);
19096 else if ( mp->cur_type==mp_picture_type ) {
19097 if pict_color_type(mp_grey_model) mp_take_pict_part(mp, c);
19098 else mp_bad_color_part(mp, c);
19100 else mp_bad_unary(mp, c);
19102 case color_model_part:
19103 if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
19104 else mp_bad_unary(mp, c);
19107 @ @<Declarations@>=
19108 void mp_bad_color_part(MP mp, quarterword c);
19111 void mp_bad_color_part(MP mp, quarterword c) {
19112 pointer p; /* the big node */
19113 p=link(dummy_loc(mp->cur_exp));
19114 exp_err("Wrong picture color model: "); mp_print_op(mp, c);
19115 @.Wrong picture color model...@>
19116 if (color_model(p)==mp_grey_model)
19117 mp_print(mp, " of grey object");
19118 else if (color_model(p)==mp_cmyk_model)
19119 mp_print(mp, " of cmyk object");
19120 else if (color_model(p)==mp_rgb_model)
19121 mp_print(mp, " of rgb object");
19122 else if (color_model(p)==mp_no_model)
19123 mp_print(mp, " of marking object");
19125 mp_print(mp," of defaulted object");
19126 help3("You can only ask for the redpart, greenpart, bluepart of a rgb object,")
19127 ("the cyanpart, magentapart, yellowpart or blackpart of a cmyk object, ")
19128 ("or the greypart of a grey object. No mixing and matching, please.");
19131 mp_flush_cur_exp(mp,unity);
19133 mp_flush_cur_exp(mp,0);
19136 @ In the following procedure, |cur_exp| points to a capsule, which points to
19137 a big node. We want to delete all but one part of the big node.
19139 @<Declare unary action...@>=
19140 void mp_take_part (MP mp,quarterword c) {
19141 pointer p; /* the big node */
19142 p=value(mp->cur_exp); value(temp_val)=p; type(temp_val)=mp->cur_type;
19143 link(p)=temp_val; mp_free_node(mp, mp->cur_exp,value_node_size);
19144 mp_make_exp_copy(mp, p+mp->sector_offset[c+mp_x_part_sector-x_part]);
19145 mp_recycle_value(mp, temp_val);
19148 @ @<Initialize table entries...@>=
19149 name_type(temp_val)=mp_capsule;
19151 @ @<Additional cases of unary operators@>=
19157 if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
19158 else mp_bad_unary(mp, c);
19161 @ @<Declarations@>=
19162 void mp_scale_edges (MP mp);
19164 @ @<Declare unary action...@>=
19165 void mp_take_pict_part (MP mp,quarterword c) {
19166 pointer p; /* first graphical object in |cur_exp| */
19167 p=link(dummy_loc(mp->cur_exp));
19170 case x_part: case y_part: case xx_part:
19171 case xy_part: case yx_part: case yy_part:
19172 if ( type(p)==mp_text_code ) mp_flush_cur_exp(mp, text_trans_part(p+c));
19173 else goto NOT_FOUND;
19175 case red_part: case green_part: case blue_part:
19176 if ( has_color(p) ) mp_flush_cur_exp(mp, obj_color_part(p+c));
19177 else goto NOT_FOUND;
19179 case cyan_part: case magenta_part: case yellow_part:
19181 if ( has_color(p) ) {
19182 if ( color_model(p)==mp_uninitialized_model && c==black_part)
19183 mp_flush_cur_exp(mp, unity);
19185 mp_flush_cur_exp(mp, obj_color_part(p+c+(red_part-cyan_part)));
19186 } else goto NOT_FOUND;
19189 if ( has_color(p) )
19190 mp_flush_cur_exp(mp, obj_color_part(p+c+(red_part-grey_part)));
19191 else goto NOT_FOUND;
19193 case color_model_part:
19194 if ( has_color(p) ) {
19195 if ( color_model(p)==mp_uninitialized_model )
19196 mp_flush_cur_exp(mp, mp->internal[mp_default_color_model]);
19198 mp_flush_cur_exp(mp, color_model(p)*unity);
19199 } else goto NOT_FOUND;
19201 @<Handle other cases in |take_pict_part| or |goto not_found|@>;
19202 } /* all cases have been enumerated */
19206 @<Convert the current expression to a null value appropriate
19210 @ @<Handle other cases in |take_pict_part| or |goto not_found|@>=
19212 if ( type(p)!=mp_text_code ) goto NOT_FOUND;
19214 mp_flush_cur_exp(mp, text_p(p));
19215 add_str_ref(mp->cur_exp);
19216 mp->cur_type=mp_string_type;
19220 if ( type(p)!=mp_text_code ) goto NOT_FOUND;
19222 mp_flush_cur_exp(mp, rts(mp->font_name[font_n(p)]));
19223 add_str_ref(mp->cur_exp);
19224 mp->cur_type=mp_string_type;
19228 if ( type(p)==mp_text_code ) goto NOT_FOUND;
19229 else if ( is_stop(p) ) mp_confusion(mp, "pict");
19230 @:this can't happen pict}{\quad pict@>
19232 mp_flush_cur_exp(mp, mp_copy_path(mp, path_p(p)));
19233 mp->cur_type=mp_path_type;
19237 if ( ! has_pen(p) ) goto NOT_FOUND;
19239 if ( pen_p(p)==null ) goto NOT_FOUND;
19240 else { mp_flush_cur_exp(mp, copy_pen(pen_p(p)));
19241 mp->cur_type=mp_pen_type;
19246 if ( type(p)!=mp_stroked_code ) goto NOT_FOUND;
19247 else { if ( dash_p(p)==null ) goto NOT_FOUND;
19248 else { add_edge_ref(dash_p(p));
19249 mp->se_sf=dash_scale(p);
19250 mp->se_pic=dash_p(p);
19251 mp_scale_edges(mp);
19252 mp_flush_cur_exp(mp, mp->se_pic);
19253 mp->cur_type=mp_picture_type;
19258 @ Since |scale_edges| had to be declared |forward|, it had to be declared as a
19259 parameterless procedure even though it really takes two arguments and updates
19260 one of them. Hence the following globals are needed.
19263 pointer se_pic; /* edge header used and updated by |scale_edges| */
19264 scaled se_sf; /* the scale factor argument to |scale_edges| */
19266 @ @<Convert the current expression to a null value appropriate...@>=
19268 case text_part: case font_part:
19269 mp_flush_cur_exp(mp, rts(""));
19270 mp->cur_type=mp_string_type;
19273 mp_flush_cur_exp(mp, mp_get_node(mp, knot_node_size));
19274 left_type(mp->cur_exp)=mp_endpoint;
19275 right_type(mp->cur_exp)=mp_endpoint;
19276 link(mp->cur_exp)=mp->cur_exp;
19277 x_coord(mp->cur_exp)=0;
19278 y_coord(mp->cur_exp)=0;
19279 originator(mp->cur_exp)=mp_metapost_user;
19280 mp->cur_type=mp_path_type;
19283 mp_flush_cur_exp(mp, mp_get_pen_circle(mp, 0));
19284 mp->cur_type=mp_pen_type;
19287 mp_flush_cur_exp(mp, mp_get_node(mp, edge_header_size));
19288 mp_init_edges(mp, mp->cur_exp);
19289 mp->cur_type=mp_picture_type;
19292 mp_flush_cur_exp(mp, 0);
19296 @ @<Additional cases of unary...@>=
19298 if ( mp->cur_type!=mp_known ) {
19299 mp_bad_unary(mp, char_op);
19301 mp->cur_exp=mp_round_unscaled(mp, mp->cur_exp) % 256;
19302 mp->cur_type=mp_string_type;
19303 if ( mp->cur_exp<0 ) mp->cur_exp=mp->cur_exp+256;
19307 if ( mp->cur_type!=mp_known ) {
19308 mp_bad_unary(mp, decimal);
19310 mp->old_setting=mp->selector; mp->selector=new_string;
19311 mp_print_scaled(mp, mp->cur_exp); mp->cur_exp=mp_make_string(mp);
19312 mp->selector=mp->old_setting; mp->cur_type=mp_string_type;
19318 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, c);
19319 else mp_str_to_num(mp, c);
19322 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, font_size);
19323 else @<Find the design size of the font whose name is |cur_exp|@>;
19326 @ @<Declare unary action...@>=
19327 void mp_str_to_num (MP mp,quarterword c) { /* converts a string to a number */
19328 integer n; /* accumulator */
19329 ASCII_code m; /* current character */
19330 pool_pointer k; /* index into |str_pool| */
19331 int b; /* radix of conversion */
19332 boolean bad_char; /* did the string contain an invalid digit? */
19333 if ( c==ASCII_op ) {
19334 if ( length(mp->cur_exp)==0 ) n=-1;
19335 else n=mp->str_pool[mp->str_start[mp->cur_exp]];
19337 if ( c==oct_op ) b=8; else b=16;
19338 n=0; bad_char=false;
19339 for (k=mp->str_start[mp->cur_exp];k<=str_stop(mp->cur_exp)-1;k++) {
19341 if ( (m>='0')&&(m<='9') ) m=m-'0';
19342 else if ( (m>='A')&&(m<='F') ) m=m-'A'+10;
19343 else if ( (m>='a')&&(m<='f') ) m=m-'a'+10;
19344 else { bad_char=true; m=0; };
19345 if ( m>=b ) { bad_char=true; m=0; };
19346 if ( n<32768 / b ) n=n*b+m; else n=32767;
19348 @<Give error messages if |bad_char| or |n>=4096|@>;
19350 mp_flush_cur_exp(mp, n*unity);
19353 @ @<Give error messages if |bad_char|...@>=
19355 exp_err("String contains illegal digits");
19356 @.String contains illegal digits@>
19358 help1("I zeroed out characters that weren't in the range 0..7.");
19360 help1("I zeroed out characters that weren't hex digits.");
19362 mp_put_get_error(mp);
19365 if ( mp->internal[mp_warning_check]>0 ) {
19366 print_err("Number too large (");
19367 mp_print_int(mp, n); mp_print_char(mp, ')');
19368 @.Number too large@>
19369 help2("I have trouble with numbers greater than 4095; watch out.")
19370 ("(Set warningcheck:=0 to suppress this message.)");
19371 mp_put_get_error(mp);
19375 @ The length operation is somewhat unusual in that it applies to a variety
19376 of different types of operands.
19378 @<Additional cases of unary...@>=
19380 switch (mp->cur_type) {
19381 case mp_string_type: mp_flush_cur_exp(mp, length(mp->cur_exp)*unity); break;
19382 case mp_path_type: mp_flush_cur_exp(mp, mp_path_length(mp)); break;
19383 case mp_known: mp->cur_exp=abs(mp->cur_exp); break;
19384 case mp_picture_type: mp_flush_cur_exp(mp, mp_pict_length(mp)); break;
19386 if ( mp_nice_pair(mp, mp->cur_exp,mp->cur_type) )
19387 mp_flush_cur_exp(mp, mp_pyth_add(mp,
19388 value(x_part_loc(value(mp->cur_exp))),
19389 value(y_part_loc(value(mp->cur_exp)))));
19390 else mp_bad_unary(mp, c);
19395 @ @<Declare unary action...@>=
19396 scaled mp_path_length (MP mp) { /* computes the length of the current path */
19397 scaled n; /* the path length so far */
19398 pointer p; /* traverser */
19400 if ( left_type(p)==mp_endpoint ) n=-unity; else n=0;
19401 do { p=link(p); n=n+unity; } while (p!=mp->cur_exp);
19405 @ @<Declare unary action...@>=
19406 scaled mp_pict_length (MP mp) {
19407 /* counts interior components in picture |cur_exp| */
19408 scaled n; /* the count so far */
19409 pointer p; /* traverser */
19411 p=link(dummy_loc(mp->cur_exp));
19413 if ( is_start_or_stop(p) )
19414 if ( mp_skip_1component(mp, p)==null ) p=link(p);
19415 while ( p!=null ) {
19416 skip_component(p) return n;
19423 @ Implement |turningnumber|
19425 @<Additional cases of unary...@>=
19427 if ( mp->cur_type==mp_pair_type ) mp_flush_cur_exp(mp, 0);
19428 else if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, turning_op);
19429 else if ( left_type(mp->cur_exp)==mp_endpoint )
19430 mp_flush_cur_exp(mp, 0); /* not a cyclic path */
19432 mp_flush_cur_exp(mp, mp_turn_cycles_wrapper(mp, mp->cur_exp));
19435 @ The function |an_angle| returns the value of the |angle| primitive, or $0$ if the
19436 argument is |origin|.
19438 @<Declare unary action...@>=
19439 angle mp_an_angle (MP mp,scaled xpar, scaled ypar) {
19440 if ( (! ((xpar==0) && (ypar==0))) )
19441 return mp_n_arg(mp, xpar,ypar);
19446 @ The actual turning number is (for the moment) computed in a C function
19447 that receives eight integers corresponding to the four controlling points,
19448 and returns a single angle. Besides those, we have to account for discrete
19449 moves at the actual points.
19451 @d floor(a) (a>=0 ? a : -(int)(-a))
19452 @d bezier_error (720<<20)+1
19453 @d sign(v) ((v)>0 ? 1 : ((v)<0 ? -1 : 0 ))
19455 @d out ((double)(xo>>20))
19456 @d mid ((double)(xm>>20))
19457 @d in ((double)(xi>>20))
19458 @d divisor (256*256)
19459 @d double2angle(a) (int)floor(a*256.0*256.0*16.0)
19461 @<Declare unary action...@>=
19462 angle mp_bezier_slope(MP mp, integer AX,integer AY,integer BX,integer BY,
19463 integer CX,integer CY,integer DX,integer DY);
19466 angle mp_bezier_slope(MP mp, integer AX,integer AY,integer BX,integer BY,
19467 integer CX,integer CY,integer DX,integer DY) {
19469 integer deltax,deltay;
19470 double ax,ay,bx,by,cx,cy,dx,dy;
19471 angle xi = 0, xo = 0, xm = 0;
19473 ax=AX/divisor; ay=AY/divisor;
19474 bx=BX/divisor; by=BY/divisor;
19475 cx=CX/divisor; cy=CY/divisor;
19476 dx=DX/divisor; dy=DY/divisor;
19478 deltax = (BX-AX); deltay = (BY-AY);
19479 if (deltax==0 && deltay == 0) { deltax=(CX-AX); deltay=(CY-AY); }
19480 if (deltax==0 && deltay == 0) { deltax=(DX-AX); deltay=(DY-AY); }
19481 xi = mp_an_angle(mp,deltax,deltay);
19483 deltax = (CX-BX); deltay = (CY-BY);
19484 xm = mp_an_angle(mp,deltax,deltay);
19486 deltax = (DX-CX); deltay = (DY-CY);
19487 if (deltax==0 && deltay == 0) { deltax=(DX-BX); deltay=(DY-BY); }
19488 if (deltax==0 && deltay == 0) { deltax=(DX-AX); deltay=(DY-AY); }
19489 xo = mp_an_angle(mp,deltax,deltay);
19491 a = (bx-ax)*(cy-by) - (cx-bx)*(by-ay); /* a = (bp-ap)x(cp-bp); */
19492 b = (bx-ax)*(dy-cy) - (by-ay)*(dx-cx);; /* b = (bp-ap)x(dp-cp);*/
19493 c = (cx-bx)*(dy-cy) - (dx-cx)*(cy-by); /* c = (cp-bp)x(dp-cp);*/
19495 if ((a==0)&&(c==0)) {
19496 res = (b==0 ? 0 : (out-in));
19497 print_roots("no roots (a)");
19498 } else if ((a==0)||(c==0)) {
19499 if ((sign(b) == sign(a)) || (sign(b) == sign(c))) {
19500 res = out-in; /* ? */
19503 else if (res>180.0)
19505 print_roots("no roots (b)");
19507 res = out-in; /* ? */
19508 print_roots("one root (a)");
19510 } else if ((sign(a)*sign(c))<0) {
19511 res = out-in; /* ? */
19514 else if (res>180.0)
19516 print_roots("one root (b)");
19518 if (sign(a) == sign(b)) {
19519 res = out-in; /* ? */
19522 else if (res>180.0)
19524 print_roots("no roots (d)");
19526 if ((b*b) == (4*a*c)) {
19527 res = bezier_error;
19528 print_roots("double root"); /* cusp */
19529 } else if ((b*b) < (4*a*c)) {
19530 res = out-in; /* ? */
19531 if (res<=0.0 &&res>-180.0)
19533 else if (res>=0.0 && res<180.0)
19535 print_roots("no roots (e)");
19540 else if (res>180.0)
19542 print_roots("two roots"); /* two inflections */
19546 return double2angle(res);
19550 @d p_nextnext link(link(p))
19552 @d seven_twenty_deg 05500000000 /* $720\cdot2^{20}$, represents $720^\circ$ */
19554 @<Declare unary action...@>=
19555 scaled mp_new_turn_cycles (MP mp,pointer c) {
19556 angle res,ang; /* the angles of intermediate results */
19557 scaled turns; /* the turn counter */
19558 pointer p; /* for running around the path */
19559 integer xp,yp; /* coordinates of next point */
19560 integer x,y; /* helper coordinates */
19561 angle in_angle,out_angle; /* helper angles */
19562 int old_setting; /* saved |selector| setting */
19566 old_setting = mp->selector; mp->selector=term_only;
19567 if ( mp->internal[mp_tracing_commands]>unity ) {
19568 mp_begin_diagnostic(mp);
19569 mp_print_nl(mp, "");
19570 mp_end_diagnostic(mp, false);
19573 xp = x_coord(p_next); yp = y_coord(p_next);
19574 ang = mp_bezier_slope(mp,x_coord(p), y_coord(p), right_x(p), right_y(p),
19575 left_x(p_next), left_y(p_next), xp, yp);
19576 if ( ang>seven_twenty_deg ) {
19577 print_err("Strange path");
19579 mp->selector=old_setting;
19583 if ( res > one_eighty_deg ) {
19584 res = res - three_sixty_deg;
19585 turns = turns + unity;
19587 if ( res <= -one_eighty_deg ) {
19588 res = res + three_sixty_deg;
19589 turns = turns - unity;
19591 /* incoming angle at next point */
19592 x = left_x(p_next); y = left_y(p_next);
19593 if ( (xp==x)&&(yp==y) ) { x = right_x(p); y = right_y(p); };
19594 if ( (xp==x)&&(yp==y) ) { x = x_coord(p); y = y_coord(p); };
19595 in_angle = mp_an_angle(mp, xp - x, yp - y);
19596 /* outgoing angle at next point */
19597 x = right_x(p_next); y = right_y(p_next);
19598 if ( (xp==x)&&(yp==y) ) { x = left_x(p_nextnext); y = left_y(p_nextnext); };
19599 if ( (xp==x)&&(yp==y) ) { x = x_coord(p_nextnext); y = y_coord(p_nextnext); };
19600 out_angle = mp_an_angle(mp, x - xp, y- yp);
19601 ang = (out_angle - in_angle);
19605 if ( res >= one_eighty_deg ) {
19606 res = res - three_sixty_deg;
19607 turns = turns + unity;
19609 if ( res <= -one_eighty_deg ) {
19610 res = res + three_sixty_deg;
19611 turns = turns - unity;
19616 mp->selector=old_setting;
19621 @ This code is based on Bogus\l{}av Jackowski's
19622 |emergency_turningnumber| macro, with some minor changes by Taco
19623 Hoekwater. The macro code looked more like this:
19625 vardef turning\_number primary p =
19626 ~~save res, ang, turns;
19628 ~~if length p <= 2:
19629 ~~~~if Angle ((point 0 of p) - (postcontrol 0 of p)) >= 0: 1 else: -1 fi
19631 ~~~~for t = 0 upto length p-1 :
19632 ~~~~~~angc := Angle ((point t+1 of p) - (point t of p))
19633 ~~~~~~~~- Angle ((point t of p) - (point t-1 of p));
19634 ~~~~~~if angc > 180: angc := angc - 360; fi;
19635 ~~~~~~if angc < -180: angc := angc + 360; fi;
19636 ~~~~~~res := res + angc;
19641 The general idea is to calculate only the sum of the angles of
19642 straight lines between the points, of a path, not worrying about cusps
19643 or self-intersections in the segments at all. If the segment is not
19644 well-behaved, the result is not necesarily correct. But the old code
19645 was not always correct either, and worse, it sometimes failed for
19646 well-behaved paths as well. All known bugs that were triggered by the
19647 original code no longer occur with this code, and it runs roughly 3
19648 times as fast because the algorithm is much simpler.
19650 @ It is possible to overflow the return value of the |turn_cycles|
19651 function when the path is sufficiently long and winding, but I am not
19652 going to bother testing for that. In any case, it would only return
19653 the looped result value, which is not a big problem.
19655 The macro code for the repeat loop was a bit nicer to look
19656 at than the pascal code, because it could use |point -1 of p|. In
19657 pascal, the fastest way to loop around the path is not to look
19658 backward once, but forward twice. These defines help hide the trick.
19660 @d p_to link(link(p))
19664 @<Declare unary action...@>=
19665 scaled mp_turn_cycles (MP mp,pointer c) {
19666 angle res,ang; /* the angles of intermediate results */
19667 scaled turns; /* the turn counter */
19668 pointer p; /* for running around the path */
19669 res=0; turns= 0; p=c;
19671 ang = mp_an_angle (mp, x_coord(p_to) - x_coord(p_here),
19672 y_coord(p_to) - y_coord(p_here))
19673 - mp_an_angle (mp, x_coord(p_here) - x_coord(p_from),
19674 y_coord(p_here) - y_coord(p_from));
19677 if ( res >= three_sixty_deg ) {
19678 res = res - three_sixty_deg;
19679 turns = turns + unity;
19681 if ( res <= -three_sixty_deg ) {
19682 res = res + three_sixty_deg;
19683 turns = turns - unity;
19690 @ @<Declare unary action...@>=
19691 scaled mp_turn_cycles_wrapper (MP mp,pointer c) {
19693 scaled saved_t_o; /* tracing\_online saved */
19694 if ( (link(c)==c)||(link(link(c))==c) ) {
19695 if ( mp_an_angle (mp, x_coord(c) - right_x(c), y_coord(c) - right_y(c)) > 0 )
19700 nval = mp_new_turn_cycles(mp, c);
19701 oval = mp_turn_cycles(mp, c);
19702 if ( nval!=oval ) {
19703 saved_t_o=mp->internal[mp_tracing_online];
19704 mp->internal[mp_tracing_online]=unity;
19705 mp_begin_diagnostic(mp);
19706 mp_print_nl (mp, "Warning: the turningnumber algorithms do not agree."
19707 " The current computed value is ");
19708 mp_print_scaled(mp, nval);
19709 mp_print(mp, ", but the 'connect-the-dots' algorithm returned ");
19710 mp_print_scaled(mp, oval);
19711 mp_end_diagnostic(mp, false);
19712 mp->internal[mp_tracing_online]=saved_t_o;
19718 @ @<Declare unary action...@>=
19719 scaled mp_count_turns (MP mp,pointer c) {
19720 pointer p; /* a knot in envelope spec |c| */
19721 integer t; /* total pen offset changes counted */
19724 t=t+info(p)-zero_off;
19727 return ((t / 3)*unity);
19730 @ @d type_range(A,B) {
19731 if ( (mp->cur_type>=(A)) && (mp->cur_type<=(B)) )
19732 mp_flush_cur_exp(mp, true_code);
19733 else mp_flush_cur_exp(mp, false_code);
19734 mp->cur_type=mp_boolean_type;
19737 if ( mp->cur_type==(A) ) mp_flush_cur_exp(mp, true_code);
19738 else mp_flush_cur_exp(mp, false_code);
19739 mp->cur_type=mp_boolean_type;
19742 @<Additional cases of unary operators@>=
19743 case mp_boolean_type:
19744 type_range(mp_boolean_type,mp_unknown_boolean); break;
19745 case mp_string_type:
19746 type_range(mp_string_type,mp_unknown_string); break;
19748 type_range(mp_pen_type,mp_unknown_pen); break;
19750 type_range(mp_path_type,mp_unknown_path); break;
19751 case mp_picture_type:
19752 type_range(mp_picture_type,mp_unknown_picture); break;
19753 case mp_transform_type: case mp_color_type: case mp_cmykcolor_type:
19755 type_test(c); break;
19756 case mp_numeric_type:
19757 type_range(mp_known,mp_independent); break;
19758 case known_op: case unknown_op:
19759 mp_test_known(mp, c); break;
19761 @ @<Declare unary action procedures@>=
19762 void mp_test_known (MP mp,quarterword c) {
19763 int b; /* is the current expression known? */
19764 pointer p,q; /* locations in a big node */
19766 switch (mp->cur_type) {
19767 case mp_vacuous: case mp_boolean_type: case mp_string_type:
19768 case mp_pen_type: case mp_path_type: case mp_picture_type:
19772 case mp_transform_type:
19773 case mp_color_type: case mp_cmykcolor_type: case mp_pair_type:
19774 p=value(mp->cur_exp);
19775 q=p+mp->big_node_size[mp->cur_type];
19778 if ( type(q)!=mp_known )
19787 if ( c==known_op ) mp_flush_cur_exp(mp, b);
19788 else mp_flush_cur_exp(mp, true_code+false_code-b);
19789 mp->cur_type=mp_boolean_type;
19792 @ @<Additional cases of unary operators@>=
19794 if ( mp->cur_type!=mp_path_type ) mp_flush_cur_exp(mp, false_code);
19795 else if ( left_type(mp->cur_exp)!=mp_endpoint ) mp_flush_cur_exp(mp, true_code);
19796 else mp_flush_cur_exp(mp, false_code);
19797 mp->cur_type=mp_boolean_type;
19800 @ @<Additional cases of unary operators@>=
19802 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19803 if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, arc_length);
19804 else mp_flush_cur_exp(mp, mp_get_arc_length(mp, mp->cur_exp));
19807 @ Here we use the fact that |c-filled_op+fill_code| is the desired graphical
19809 @^data structure assumptions@>
19811 @<Additional cases of unary operators@>=
19817 if ( mp->cur_type!=mp_picture_type ) mp_flush_cur_exp(mp, false_code);
19818 else if ( link(dummy_loc(mp->cur_exp))==null ) mp_flush_cur_exp(mp, false_code);
19819 else if ( type(link(dummy_loc(mp->cur_exp)))==c+mp_fill_code-filled_op )
19820 mp_flush_cur_exp(mp, true_code);
19821 else mp_flush_cur_exp(mp, false_code);
19822 mp->cur_type=mp_boolean_type;
19825 @ @<Additional cases of unary operators@>=
19827 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19828 if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, make_pen_op);
19830 mp->cur_type=mp_pen_type;
19831 mp->cur_exp=mp_make_pen(mp, mp->cur_exp,true);
19835 if ( mp->cur_type!=mp_pen_type ) mp_bad_unary(mp, make_path_op);
19837 mp->cur_type=mp_path_type;
19838 mp_make_path(mp, mp->cur_exp);
19842 if ( mp->cur_type==mp_path_type ) {
19843 p=mp_htap_ypoc(mp, mp->cur_exp);
19844 if ( right_type(p)==mp_endpoint ) p=link(p);
19845 mp_toss_knot_list(mp, mp->cur_exp); mp->cur_exp=p;
19846 } else if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19847 else mp_bad_unary(mp, reverse);
19850 @ The |pair_value| routine changes the current expression to a
19851 given ordered pair of values.
19853 @<Declare unary action procedures@>=
19854 void mp_pair_value (MP mp,scaled x, scaled y) {
19855 pointer p; /* a pair node */
19856 p=mp_get_node(mp, value_node_size);
19857 mp_flush_cur_exp(mp, p); mp->cur_type=mp_pair_type;
19858 type(p)=mp_pair_type; name_type(p)=mp_capsule; mp_init_big_node(mp, p);
19860 type(x_part_loc(p))=mp_known; value(x_part_loc(p))=x;
19861 type(y_part_loc(p))=mp_known; value(y_part_loc(p))=y;
19864 @ @<Additional cases of unary operators@>=
19866 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ll_corner_op);
19867 else mp_pair_value(mp, minx,miny);
19870 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, lr_corner_op);
19871 else mp_pair_value(mp, maxx,miny);
19874 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ul_corner_op);
19875 else mp_pair_value(mp, minx,maxy);
19878 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ur_corner_op);
19879 else mp_pair_value(mp, maxx,maxy);
19882 @ Here is a function that sets |minx|, |maxx|, |miny|, |maxy| to the bounding
19883 box of the current expression. The boolean result is |false| if the expression
19884 has the wrong type.
19886 @<Declare unary action procedures@>=
19887 boolean mp_get_cur_bbox (MP mp) {
19888 switch (mp->cur_type) {
19889 case mp_picture_type:
19890 mp_set_bbox(mp, mp->cur_exp,true);
19891 if ( minx_val(mp->cur_exp)>maxx_val(mp->cur_exp) ) {
19892 minx=0; maxx=0; miny=0; maxy=0;
19894 minx=minx_val(mp->cur_exp);
19895 maxx=maxx_val(mp->cur_exp);
19896 miny=miny_val(mp->cur_exp);
19897 maxy=maxy_val(mp->cur_exp);
19901 mp_path_bbox(mp, mp->cur_exp);
19904 mp_pen_bbox(mp, mp->cur_exp);
19912 @ @<Additional cases of unary operators@>=
19914 case close_from_op:
19915 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, c);
19916 else mp_do_read_or_close(mp,c);
19919 @ Here is a routine that interprets |cur_exp| as a file name and tries to read
19920 a line from the file or to close the file.
19922 @<Declare unary action procedures@>=
19923 void mp_do_read_or_close (MP mp,quarterword c) {
19924 readf_index n,n0; /* indices for searching |rd_fname| */
19925 @<Find the |n| where |rd_fname[n]=cur_exp|; if |cur_exp| must be inserted,
19926 call |start_read_input| and |goto found| or |not_found|@>;
19927 mp_begin_file_reading(mp);
19929 if ( mp_input_ln(mp, mp->rd_file[n] ) )
19931 mp_end_file_reading(mp);
19933 @<Record the end of file and set |cur_exp| to a dummy value@>;
19936 mp_flush_cur_exp(mp, 0); mp->cur_type=mp_vacuous;
19939 mp_flush_cur_exp(mp, 0);
19940 mp_finish_read(mp);
19943 @ Free slots in the |rd_file| and |rd_fname| arrays are marked with NULL's in
19946 @<Find the |n| where |rd_fname[n]=cur_exp|...@>=
19951 fn = str(mp->cur_exp);
19952 while (mp_xstrcmp(fn,mp->rd_fname[n])!=0) {
19955 } else if ( c==close_from_op ) {
19958 if ( n0==mp->read_files ) {
19959 if ( mp->read_files<mp->max_read_files ) {
19960 incr(mp->read_files);
19965 l = mp->max_read_files + (mp->max_read_files>>2);
19966 rd_file = xmalloc((l+1), sizeof(void *));
19967 rd_fname = xmalloc((l+1), sizeof(char *));
19968 for (k=0;k<=l;k++) {
19969 if (k<=mp->max_read_files) {
19970 rd_file[k]=mp->rd_file[k];
19971 rd_fname[k]=mp->rd_fname[k];
19977 xfree(mp->rd_file); xfree(mp->rd_fname);
19978 mp->max_read_files = l;
19979 mp->rd_file = rd_file;
19980 mp->rd_fname = rd_fname;
19984 if ( mp_start_read_input(mp,fn,n) )
19989 if ( mp->rd_fname[n]==NULL ) { n0=n; }
19991 if ( c==close_from_op ) {
19992 (mp->close_file)(mp,mp->rd_file[n]);
19997 @ @<Record the end of file and set |cur_exp| to a dummy value@>=
19998 xfree(mp->rd_fname[n]);
19999 mp->rd_fname[n]=NULL;
20000 if ( n==mp->read_files-1 ) mp->read_files=n;
20001 if ( c==close_from_op )
20003 mp_flush_cur_exp(mp, mp->eof_line);
20004 mp->cur_type=mp_string_type
20006 @ The string denoting end-of-file is a one-byte string at position zero, by definition
20009 str_number eof_line;
20014 @ Finally, we have the operations that combine a capsule~|p|
20015 with the current expression.
20017 @d binary_return { mp_finish_binary(mp, old_p, old_exp); return; }
20019 @c @<Declare binary action procedures@>
20020 void mp_finish_binary (MP mp, pointer old_p, pointer old_exp ){
20022 @<Recycle any sidestepped |independent| capsules@>;
20024 void mp_do_binary (MP mp,pointer p, quarterword c) {
20025 pointer q,r,rr; /* for list manipulation */
20026 pointer old_p,old_exp; /* capsules to recycle */
20027 integer v; /* for numeric manipulation */
20029 if ( mp->internal[mp_tracing_commands]>two ) {
20030 @<Trace the current binary operation@>;
20032 @<Sidestep |independent| cases in capsule |p|@>;
20033 @<Sidestep |independent| cases in the current expression@>;
20035 case plus: case minus:
20036 @<Add or subtract the current expression from |p|@>;
20038 @<Additional cases of binary operators@>;
20039 }; /* there are no other cases */
20040 mp_recycle_value(mp, p);
20041 mp_free_node(mp, p,value_node_size); /* |return| to avoid this */
20042 mp_finish_binary(mp, old_p, old_exp);
20045 @ @<Declare binary action...@>=
20046 void mp_bad_binary (MP mp,pointer p, quarterword c) {
20047 mp_disp_err(mp, p,"");
20048 exp_err("Not implemented: ");
20049 @.Not implemented...@>
20050 if ( c>=min_of ) mp_print_op(mp, c);
20051 mp_print_known_or_unknown_type(mp, type(p),p);
20052 if ( c>=min_of ) mp_print(mp, "of"); else mp_print_op(mp, c);
20053 mp_print_known_or_unknown_type(mp, mp->cur_type,mp->cur_exp);
20054 help3("I'm afraid I don't know how to apply that operation to that")
20055 ("combination of types. Continue, and I'll return the second")
20056 ("argument (see above) as the result of the operation.");
20057 mp_put_get_error(mp);
20059 void mp_bad_envelope_pen (MP mp) {
20060 mp_disp_err(mp, null,"");
20061 exp_err("Not implemented: envelope(elliptical pen)of(path)");
20062 @.Not implemented...@>
20063 help3("I'm afraid I don't know how to apply that operation to that")
20064 ("combination of types. Continue, and I'll return the second")
20065 ("argument (see above) as the result of the operation.");
20066 mp_put_get_error(mp);
20069 @ @<Trace the current binary operation@>=
20071 mp_begin_diagnostic(mp); mp_print_nl(mp, "{(");
20072 mp_print_exp(mp,p,0); /* show the operand, but not verbosely */
20073 mp_print_char(mp,')'); mp_print_op(mp,c); mp_print_char(mp,'(');
20074 mp_print_exp(mp,null,0); mp_print(mp,")}");
20075 mp_end_diagnostic(mp, false);
20078 @ Several of the binary operations are potentially complicated by the
20079 fact that |independent| values can sneak into capsules. For example,
20080 we've seen an instance of this difficulty in the unary operation
20081 of negation. In order to reduce the number of cases that need to be
20082 handled, we first change the two operands (if necessary)
20083 to rid them of |independent| components. The original operands are
20084 put into capsules called |old_p| and |old_exp|, which will be
20085 recycled after the binary operation has been safely carried out.
20087 @<Recycle any sidestepped |independent| capsules@>=
20088 if ( old_p!=null ) {
20089 mp_recycle_value(mp, old_p); mp_free_node(mp, old_p,value_node_size);
20091 if ( old_exp!=null ) {
20092 mp_recycle_value(mp, old_exp); mp_free_node(mp, old_exp,value_node_size);
20095 @ A big node is considered to be ``tarnished'' if it contains at least one
20096 independent component. We will define a simple function called `|tarnished|'
20097 that returns |null| if and only if its argument is not tarnished.
20099 @<Sidestep |independent| cases in capsule |p|@>=
20101 case mp_transform_type:
20102 case mp_color_type:
20103 case mp_cmykcolor_type:
20105 old_p=mp_tarnished(mp, p);
20107 case mp_independent: old_p=mp_void; break;
20108 default: old_p=null; break;
20110 if ( old_p!=null ) {
20111 q=mp_stash_cur_exp(mp); old_p=p; mp_make_exp_copy(mp, old_p);
20112 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q);
20115 @ @<Sidestep |independent| cases in the current expression@>=
20116 switch (mp->cur_type) {
20117 case mp_transform_type:
20118 case mp_color_type:
20119 case mp_cmykcolor_type:
20121 old_exp=mp_tarnished(mp, mp->cur_exp);
20123 case mp_independent:old_exp=mp_void; break;
20124 default: old_exp=null; break;
20126 if ( old_exp!=null ) {
20127 old_exp=mp->cur_exp; mp_make_exp_copy(mp, old_exp);
20130 @ @<Declare binary action...@>=
20131 pointer mp_tarnished (MP mp,pointer p) {
20132 pointer q; /* beginning of the big node */
20133 pointer r; /* current position in the big node */
20134 q=value(p); r=q+mp->big_node_size[type(p)];
20137 if ( type(r)==mp_independent ) return mp_void;
20142 @ @<Add or subtract the current expression from |p|@>=
20143 if ( (mp->cur_type<mp_color_type)||(type(p)<mp_color_type) ) {
20144 mp_bad_binary(mp, p,c);
20146 if ((mp->cur_type>mp_pair_type)&&(type(p)>mp_pair_type) ) {
20147 mp_add_or_subtract(mp, p,null,c);
20149 if ( mp->cur_type!=type(p) ) {
20150 mp_bad_binary(mp, p,c);
20152 q=value(p); r=value(mp->cur_exp);
20153 rr=r+mp->big_node_size[mp->cur_type];
20155 mp_add_or_subtract(mp, q,r,c);
20162 @ The first argument to |add_or_subtract| is the location of a value node
20163 in a capsule or pair node that will soon be recycled. The second argument
20164 is either a location within a pair or transform node of |cur_exp|,
20165 or it is null (which means that |cur_exp| itself should be the second
20166 argument). The third argument is either |plus| or |minus|.
20168 The sum or difference of the numeric quantities will replace the second
20169 operand. Arithmetic overflow may go undetected; users aren't supposed to
20170 be monkeying around with really big values.
20171 @^overflow in arithmetic@>
20173 @<Declare binary action...@>=
20174 @<Declare the procedure called |dep_finish|@>
20175 void mp_add_or_subtract (MP mp,pointer p, pointer q, quarterword c) {
20176 small_number s,t; /* operand types */
20177 pointer r; /* list traverser */
20178 integer v; /* second operand value */
20181 if ( t<mp_dependent ) v=mp->cur_exp; else v=dep_list(mp->cur_exp);
20184 if ( t<mp_dependent ) v=value(q); else v=dep_list(q);
20186 if ( t==mp_known ) {
20187 if ( c==minus ) negate(v);
20188 if ( type(p)==mp_known ) {
20189 v=mp_slow_add(mp, value(p),v);
20190 if ( q==null ) mp->cur_exp=v; else value(q)=v;
20193 @<Add a known value to the constant term of |dep_list(p)|@>;
20195 if ( c==minus ) mp_negate_dep_list(mp, v);
20196 @<Add operand |p| to the dependency list |v|@>;
20200 @ @<Add a known value to the constant term of |dep_list(p)|@>=
20202 while ( info(r)!=null ) r=link(r);
20203 value(r)=mp_slow_add(mp, value(r),v);
20205 q=mp_get_node(mp, value_node_size); mp->cur_exp=q; mp->cur_type=type(p);
20206 name_type(q)=mp_capsule;
20208 dep_list(q)=dep_list(p); type(q)=type(p);
20209 prev_dep(q)=prev_dep(p); link(prev_dep(p))=q;
20210 type(p)=mp_known; /* this will keep the recycler from collecting non-garbage */
20212 @ We prefer |dependent| lists to |mp_proto_dependent| ones, because it is
20213 nice to retain the extra accuracy of |fraction| coefficients.
20214 But we have to handle both kinds, and mixtures too.
20216 @<Add operand |p| to the dependency list |v|@>=
20217 if ( type(p)==mp_known ) {
20218 @<Add the known |value(p)| to the constant term of |v|@>;
20220 s=type(p); r=dep_list(p);
20221 if ( t==mp_dependent ) {
20222 if ( s==mp_dependent ) {
20223 if ( mp_max_coef(mp, r)+mp_max_coef(mp, v)<coef_bound )
20224 v=mp_p_plus_q(mp, v,r,mp_dependent); goto DONE;
20225 } /* |fix_needed| will necessarily be false */
20226 t=mp_proto_dependent;
20227 v=mp_p_over_v(mp, v,unity,mp_dependent,mp_proto_dependent);
20229 if ( s==mp_proto_dependent ) v=mp_p_plus_q(mp, v,r,mp_proto_dependent);
20230 else v=mp_p_plus_fq(mp, v,unity,r,mp_proto_dependent,mp_dependent);
20232 @<Output the answer, |v| (which might have become |known|)@>;
20235 @ @<Add the known |value(p)| to the constant term of |v|@>=
20237 while ( info(v)!=null ) v=link(v);
20238 value(v)=mp_slow_add(mp, value(p),value(v));
20241 @ @<Output the answer, |v| (which might have become |known|)@>=
20242 if ( q!=null ) mp_dep_finish(mp, v,q,t);
20243 else { mp->cur_type=t; mp_dep_finish(mp, v,null,t); }
20245 @ Here's the current situation: The dependency list |v| of type |t|
20246 should either be put into the current expression (if |q=null|) or
20247 into location |q| within a pair node (otherwise). The destination (|cur_exp|
20248 or |q|) formerly held a dependency list with the same
20249 final pointer as the list |v|.
20251 @<Declare the procedure called |dep_finish|@>=
20252 void mp_dep_finish (MP mp, pointer v, pointer q, small_number t) {
20253 pointer p; /* the destination */
20254 scaled vv; /* the value, if it is |known| */
20255 if ( q==null ) p=mp->cur_exp; else p=q;
20256 dep_list(p)=v; type(p)=t;
20257 if ( info(v)==null ) {
20260 mp_flush_cur_exp(mp, vv);
20262 mp_recycle_value(mp, p); type(q)=mp_known; value(q)=vv;
20264 } else if ( q==null ) {
20267 if ( mp->fix_needed ) mp_fix_dependencies(mp);
20270 @ Let's turn now to the six basic relations of comparison.
20272 @<Additional cases of binary operators@>=
20273 case less_than: case less_or_equal: case greater_than:
20274 case greater_or_equal: case equal_to: case unequal_to:
20275 check_arith; /* at this point |arith_error| should be |false|? */
20276 if ( (mp->cur_type>mp_pair_type)&&(type(p)>mp_pair_type) ) {
20277 mp_add_or_subtract(mp, p,null,minus); /* |cur_exp:=(p)-cur_exp| */
20278 } else if ( mp->cur_type!=type(p) ) {
20279 mp_bad_binary(mp, p,c); goto DONE;
20280 } else if ( mp->cur_type==mp_string_type ) {
20281 mp_flush_cur_exp(mp, mp_str_vs_str(mp, value(p),mp->cur_exp));
20282 } else if ((mp->cur_type==mp_unknown_string)||
20283 (mp->cur_type==mp_unknown_boolean) ) {
20284 @<Check if unknowns have been equated@>;
20285 } else if ( (mp->cur_type<=mp_pair_type)&&(mp->cur_type>=mp_transform_type)) {
20286 @<Reduce comparison of big nodes to comparison of scalars@>;
20287 } else if ( mp->cur_type==mp_boolean_type ) {
20288 mp_flush_cur_exp(mp, mp->cur_exp-value(p));
20290 mp_bad_binary(mp, p,c); goto DONE;
20292 @<Compare the current expression with zero@>;
20294 mp->arith_error=false; /* ignore overflow in comparisons */
20297 @ @<Compare the current expression with zero@>=
20298 if ( mp->cur_type!=mp_known ) {
20299 if ( mp->cur_type<mp_known ) {
20300 mp_disp_err(mp, p,"");
20301 help1("The quantities shown above have not been equated.")
20303 help2("Oh dear. I can\'t decide if the expression above is positive,")
20304 ("negative, or zero. So this comparison test won't be `true'.");
20306 exp_err("Unknown relation will be considered false");
20307 @.Unknown relation...@>
20308 mp_put_get_flush_error(mp, false_code);
20311 case less_than: boolean_reset(mp->cur_exp<0); break;
20312 case less_or_equal: boolean_reset(mp->cur_exp<=0); break;
20313 case greater_than: boolean_reset(mp->cur_exp>0); break;
20314 case greater_or_equal: boolean_reset(mp->cur_exp>=0); break;
20315 case equal_to: boolean_reset(mp->cur_exp==0); break;
20316 case unequal_to: boolean_reset(mp->cur_exp!=0); break;
20317 }; /* there are no other cases */
20319 mp->cur_type=mp_boolean_type
20321 @ When two unknown strings are in the same ring, we know that they are
20322 equal. Otherwise, we don't know whether they are equal or not, so we
20325 @<Check if unknowns have been equated@>=
20327 q=value(mp->cur_exp);
20328 while ( (q!=mp->cur_exp)&&(q!=p) ) q=value(q);
20329 if ( q==p ) mp_flush_cur_exp(mp, 0);
20332 @ @<Reduce comparison of big nodes to comparison of scalars@>=
20334 q=value(p); r=value(mp->cur_exp);
20335 rr=r+mp->big_node_size[mp->cur_type]-2;
20336 while (1) { mp_add_or_subtract(mp, q,r,minus);
20337 if ( type(r)!=mp_known ) break;
20338 if ( value(r)!=0 ) break;
20339 if ( r==rr ) break;
20342 mp_take_part(mp, name_type(r)+x_part-mp_x_part_sector);
20345 @ Here we use the sneaky fact that |and_op-false_code=or_op-true_code|.
20347 @<Additional cases of binary operators@>=
20350 if ( (type(p)!=mp_boolean_type)||(mp->cur_type!=mp_boolean_type) )
20351 mp_bad_binary(mp, p,c);
20352 else if ( value(p)==c+false_code-and_op ) mp->cur_exp=value(p);
20355 @ @<Additional cases of binary operators@>=
20357 if ( (mp->cur_type<mp_color_type)||(type(p)<mp_color_type) ) {
20358 mp_bad_binary(mp, p,times);
20359 } else if ( (mp->cur_type==mp_known)||(type(p)==mp_known) ) {
20360 @<Multiply when at least one operand is known@>;
20361 } else if ( (mp_nice_color_or_pair(mp, p,type(p))&&(mp->cur_type>mp_pair_type))
20362 ||(mp_nice_color_or_pair(mp, mp->cur_exp,mp->cur_type)&&
20363 (type(p)>mp_pair_type)) ) {
20364 mp_hard_times(mp, p);
20367 mp_bad_binary(mp, p,times);
20371 @ @<Multiply when at least one operand is known@>=
20373 if ( type(p)==mp_known ) {
20374 v=value(p); mp_free_node(mp, p,value_node_size);
20376 v=mp->cur_exp; mp_unstash_cur_exp(mp, p);
20378 if ( mp->cur_type==mp_known ) {
20379 mp->cur_exp=mp_take_scaled(mp, mp->cur_exp,v);
20380 } else if ( (mp->cur_type==mp_pair_type)||
20381 (mp->cur_type==mp_color_type)||
20382 (mp->cur_type==mp_cmykcolor_type) ) {
20383 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20385 p=p-2; mp_dep_mult(mp, p,v,true);
20386 } while (p!=value(mp->cur_exp));
20388 mp_dep_mult(mp, null,v,true);
20393 @ @<Declare binary action...@>=
20394 void mp_dep_mult (MP mp,pointer p, integer v, boolean v_is_scaled) {
20395 pointer q; /* the dependency list being multiplied by |v| */
20396 small_number s,t; /* its type, before and after */
20399 } else if ( type(p)!=mp_known ) {
20402 if ( v_is_scaled ) value(p)=mp_take_scaled(mp, value(p),v);
20403 else value(p)=mp_take_fraction(mp, value(p),v);
20406 t=type(q); q=dep_list(q); s=t;
20407 if ( t==mp_dependent ) if ( v_is_scaled )
20408 if (mp_ab_vs_cd(mp, mp_max_coef(mp,q),abs(v),coef_bound-1,unity)>=0 )
20409 t=mp_proto_dependent;
20410 q=mp_p_times_v(mp, q,v,s,t,v_is_scaled);
20411 mp_dep_finish(mp, q,p,t);
20414 @ Here is a routine that is similar to |times|; but it is invoked only
20415 internally, when |v| is a |fraction| whose magnitude is at most~1,
20416 and when |cur_type>=mp_color_type|.
20418 @c void mp_frac_mult (MP mp,scaled n, scaled d) {
20419 /* multiplies |cur_exp| by |n/d| */
20420 pointer p; /* a pair node */
20421 pointer old_exp; /* a capsule to recycle */
20422 fraction v; /* |n/d| */
20423 if ( mp->internal[mp_tracing_commands]>two ) {
20424 @<Trace the fraction multiplication@>;
20426 switch (mp->cur_type) {
20427 case mp_transform_type:
20428 case mp_color_type:
20429 case mp_cmykcolor_type:
20431 old_exp=mp_tarnished(mp, mp->cur_exp);
20433 case mp_independent: old_exp=mp_void; break;
20434 default: old_exp=null; break;
20436 if ( old_exp!=null ) {
20437 old_exp=mp->cur_exp; mp_make_exp_copy(mp, old_exp);
20439 v=mp_make_fraction(mp, n,d);
20440 if ( mp->cur_type==mp_known ) {
20441 mp->cur_exp=mp_take_fraction(mp, mp->cur_exp,v);
20442 } else if ( mp->cur_type<=mp_pair_type ) {
20443 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20446 mp_dep_mult(mp, p,v,false);
20447 } while (p!=value(mp->cur_exp));
20449 mp_dep_mult(mp, null,v,false);
20451 if ( old_exp!=null ) {
20452 mp_recycle_value(mp, old_exp);
20453 mp_free_node(mp, old_exp,value_node_size);
20457 @ @<Trace the fraction multiplication@>=
20459 mp_begin_diagnostic(mp);
20460 mp_print_nl(mp, "{("); mp_print_scaled(mp,n); mp_print_char(mp,'/');
20461 mp_print_scaled(mp,d); mp_print(mp,")*("); mp_print_exp(mp,null,0);
20463 mp_end_diagnostic(mp, false);
20466 @ The |hard_times| routine multiplies a nice color or pair by a dependency list.
20468 @<Declare binary action procedures@>=
20469 void mp_hard_times (MP mp,pointer p) {
20470 pointer q; /* a copy of the dependent variable |p| */
20471 pointer r; /* a component of the big node for the nice color or pair */
20472 scaled v; /* the known value for |r| */
20473 if ( type(p)<=mp_pair_type ) {
20474 q=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, p); p=q;
20475 }; /* now |cur_type=mp_pair_type| or |cur_type=mp_color_type| */
20476 r=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20481 if ( r==value(mp->cur_exp) )
20483 mp_new_dep(mp, r,mp_copy_dep_list(mp, dep_list(p)));
20484 mp_dep_mult(mp, r,v,true);
20486 mp->mem[value_loc(r)]=mp->mem[value_loc(p)];
20487 link(prev_dep(p))=r;
20488 mp_free_node(mp, p,value_node_size);
20489 mp_dep_mult(mp, r,v,true);
20492 @ @<Additional cases of binary operators@>=
20494 if ( (mp->cur_type!=mp_known)||(type(p)<mp_color_type) ) {
20495 mp_bad_binary(mp, p,over);
20497 v=mp->cur_exp; mp_unstash_cur_exp(mp, p);
20499 @<Squeal about division by zero@>;
20501 if ( mp->cur_type==mp_known ) {
20502 mp->cur_exp=mp_make_scaled(mp, mp->cur_exp,v);
20503 } else if ( mp->cur_type<=mp_pair_type ) {
20504 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20506 p=p-2; mp_dep_div(mp, p,v);
20507 } while (p!=value(mp->cur_exp));
20509 mp_dep_div(mp, null,v);
20516 @ @<Declare binary action...@>=
20517 void mp_dep_div (MP mp,pointer p, scaled v) {
20518 pointer q; /* the dependency list being divided by |v| */
20519 small_number s,t; /* its type, before and after */
20520 if ( p==null ) q=mp->cur_exp;
20521 else if ( type(p)!=mp_known ) q=p;
20522 else { value(p)=mp_make_scaled(mp, value(p),v); return; };
20523 t=type(q); q=dep_list(q); s=t;
20524 if ( t==mp_dependent )
20525 if ( mp_ab_vs_cd(mp, mp_max_coef(mp,q),unity,coef_bound-1,abs(v))>=0 )
20526 t=mp_proto_dependent;
20527 q=mp_p_over_v(mp, q,v,s,t);
20528 mp_dep_finish(mp, q,p,t);
20531 @ @<Squeal about division by zero@>=
20533 exp_err("Division by zero");
20534 @.Division by zero@>
20535 help2("You're trying to divide the quantity shown above the error")
20536 ("message by zero. I'm going to divide it by one instead.");
20537 mp_put_get_error(mp);
20540 @ @<Additional cases of binary operators@>=
20543 if ( (mp->cur_type==mp_known)&&(type(p)==mp_known) ) {
20544 if ( c==pythag_add ) mp->cur_exp=mp_pyth_add(mp, value(p),mp->cur_exp);
20545 else mp->cur_exp=mp_pyth_sub(mp, value(p),mp->cur_exp);
20546 } else mp_bad_binary(mp, p,c);
20549 @ The next few sections of the program deal with affine transformations
20550 of coordinate data.
20552 @<Additional cases of binary operators@>=
20553 case rotated_by: case slanted_by:
20554 case scaled_by: case shifted_by: case transformed_by:
20555 case x_scaled: case y_scaled: case z_scaled:
20556 if ( type(p)==mp_path_type ) {
20557 path_trans(c,p); binary_return;
20558 } else if ( type(p)==mp_pen_type ) {
20560 mp->cur_exp=mp_convex_hull(mp, mp->cur_exp);
20561 /* rounding error could destroy convexity */
20563 } else if ( (type(p)==mp_pair_type)||(type(p)==mp_transform_type) ) {
20564 mp_big_trans(mp, p,c);
20565 } else if ( type(p)==mp_picture_type ) {
20566 mp_do_edges_trans(mp, p,c); binary_return;
20568 mp_bad_binary(mp, p,c);
20572 @ Let |c| be one of the eight transform operators. The procedure call
20573 |set_up_trans(c)| first changes |cur_exp| to a transform that corresponds to
20574 |c| and the original value of |cur_exp|. (In particular, |cur_exp| doesn't
20575 change at all if |c=transformed_by|.)
20577 Then, if all components of the resulting transform are |known|, they are
20578 moved to the global variables |txx|, |txy|, |tyx|, |tyy|, |tx|, |ty|;
20579 and |cur_exp| is changed to the known value zero.
20581 @<Declare binary action...@>=
20582 void mp_set_up_trans (MP mp,quarterword c) {
20583 pointer p,q,r; /* list manipulation registers */
20584 if ( (c!=transformed_by)||(mp->cur_type!=mp_transform_type) ) {
20585 @<Put the current transform into |cur_exp|@>;
20587 @<If the current transform is entirely known, stash it in global variables;
20588 otherwise |return|@>;
20597 scaled ty; /* current transform coefficients */
20599 @ @<Put the current transform...@>=
20601 p=mp_stash_cur_exp(mp);
20602 mp->cur_exp=mp_id_transform(mp);
20603 mp->cur_type=mp_transform_type;
20604 q=value(mp->cur_exp);
20606 @<For each of the eight cases, change the relevant fields of |cur_exp|
20608 but do nothing if capsule |p| doesn't have the appropriate type@>;
20609 }; /* there are no other cases */
20610 mp_disp_err(mp, p,"Improper transformation argument");
20611 @.Improper transformation argument@>
20612 help3("The expression shown above has the wrong type,")
20613 ("so I can\'t transform anything using it.")
20614 ("Proceed, and I'll omit the transformation.");
20615 mp_put_get_error(mp);
20617 mp_recycle_value(mp, p);
20618 mp_free_node(mp, p,value_node_size);
20621 @ @<If the current transform is entirely known, ...@>=
20622 q=value(mp->cur_exp); r=q+transform_node_size;
20625 if ( type(r)!=mp_known ) return;
20627 mp->txx=value(xx_part_loc(q));
20628 mp->txy=value(xy_part_loc(q));
20629 mp->tyx=value(yx_part_loc(q));
20630 mp->tyy=value(yy_part_loc(q));
20631 mp->tx=value(x_part_loc(q));
20632 mp->ty=value(y_part_loc(q));
20633 mp_flush_cur_exp(mp, 0)
20635 @ @<For each of the eight cases...@>=
20637 if ( type(p)==mp_known )
20638 @<Install sines and cosines, then |goto done|@>;
20641 if ( type(p)>mp_pair_type ) {
20642 mp_install(mp, xy_part_loc(q),p); goto DONE;
20646 if ( type(p)>mp_pair_type ) {
20647 mp_install(mp, xx_part_loc(q),p); mp_install(mp, yy_part_loc(q),p);
20652 if ( type(p)==mp_pair_type ) {
20653 r=value(p); mp_install(mp, x_part_loc(q),x_part_loc(r));
20654 mp_install(mp, y_part_loc(q),y_part_loc(r)); goto DONE;
20658 if ( type(p)>mp_pair_type ) {
20659 mp_install(mp, xx_part_loc(q),p); goto DONE;
20663 if ( type(p)>mp_pair_type ) {
20664 mp_install(mp, yy_part_loc(q),p); goto DONE;
20668 if ( type(p)==mp_pair_type )
20669 @<Install a complex multiplier, then |goto done|@>;
20671 case transformed_by:
20675 @ @<Install sines and cosines, then |goto done|@>=
20676 { mp_n_sin_cos(mp, (value(p) % three_sixty_units)*16);
20677 value(xx_part_loc(q))=mp_round_fraction(mp, mp->n_cos);
20678 value(yx_part_loc(q))=mp_round_fraction(mp, mp->n_sin);
20679 value(xy_part_loc(q))=-value(yx_part_loc(q));
20680 value(yy_part_loc(q))=value(xx_part_loc(q));
20684 @ @<Install a complex multiplier, then |goto done|@>=
20687 mp_install(mp, xx_part_loc(q),x_part_loc(r));
20688 mp_install(mp, yy_part_loc(q),x_part_loc(r));
20689 mp_install(mp, yx_part_loc(q),y_part_loc(r));
20690 if ( type(y_part_loc(r))==mp_known ) negate(value(y_part_loc(r)));
20691 else mp_negate_dep_list(mp, dep_list(y_part_loc(r)));
20692 mp_install(mp, xy_part_loc(q),y_part_loc(r));
20696 @ Procedure |set_up_known_trans| is like |set_up_trans|, but it
20697 insists that the transformation be entirely known.
20699 @<Declare binary action...@>=
20700 void mp_set_up_known_trans (MP mp,quarterword c) {
20701 mp_set_up_trans(mp, c);
20702 if ( mp->cur_type!=mp_known ) {
20703 exp_err("Transform components aren't all known");
20704 @.Transform components...@>
20705 help3("I'm unable to apply a partially specified transformation")
20706 ("except to a fully known pair or transform.")
20707 ("Proceed, and I'll omit the transformation.");
20708 mp_put_get_flush_error(mp, 0);
20709 mp->txx=unity; mp->txy=0; mp->tyx=0; mp->tyy=unity;
20710 mp->tx=0; mp->ty=0;
20714 @ Here's a procedure that applies the transform |txx..ty| to a pair of
20715 coordinates in locations |p| and~|q|.
20717 @<Declare binary action...@>=
20718 void mp_trans (MP mp,pointer p, pointer q) {
20719 scaled v; /* the new |x| value */
20720 v=mp_take_scaled(mp, mp->mem[p].sc,mp->txx)+
20721 mp_take_scaled(mp, mp->mem[q].sc,mp->txy)+mp->tx;
20722 mp->mem[q].sc=mp_take_scaled(mp, mp->mem[p].sc,mp->tyx)+
20723 mp_take_scaled(mp, mp->mem[q].sc,mp->tyy)+mp->ty;
20727 @ The simplest transformation procedure applies a transform to all
20728 coordinates of a path. The |path_trans(c)(p)| macro applies
20729 a transformation defined by |cur_exp| and the transform operator |c|
20732 @d path_trans(A,B) { mp_set_up_known_trans(mp, (A));
20733 mp_unstash_cur_exp(mp, (B));
20734 mp_do_path_trans(mp, mp->cur_exp); }
20736 @<Declare binary action...@>=
20737 void mp_do_path_trans (MP mp,pointer p) {
20738 pointer q; /* list traverser */
20741 if ( left_type(q)!=mp_endpoint )
20742 mp_trans(mp, q+3,q+4); /* that's |left_x| and |left_y| */
20743 mp_trans(mp, q+1,q+2); /* that's |x_coord| and |y_coord| */
20744 if ( right_type(q)!=mp_endpoint )
20745 mp_trans(mp, q+5,q+6); /* that's |right_x| and |right_y| */
20746 @^data structure assumptions@>
20751 @ Transforming a pen is very similar, except that there are no |left_type|
20752 and |right_type| fields.
20754 @d pen_trans(A,B) { mp_set_up_known_trans(mp, (A));
20755 mp_unstash_cur_exp(mp, (B));
20756 mp_do_pen_trans(mp, mp->cur_exp); }
20758 @<Declare binary action...@>=
20759 void mp_do_pen_trans (MP mp,pointer p) {
20760 pointer q; /* list traverser */
20761 if ( pen_is_elliptical(p) ) {
20762 mp_trans(mp, p+3,p+4); /* that's |left_x| and |left_y| */
20763 mp_trans(mp, p+5,p+6); /* that's |right_x| and |right_y| */
20767 mp_trans(mp, q+1,q+2); /* that's |x_coord| and |y_coord| */
20768 @^data structure assumptions@>
20773 @ The next transformation procedure applies to edge structures. It will do
20774 any transformation, but the results may be substandard if the picture contains
20775 text that uses downloaded bitmap fonts. The binary action procedure is
20776 |do_edges_trans|, but we also need a function that just scales a picture.
20777 That routine is |scale_edges|. Both it and the underlying routine |edges_trans|
20778 should be thought of as procedures that update an edge structure |h|, except
20779 that they have to return a (possibly new) structure because of the need to call
20782 @<Declare binary action...@>=
20783 pointer mp_edges_trans (MP mp, pointer h) {
20784 pointer q; /* the object being transformed */
20785 pointer r,s; /* for list manipulation */
20786 scaled sx,sy; /* saved transformation parameters */
20787 scaled sqdet; /* square root of determinant for |dash_scale| */
20788 integer sgndet; /* sign of the determinant */
20789 scaled v; /* a temporary value */
20790 h=mp_private_edges(mp, h);
20791 sqdet=mp_sqrt_det(mp, mp->txx,mp->txy,mp->tyx,mp->tyy);
20792 sgndet=mp_ab_vs_cd(mp, mp->txx,mp->tyy,mp->txy,mp->tyx);
20793 if ( dash_list(h)!=null_dash ) {
20794 @<Try to transform the dash list of |h|@>;
20796 @<Make the bounding box of |h| unknown if it can't be updated properly
20797 without scanning the whole structure@>;
20798 q=link(dummy_loc(h));
20799 while ( q!=null ) {
20800 @<Transform graphical object |q|@>;
20805 void mp_do_edges_trans (MP mp,pointer p, quarterword c) {
20806 mp_set_up_known_trans(mp, c);
20807 value(p)=mp_edges_trans(mp, value(p));
20808 mp_unstash_cur_exp(mp, p);
20810 void mp_scale_edges (MP mp) {
20811 mp->txx=mp->se_sf; mp->tyy=mp->se_sf;
20812 mp->txy=0; mp->tyx=0; mp->tx=0; mp->ty=0;
20813 mp->se_pic=mp_edges_trans(mp, mp->se_pic);
20816 @ @<Try to transform the dash list of |h|@>=
20817 if ( (mp->txy!=0)||(mp->tyx!=0)||
20818 (mp->ty!=0)||(abs(mp->txx)!=abs(mp->tyy))) {
20819 mp_flush_dash_list(mp, h);
20821 if ( mp->txx<0 ) { @<Reverse the dash list of |h|@>; }
20822 @<Scale the dash list by |txx| and shift it by |tx|@>;
20823 dash_y(h)=mp_take_scaled(mp, dash_y(h),abs(mp->tyy));
20826 @ @<Reverse the dash list of |h|@>=
20829 dash_list(h)=null_dash;
20830 while ( r!=null_dash ) {
20832 v=start_x(s); start_x(s)=stop_x(s); stop_x(s)=v;
20833 link(s)=dash_list(h);
20838 @ @<Scale the dash list by |txx| and shift it by |tx|@>=
20840 while ( r!=null_dash ) {
20841 start_x(r)=mp_take_scaled(mp, start_x(r),mp->txx)+mp->tx;
20842 stop_x(r)=mp_take_scaled(mp, stop_x(r),mp->txx)+mp->tx;
20846 @ @<Make the bounding box of |h| unknown if it can't be updated properly...@>=
20847 if ( (mp->txx==0)&&(mp->tyy==0) ) {
20848 @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>;
20849 } else if ( (mp->txy!=0)||(mp->tyx!=0) ) {
20850 mp_init_bbox(mp, h);
20853 if ( minx_val(h)<=maxx_val(h) ) {
20854 @<Scale the bounding box by |txx+txy| and |tyx+tyy|; then shift by
20861 @ @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>=
20863 v=minx_val(h); minx_val(h)=miny_val(h); miny_val(h)=v;
20864 v=maxx_val(h); maxx_val(h)=maxy_val(h); maxy_val(h)=v;
20867 @ The sum ``|txx+txy|'' is whichever of |txx| or |txy| is nonzero. The other
20870 @<Scale the bounding box by |txx+txy| and |tyx+tyy|; then shift...@>=
20872 minx_val(h)=mp_take_scaled(mp, minx_val(h),mp->txx+mp->txy)+mp->tx;
20873 maxx_val(h)=mp_take_scaled(mp, maxx_val(h),mp->txx+mp->txy)+mp->tx;
20874 miny_val(h)=mp_take_scaled(mp, miny_val(h),mp->tyx+mp->tyy)+mp->ty;
20875 maxy_val(h)=mp_take_scaled(mp, maxy_val(h),mp->tyx+mp->tyy)+mp->ty;
20876 if ( mp->txx+mp->txy<0 ) {
20877 v=minx_val(h); minx_val(h)=maxx_val(h); maxx_val(h)=v;
20879 if ( mp->tyx+mp->tyy<0 ) {
20880 v=miny_val(h); miny_val(h)=maxy_val(h); maxy_val(h)=v;
20884 @ Now we ready for the main task of transforming the graphical objects in edge
20887 @<Transform graphical object |q|@>=
20889 case mp_fill_code: case mp_stroked_code:
20890 mp_do_path_trans(mp, path_p(q));
20891 @<Transform |pen_p(q)|, making sure polygonal pens stay counter-clockwise@>;
20893 case mp_start_clip_code: case mp_start_bounds_code:
20894 mp_do_path_trans(mp, path_p(q));
20898 @<Transform the compact transformation starting at |r|@>;
20900 case mp_stop_clip_code: case mp_stop_bounds_code:
20902 } /* there are no other cases */
20904 @ Note that the shift parameters |(tx,ty)| apply only to the path being stroked.
20905 The |dash_scale| has to be adjusted to scale the dash lengths in |dash_p(q)|
20906 since the \ps\ output procedures will try to compensate for the transformation
20907 we are applying to |pen_p(q)|. Since this compensation is based on the square
20908 root of the determinant, |sqdet| is the appropriate factor.
20910 @<Transform |pen_p(q)|, making sure...@>=
20911 if ( pen_p(q)!=null ) {
20912 sx=mp->tx; sy=mp->ty;
20913 mp->tx=0; mp->ty=0;
20914 mp_do_pen_trans(mp, pen_p(q));
20915 if ( ((type(q)==mp_stroked_code)&&(dash_p(q)!=null)) )
20916 dash_scale(q)=mp_take_scaled(mp, dash_scale(q),sqdet);
20917 if ( ! pen_is_elliptical(pen_p(q)) )
20919 pen_p(q)=mp_make_pen(mp, mp_copy_path(mp, pen_p(q)),true);
20920 /* this unreverses the pen */
20921 mp->tx=sx; mp->ty=sy;
20924 @ This uses the fact that transformations are stored in the order
20925 |(tx,ty,txx,txy,tyx,tyy)|.
20926 @^data structure assumptions@>
20928 @<Transform the compact transformation starting at |r|@>=
20929 mp_trans(mp, r,r+1);
20930 sx=mp->tx; sy=mp->ty;
20931 mp->tx=0; mp->ty=0;
20932 mp_trans(mp, r+2,r+4);
20933 mp_trans(mp, r+3,r+5);
20934 mp->tx=sx; mp->ty=sy
20936 @ The hard cases of transformation occur when big nodes are involved,
20937 and when some of their components are unknown.
20939 @<Declare binary action...@>=
20940 @<Declare subroutines needed by |big_trans|@>
20941 void mp_big_trans (MP mp,pointer p, quarterword c) {
20942 pointer q,r,pp,qq; /* list manipulation registers */
20943 small_number s; /* size of a big node */
20944 s=mp->big_node_size[type(p)]; q=value(p); r=q+s;
20947 if ( type(r)!=mp_known ) {
20948 @<Transform an unknown big node and |return|@>;
20951 @<Transform a known big node@>;
20952 } /* node |p| will now be recycled by |do_binary| */
20954 @ @<Transform an unknown big node and |return|@>=
20956 mp_set_up_known_trans(mp, c); mp_make_exp_copy(mp, p);
20957 r=value(mp->cur_exp);
20958 if ( mp->cur_type==mp_transform_type ) {
20959 mp_bilin1(mp, yy_part_loc(r),mp->tyy,xy_part_loc(q),mp->tyx,0);
20960 mp_bilin1(mp, yx_part_loc(r),mp->tyy,xx_part_loc(q),mp->tyx,0);
20961 mp_bilin1(mp, xy_part_loc(r),mp->txx,yy_part_loc(q),mp->txy,0);
20962 mp_bilin1(mp, xx_part_loc(r),mp->txx,yx_part_loc(q),mp->txy,0);
20964 mp_bilin1(mp, y_part_loc(r),mp->tyy,x_part_loc(q),mp->tyx,mp->ty);
20965 mp_bilin1(mp, x_part_loc(r),mp->txx,y_part_loc(q),mp->txy,mp->tx);
20969 @ Let |p| point to a two-word value field inside a big node of |cur_exp|,
20970 and let |q| point to a another value field. The |bilin1| procedure
20971 replaces |p| by $p\cdot t+q\cdot u+\delta$.
20973 @<Declare subroutines needed by |big_trans|@>=
20974 void mp_bilin1 (MP mp, pointer p, scaled t, pointer q,
20975 scaled u, scaled delta) {
20976 pointer r; /* list traverser */
20977 if ( t!=unity ) mp_dep_mult(mp, p,t,true);
20979 if ( type(q)==mp_known ) {
20980 delta+=mp_take_scaled(mp, value(q),u);
20982 @<Ensure that |type(p)=mp_proto_dependent|@>;
20983 dep_list(p)=mp_p_plus_fq(mp, dep_list(p),u,dep_list(q),
20984 mp_proto_dependent,type(q));
20987 if ( type(p)==mp_known ) {
20991 while ( info(r)!=null ) r=link(r);
20993 if ( r!=dep_list(p) ) value(r)=delta;
20994 else { mp_recycle_value(mp, p); type(p)=mp_known; value(p)=delta; };
20996 if ( mp->fix_needed ) mp_fix_dependencies(mp);
20999 @ @<Ensure that |type(p)=mp_proto_dependent|@>=
21000 if ( type(p)!=mp_proto_dependent ) {
21001 if ( type(p)==mp_known )
21002 mp_new_dep(mp, p,mp_const_dependency(mp, value(p)));
21004 dep_list(p)=mp_p_times_v(mp, dep_list(p),unity,mp_dependent,
21005 mp_proto_dependent,true);
21006 type(p)=mp_proto_dependent;
21009 @ @<Transform a known big node@>=
21010 mp_set_up_trans(mp, c);
21011 if ( mp->cur_type==mp_known ) {
21012 @<Transform known by known@>;
21014 pp=mp_stash_cur_exp(mp); qq=value(pp);
21015 mp_make_exp_copy(mp, p); r=value(mp->cur_exp);
21016 if ( mp->cur_type==mp_transform_type ) {
21017 mp_bilin2(mp, yy_part_loc(r),yy_part_loc(qq),
21018 value(xy_part_loc(q)),yx_part_loc(qq),null);
21019 mp_bilin2(mp, yx_part_loc(r),yy_part_loc(qq),
21020 value(xx_part_loc(q)),yx_part_loc(qq),null);
21021 mp_bilin2(mp, xy_part_loc(r),xx_part_loc(qq),
21022 value(yy_part_loc(q)),xy_part_loc(qq),null);
21023 mp_bilin2(mp, xx_part_loc(r),xx_part_loc(qq),
21024 value(yx_part_loc(q)),xy_part_loc(qq),null);
21026 mp_bilin2(mp, y_part_loc(r),yy_part_loc(qq),
21027 value(x_part_loc(q)),yx_part_loc(qq),y_part_loc(qq));
21028 mp_bilin2(mp, x_part_loc(r),xx_part_loc(qq),
21029 value(y_part_loc(q)),xy_part_loc(qq),x_part_loc(qq));
21030 mp_recycle_value(mp, pp); mp_free_node(mp, pp,value_node_size);
21033 @ Let |p| be a |mp_proto_dependent| value whose dependency list ends
21034 at |dep_final|. The following procedure adds |v| times another
21035 numeric quantity to~|p|.
21037 @<Declare subroutines needed by |big_trans|@>=
21038 void mp_add_mult_dep (MP mp,pointer p, scaled v, pointer r) {
21039 if ( type(r)==mp_known ) {
21040 value(mp->dep_final)+=mp_take_scaled(mp, value(r),v);
21042 dep_list(p)=mp_p_plus_fq(mp, dep_list(p),v,dep_list(r),
21043 mp_proto_dependent,type(r));
21044 if ( mp->fix_needed ) mp_fix_dependencies(mp);
21048 @ The |bilin2| procedure is something like |bilin1|, but with known
21049 and unknown quantities reversed. Parameter |p| points to a value field
21050 within the big node for |cur_exp|; and |type(p)=mp_known|. Parameters
21051 |t| and~|u| point to value fields elsewhere; so does parameter~|q|,
21052 unless it is |null| (which stands for zero). Location~|p| will be
21053 replaced by $p\cdot t+v\cdot u+q$.
21055 @<Declare subroutines needed by |big_trans|@>=
21056 void mp_bilin2 (MP mp,pointer p, pointer t, scaled v,
21057 pointer u, pointer q) {
21058 scaled vv; /* temporary storage for |value(p)| */
21059 vv=value(p); type(p)=mp_proto_dependent;
21060 mp_new_dep(mp, p,mp_const_dependency(mp, 0)); /* this sets |dep_final| */
21062 mp_add_mult_dep(mp, p,vv,t); /* |dep_final| doesn't change */
21063 if ( v!=0 ) mp_add_mult_dep(mp, p,v,u);
21064 if ( q!=null ) mp_add_mult_dep(mp, p,unity,q);
21065 if ( dep_list(p)==mp->dep_final ) {
21066 vv=value(mp->dep_final); mp_recycle_value(mp, p);
21067 type(p)=mp_known; value(p)=vv;
21071 @ @<Transform known by known@>=
21073 mp_make_exp_copy(mp, p); r=value(mp->cur_exp);
21074 if ( mp->cur_type==mp_transform_type ) {
21075 mp_bilin3(mp, yy_part_loc(r),mp->tyy,value(xy_part_loc(q)),mp->tyx,0);
21076 mp_bilin3(mp, yx_part_loc(r),mp->tyy,value(xx_part_loc(q)),mp->tyx,0);
21077 mp_bilin3(mp, xy_part_loc(r),mp->txx,value(yy_part_loc(q)),mp->txy,0);
21078 mp_bilin3(mp, xx_part_loc(r),mp->txx,value(yx_part_loc(q)),mp->txy,0);
21080 mp_bilin3(mp, y_part_loc(r),mp->tyy,value(x_part_loc(q)),mp->tyx,mp->ty);
21081 mp_bilin3(mp, x_part_loc(r),mp->txx,value(y_part_loc(q)),mp->txy,mp->tx);
21084 @ Finally, in |bilin3| everything is |known|.
21086 @<Declare subroutines needed by |big_trans|@>=
21087 void mp_bilin3 (MP mp,pointer p, scaled t,
21088 scaled v, scaled u, scaled delta) {
21090 delta+=mp_take_scaled(mp, value(p),t);
21093 if ( u!=0 ) value(p)=delta+mp_take_scaled(mp, v,u);
21094 else value(p)=delta;
21097 @ @<Additional cases of binary operators@>=
21099 if ( (mp->cur_type==mp_string_type)&&(type(p)==mp_string_type) ) mp_cat(mp, p);
21100 else mp_bad_binary(mp, p,concatenate);
21103 if ( mp_nice_pair(mp, p,type(p))&&(mp->cur_type==mp_string_type) )
21104 mp_chop_string(mp, value(p));
21105 else mp_bad_binary(mp, p,substring_of);
21108 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
21109 if ( mp_nice_pair(mp, p,type(p))&&(mp->cur_type==mp_path_type) )
21110 mp_chop_path(mp, value(p));
21111 else mp_bad_binary(mp, p,subpath_of);
21114 @ @<Declare binary action...@>=
21115 void mp_cat (MP mp,pointer p) {
21116 str_number a,b; /* the strings being concatenated */
21117 pool_pointer k; /* index into |str_pool| */
21118 a=value(p); b=mp->cur_exp; str_room(length(a)+length(b));
21119 for (k=mp->str_start[a];k<=str_stop(a)-1;k++) {
21120 append_char(mp->str_pool[k]);
21122 for (k=mp->str_start[b];k<=str_stop(b)-1;k++) {
21123 append_char(mp->str_pool[k]);
21125 mp->cur_exp=mp_make_string(mp); delete_str_ref(b);
21128 @ @<Declare binary action...@>=
21129 void mp_chop_string (MP mp,pointer p) {
21130 integer a, b; /* start and stop points */
21131 integer l; /* length of the original string */
21132 integer k; /* runs from |a| to |b| */
21133 str_number s; /* the original string */
21134 boolean reversed; /* was |a>b|? */
21135 a=mp_round_unscaled(mp, value(x_part_loc(p)));
21136 b=mp_round_unscaled(mp, value(y_part_loc(p)));
21137 if ( a<=b ) reversed=false;
21138 else { reversed=true; k=a; a=b; b=k; };
21139 s=mp->cur_exp; l=length(s);
21150 for (k=mp->str_start[s]+b-1;k>=mp->str_start[s]+a;k--) {
21151 append_char(mp->str_pool[k]);
21154 for (k=mp->str_start[s]+a;k<=mp->str_start[s]+b-1;k++) {
21155 append_char(mp->str_pool[k]);
21158 mp->cur_exp=mp_make_string(mp); delete_str_ref(s);
21161 @ @<Declare binary action...@>=
21162 void mp_chop_path (MP mp,pointer p) {
21163 pointer q; /* a knot in the original path */
21164 pointer pp,qq,rr,ss; /* link variables for copies of path nodes */
21165 scaled a,b,k,l; /* indices for chopping */
21166 boolean reversed; /* was |a>b|? */
21167 l=mp_path_length(mp); a=value(x_part_loc(p)); b=value(y_part_loc(p));
21168 if ( a<=b ) reversed=false;
21169 else { reversed=true; k=a; a=b; b=k; };
21170 @<Dispense with the cases |a<0| and/or |b>l|@>;
21172 while ( a>=unity ) {
21173 q=link(q); a=a-unity; b=b-unity;
21176 @<Construct a path from |pp| to |qq| of length zero@>;
21178 @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>;
21180 left_type(pp)=mp_endpoint; right_type(qq)=mp_endpoint; link(qq)=pp;
21181 mp_toss_knot_list(mp, mp->cur_exp);
21183 mp->cur_exp=link(mp_htap_ypoc(mp, pp)); mp_toss_knot_list(mp, pp);
21189 @ @<Dispense with the cases |a<0| and/or |b>l|@>=
21191 if ( left_type(mp->cur_exp)==mp_endpoint ) {
21192 a=0; if ( b<0 ) b=0;
21194 do { a=a+l; b=b+l; } while (a<0); /* a cycle always has length |l>0| */
21198 if ( left_type(mp->cur_exp)==mp_endpoint ) {
21199 b=l; if ( a>l ) a=l;
21207 @ @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>=
21209 pp=mp_copy_knot(mp, q); qq=pp;
21211 q=link(q); rr=qq; qq=mp_copy_knot(mp, q); link(rr)=qq; b=b-unity;
21214 ss=pp; pp=link(pp);
21215 mp_split_cubic(mp, ss,a*010000); pp=link(ss);
21216 mp_free_node(mp, ss,knot_node_size);
21218 b=mp_make_scaled(mp, b,unity-a); rr=pp;
21222 mp_split_cubic(mp, rr,(b+unity)*010000);
21223 mp_free_node(mp, qq,knot_node_size);
21228 @ @<Construct a path from |pp| to |qq| of length zero@>=
21230 if ( a>0 ) { mp_split_cubic(mp, q,a*010000); q=link(q); };
21231 pp=mp_copy_knot(mp, q); qq=pp;
21234 @ @<Additional cases of binary operators@>=
21235 case point_of: case precontrol_of: case postcontrol_of:
21236 if ( mp->cur_type==mp_pair_type )
21237 mp_pair_to_path(mp);
21238 if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_known) )
21239 mp_find_point(mp, value(p),c);
21241 mp_bad_binary(mp, p,c);
21243 case pen_offset_of:
21244 if ( (mp->cur_type==mp_pen_type)&& mp_nice_pair(mp, p,type(p)) )
21245 mp_set_up_offset(mp, value(p));
21247 mp_bad_binary(mp, p,pen_offset_of);
21249 case direction_time_of:
21250 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
21251 if ( (mp->cur_type==mp_path_type)&& mp_nice_pair(mp, p,type(p)) )
21252 mp_set_up_direction_time(mp, value(p));
21254 mp_bad_binary(mp, p,direction_time_of);
21257 if ( (type(p) != mp_pen_type) || (mp->cur_type != mp_path_type) )
21258 mp_bad_binary(mp, p,envelope_of);
21260 mp_set_up_envelope(mp, p);
21263 @ @<Declare binary action...@>=
21264 void mp_set_up_offset (MP mp,pointer p) {
21265 mp_find_offset(mp, value(x_part_loc(p)),value(y_part_loc(p)),mp->cur_exp);
21266 mp_pair_value(mp, mp->cur_x,mp->cur_y);
21268 void mp_set_up_direction_time (MP mp,pointer p) {
21269 mp_flush_cur_exp(mp, mp_find_direction_time(mp, value(x_part_loc(p)),
21270 value(y_part_loc(p)),mp->cur_exp));
21272 void mp_set_up_envelope (MP mp,pointer p) {
21273 small_number ljoin, lcap;
21275 pointer q = mp_copy_path(mp, mp->cur_exp); /* the original path */
21276 /* TODO: accept elliptical pens for straight paths */
21277 if (pen_is_elliptical(value(p))) {
21278 mp_bad_envelope_pen(mp);
21280 mp->cur_type = mp_path_type;
21283 if ( mp->internal[mp_linejoin]>unity ) ljoin=2;
21284 else if ( mp->internal[mp_linejoin]>0 ) ljoin=1;
21286 if ( mp->internal[mp_linecap]>unity ) lcap=2;
21287 else if ( mp->internal[mp_linecap]>0 ) lcap=1;
21289 if ( mp->internal[mp_miterlimit]<unity )
21292 miterlim=mp->internal[mp_miterlimit];
21293 mp->cur_exp = mp_make_envelope(mp, q, value(p), ljoin,lcap,miterlim);
21294 mp->cur_type = mp_path_type;
21297 @ @<Declare binary action...@>=
21298 void mp_find_point (MP mp,scaled v, quarterword c) {
21299 pointer p; /* the path */
21300 scaled n; /* its length */
21302 if ( left_type(p)==mp_endpoint ) n=-unity; else n=0;
21303 do { p=link(p); n=n+unity; } while (p!=mp->cur_exp);
21306 } else if ( v<0 ) {
21307 if ( left_type(p)==mp_endpoint ) v=0;
21308 else v=n-1-((-v-1) % n);
21309 } else if ( v>n ) {
21310 if ( left_type(p)==mp_endpoint ) v=n;
21314 while ( v>=unity ) { p=link(p); v=v-unity; };
21316 @<Insert a fractional node by splitting the cubic@>;
21318 @<Set the current expression to the desired path coordinates@>;
21321 @ @<Insert a fractional node...@>=
21322 { mp_split_cubic(mp, p,v*010000); p=link(p); }
21324 @ @<Set the current expression to the desired path coordinates...@>=
21327 mp_pair_value(mp, x_coord(p),y_coord(p));
21329 case precontrol_of:
21330 if ( left_type(p)==mp_endpoint ) mp_pair_value(mp, x_coord(p),y_coord(p));
21331 else mp_pair_value(mp, left_x(p),left_y(p));
21333 case postcontrol_of:
21334 if ( right_type(p)==mp_endpoint ) mp_pair_value(mp, x_coord(p),y_coord(p));
21335 else mp_pair_value(mp, right_x(p),right_y(p));
21337 } /* there are no other cases */
21339 @ @<Additional cases of binary operators@>=
21341 if ( mp->cur_type==mp_pair_type )
21342 mp_pair_to_path(mp);
21343 if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_known) )
21344 mp_flush_cur_exp(mp, mp_get_arc_time(mp, mp->cur_exp,value(p)));
21346 mp_bad_binary(mp, p,c);
21349 @ @<Additional cases of bin...@>=
21351 if ( type(p)==mp_pair_type ) {
21352 q=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, p);
21353 mp_pair_to_path(mp); p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q);
21355 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
21356 if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_path_type) ) {
21357 mp_path_intersection(mp, value(p),mp->cur_exp);
21358 mp_pair_value(mp, mp->cur_t,mp->cur_tt);
21360 mp_bad_binary(mp, p,intersect);
21364 @ @<Additional cases of bin...@>=
21366 if ( (mp->cur_type!=mp_string_type)||(type(p)!=mp_string_type))
21367 mp_bad_binary(mp, p,in_font);
21368 else { mp_do_infont(mp, p); binary_return; }
21371 @ Function |new_text_node| owns the reference count for its second argument
21372 (the text string) but not its first (the font name).
21374 @<Declare binary action...@>=
21375 void mp_do_infont (MP mp,pointer p) {
21377 q=mp_get_node(mp, edge_header_size);
21378 mp_init_edges(mp, q);
21379 link(obj_tail(q))=mp_new_text_node(mp,str(mp->cur_exp),value(p));
21380 obj_tail(q)=link(obj_tail(q));
21381 mp_free_node(mp, p,value_node_size);
21382 mp_flush_cur_exp(mp, q);
21383 mp->cur_type=mp_picture_type;
21386 @* \[40] Statements and commands.
21387 The chief executive of \MP\ is the |do_statement| routine, which
21388 contains the master switch that causes all the various pieces of \MP\
21389 to do their things, in the right order.
21391 In a sense, this is the grand climax of the program: It applies all the
21392 tools that we have worked so hard to construct. In another sense, this is
21393 the messiest part of the program: It necessarily refers to other pieces
21394 of code all over the place, so that a person can't fully understand what is
21395 going on without paging back and forth to be reminded of conventions that
21396 are defined elsewhere. We are now at the hub of the web.
21398 The structure of |do_statement| itself is quite simple. The first token
21399 of the statement is fetched using |get_x_next|. If it can be the first
21400 token of an expression, we look for an equation, an assignment, or a
21401 title. Otherwise we use a \&{case} construction to branch at high speed to
21402 the appropriate routine for various and sundry other types of commands,
21403 each of which has an ``action procedure'' that does the necessary work.
21405 The program uses the fact that
21406 $$\hbox{|min_primary_command=max_statement_command=type_name|}$$
21407 to interpret a statement that starts with, e.g., `\&{string}',
21408 as a type declaration rather than a boolean expression.
21410 @c void mp_do_statement (MP mp) { /* governs \MP's activities */
21411 mp->cur_type=mp_vacuous; mp_get_x_next(mp);
21412 if ( mp->cur_cmd>max_primary_command ) {
21413 @<Worry about bad statement@>;
21414 } else if ( mp->cur_cmd>max_statement_command ) {
21415 @<Do an equation, assignment, title, or
21416 `$\langle\,$expression$\,\rangle\,$\&{endgroup}'@>;
21418 @<Do a statement that doesn't begin with an expression@>;
21420 if ( mp->cur_cmd<semicolon )
21421 @<Flush unparsable junk that was found after the statement@>;
21425 @ @<Declarations@>=
21426 @<Declare action procedures for use by |do_statement|@>
21428 @ The only command codes |>max_primary_command| that can be present
21429 at the beginning of a statement are |semicolon| and higher; these
21430 occur when the statement is null.
21432 @<Worry about bad statement@>=
21434 if ( mp->cur_cmd<semicolon ) {
21435 print_err("A statement can't begin with `");
21436 @.A statement can't begin with x@>
21437 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod); mp_print_char(mp, '\'');
21438 help5("I was looking for the beginning of a new statement.")
21439 ("If you just proceed without changing anything, I'll ignore")
21440 ("everything up to the next `;'. Please insert a semicolon")
21441 ("now in front of anything that you don't want me to delete.")
21442 ("(See Chapter 27 of The METAFONTbook for an example.)");
21443 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
21444 mp_back_error(mp); mp_get_x_next(mp);
21448 @ The help message printed here says that everything is flushed up to
21449 a semicolon, but actually the commands |end_group| and |stop| will
21450 also terminate a statement.
21452 @<Flush unparsable junk that was found after the statement@>=
21454 print_err("Extra tokens will be flushed");
21455 @.Extra tokens will be flushed@>
21456 help6("I've just read as much of that statement as I could fathom,")
21457 ("so a semicolon should have been next. It's very puzzling...")
21458 ("but I'll try to get myself back together, by ignoring")
21459 ("everything up to the next `;'. Please insert a semicolon")
21460 ("now in front of anything that you don't want me to delete.")
21461 ("(See Chapter 27 of The METAFONTbook for an example.)");
21462 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
21463 mp_back_error(mp); mp->scanner_status=flushing;
21466 @<Decrease the string reference count...@>;
21467 } while (! end_of_statement); /* |cur_cmd=semicolon|, |end_group|, or |stop| */
21468 mp->scanner_status=normal;
21471 @ If |do_statement| ends with |cur_cmd=end_group|, we should have
21472 |cur_type=mp_vacuous| unless the statement was simply an expression;
21473 in the latter case, |cur_type| and |cur_exp| should represent that
21476 @<Do a statement that doesn't...@>=
21478 if ( mp->internal[mp_tracing_commands]>0 )
21480 switch (mp->cur_cmd ) {
21481 case type_name:mp_do_type_declaration(mp); break;
21483 if ( mp->cur_mod>var_def ) mp_make_op_def(mp);
21484 else if ( mp->cur_mod>end_def ) mp_scan_def(mp);
21486 @<Cases of |do_statement| that invoke particular commands@>;
21487 } /* there are no other cases */
21488 mp->cur_type=mp_vacuous;
21491 @ The most important statements begin with expressions.
21493 @<Do an equation, assignment, title, or...@>=
21495 mp->var_flag=assignment; mp_scan_expression(mp);
21496 if ( mp->cur_cmd<end_group ) {
21497 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21498 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21499 else if ( mp->cur_type==mp_string_type ) {@<Do a title@> ; }
21500 else if ( mp->cur_type!=mp_vacuous ){
21501 exp_err("Isolated expression");
21502 @.Isolated expression@>
21503 help3("I couldn't find an `=' or `:=' after the")
21504 ("expression that is shown above this error message,")
21505 ("so I guess I'll just ignore it and carry on.");
21506 mp_put_get_error(mp);
21508 mp_flush_cur_exp(mp, 0); mp->cur_type=mp_vacuous;
21514 if ( mp->internal[mp_tracing_titles]>0 ) {
21515 mp_print_nl(mp, ""); mp_print_str(mp, mp->cur_exp); update_terminal;
21519 @ Equations and assignments are performed by the pair of mutually recursive
21521 routines |do_equation| and |do_assignment|. These routines are called when
21522 |cur_cmd=equals| and when |cur_cmd=assignment|, respectively; the left-hand
21523 side is in |cur_type| and |cur_exp|, while the right-hand side is yet
21524 to be scanned. After the routines are finished, |cur_type| and |cur_exp|
21525 will be equal to the right-hand side (which will normally be equal
21526 to the left-hand side).
21528 @<Declare action procedures for use by |do_statement|@>=
21529 @<Declare the procedure called |try_eq|@>
21530 @<Declare the procedure called |make_eq|@>
21531 void mp_do_equation (MP mp) ;
21534 void mp_do_equation (MP mp) {
21535 pointer lhs; /* capsule for the left-hand side */
21536 pointer p; /* temporary register */
21537 lhs=mp_stash_cur_exp(mp); mp_get_x_next(mp);
21538 mp->var_flag=assignment; mp_scan_expression(mp);
21539 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21540 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21541 if ( mp->internal[mp_tracing_commands]>two )
21542 @<Trace the current equation@>;
21543 if ( mp->cur_type==mp_unknown_path ) if ( type(lhs)==mp_pair_type ) {
21544 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, lhs); lhs=p;
21545 }; /* in this case |make_eq| will change the pair to a path */
21546 mp_make_eq(mp, lhs); /* equate |lhs| to |(cur_type,cur_exp)| */
21549 @ And |do_assignment| is similar to |do_equation|:
21552 void mp_do_assignment (MP mp);
21554 @ @<Declare action procedures for use by |do_statement|@>=
21555 void mp_do_assignment (MP mp) ;
21558 void mp_do_assignment (MP mp) {
21559 pointer lhs; /* token list for the left-hand side */
21560 pointer p; /* where the left-hand value is stored */
21561 pointer q; /* temporary capsule for the right-hand value */
21562 if ( mp->cur_type!=mp_token_list ) {
21563 exp_err("Improper `:=' will be changed to `='");
21565 help2("I didn't find a variable name at the left of the `:=',")
21566 ("so I'm going to pretend that you said `=' instead.");
21567 mp_error(mp); mp_do_equation(mp);
21569 lhs=mp->cur_exp; mp->cur_type=mp_vacuous;
21570 mp_get_x_next(mp); mp->var_flag=assignment; mp_scan_expression(mp);
21571 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21572 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21573 if ( mp->internal[mp_tracing_commands]>two )
21574 @<Trace the current assignment@>;
21575 if ( info(lhs)>hash_end ) {
21576 @<Assign the current expression to an internal variable@>;
21578 @<Assign the current expression to the variable |lhs|@>;
21580 mp_flush_node_list(mp, lhs);
21584 @ @<Trace the current equation@>=
21586 mp_begin_diagnostic(mp); mp_print_nl(mp, "{("); mp_print_exp(mp,lhs,0);
21587 mp_print(mp,")=("); mp_print_exp(mp,null,0);
21588 mp_print(mp,")}"); mp_end_diagnostic(mp, false);
21591 @ @<Trace the current assignment@>=
21593 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
21594 if ( info(lhs)>hash_end )
21595 mp_print(mp, mp->int_name[info(lhs)-(hash_end)]);
21597 mp_show_token_list(mp, lhs,null,1000,0);
21598 mp_print(mp, ":="); mp_print_exp(mp, null,0);
21599 mp_print_char(mp, '}'); mp_end_diagnostic(mp, false);
21602 @ @<Assign the current expression to an internal variable@>=
21603 if ( mp->cur_type==mp_known ) {
21604 mp->internal[info(lhs)-(hash_end)]=mp->cur_exp;
21606 exp_err("Internal quantity `");
21607 @.Internal quantity...@>
21608 mp_print(mp, mp->int_name[info(lhs)-(hash_end)]);
21609 mp_print(mp, "' must receive a known value");
21610 help2("I can\'t set an internal quantity to anything but a known")
21611 ("numeric value, so I'll have to ignore this assignment.");
21612 mp_put_get_error(mp);
21615 @ @<Assign the current expression to the variable |lhs|@>=
21617 p=mp_find_variable(mp, lhs);
21619 q=mp_stash_cur_exp(mp); mp->cur_type=mp_und_type(mp, p);
21620 mp_recycle_value(mp, p);
21621 type(p)=mp->cur_type; value(p)=null; mp_make_exp_copy(mp, p);
21622 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q); mp_make_eq(mp, p);
21624 mp_obliterated(mp, lhs); mp_put_get_error(mp);
21629 @ And now we get to the nitty-gritty. The |make_eq| procedure is given
21630 a pointer to a capsule that is to be equated to the current expression.
21632 @<Declare the procedure called |make_eq|@>=
21633 void mp_make_eq (MP mp,pointer lhs) ;
21637 @c void mp_make_eq (MP mp,pointer lhs) {
21638 small_number t; /* type of the left-hand side */
21639 pointer p,q; /* pointers inside of big nodes */
21640 integer v=0; /* value of the left-hand side */
21643 if ( t<=mp_pair_type ) v=value(lhs);
21645 @<For each type |t|, make an equation and |goto done| unless |cur_type|
21646 is incompatible with~|t|@>;
21647 } /* all cases have been listed */
21648 @<Announce that the equation cannot be performed@>;
21650 check_arith; mp_recycle_value(mp, lhs);
21651 mp_free_node(mp, lhs,value_node_size);
21654 @ @<Announce that the equation cannot be performed@>=
21655 mp_disp_err(mp, lhs,"");
21656 exp_err("Equation cannot be performed (");
21657 @.Equation cannot be performed@>
21658 if ( type(lhs)<=mp_pair_type ) mp_print_type(mp, type(lhs));
21659 else mp_print(mp, "numeric");
21660 mp_print_char(mp, '=');
21661 if ( mp->cur_type<=mp_pair_type ) mp_print_type(mp, mp->cur_type);
21662 else mp_print(mp, "numeric");
21663 mp_print_char(mp, ')');
21664 help2("I'm sorry, but I don't know how to make such things equal.")
21665 ("(See the two expressions just above the error message.)");
21666 mp_put_get_error(mp)
21668 @ @<For each type |t|, make an equation and |goto done| unless...@>=
21669 case mp_boolean_type: case mp_string_type: case mp_pen_type:
21670 case mp_path_type: case mp_picture_type:
21671 if ( mp->cur_type==t+unknown_tag ) {
21672 mp_nonlinear_eq(mp, v,mp->cur_exp,false);
21673 mp_unstash_cur_exp(mp, mp->cur_exp); goto DONE;
21674 } else if ( mp->cur_type==t ) {
21675 @<Report redundant or inconsistent equation and |goto done|@>;
21678 case unknown_types:
21679 if ( mp->cur_type==t-unknown_tag ) {
21680 mp_nonlinear_eq(mp, mp->cur_exp,lhs,true); goto DONE;
21681 } else if ( mp->cur_type==t ) {
21682 mp_ring_merge(mp, lhs,mp->cur_exp); goto DONE;
21683 } else if ( mp->cur_type==mp_pair_type ) {
21684 if ( t==mp_unknown_path ) {
21685 mp_pair_to_path(mp); goto RESTART;
21689 case mp_transform_type: case mp_color_type:
21690 case mp_cmykcolor_type: case mp_pair_type:
21691 if ( mp->cur_type==t ) {
21692 @<Do multiple equations and |goto done|@>;
21695 case mp_known: case mp_dependent:
21696 case mp_proto_dependent: case mp_independent:
21697 if ( mp->cur_type>=mp_known ) {
21698 mp_try_eq(mp, lhs,null); goto DONE;
21704 @ @<Report redundant or inconsistent equation and |goto done|@>=
21706 if ( mp->cur_type<=mp_string_type ) {
21707 if ( mp->cur_type==mp_string_type ) {
21708 if ( mp_str_vs_str(mp, v,mp->cur_exp)!=0 ) {
21711 } else if ( v!=mp->cur_exp ) {
21714 @<Exclaim about a redundant equation@>; goto DONE;
21716 print_err("Redundant or inconsistent equation");
21717 @.Redundant or inconsistent equation@>
21718 help2("An equation between already-known quantities can't help.")
21719 ("But don't worry; continue and I'll just ignore it.");
21720 mp_put_get_error(mp); goto DONE;
21722 print_err("Inconsistent equation");
21723 @.Inconsistent equation@>
21724 help2("The equation I just read contradicts what was said before.")
21725 ("But don't worry; continue and I'll just ignore it.");
21726 mp_put_get_error(mp); goto DONE;
21729 @ @<Do multiple equations and |goto done|@>=
21731 p=v+mp->big_node_size[t];
21732 q=value(mp->cur_exp)+mp->big_node_size[t];
21734 p=p-2; q=q-2; mp_try_eq(mp, p,q);
21739 @ The first argument to |try_eq| is the location of a value node
21740 in a capsule that will soon be recycled. The second argument is
21741 either a location within a pair or transform node pointed to by
21742 |cur_exp|, or it is |null| (which means that |cur_exp| itself
21743 serves as the second argument). The idea is to leave |cur_exp| unchanged,
21744 but to equate the two operands.
21746 @<Declare the procedure called |try_eq|@>=
21747 void mp_try_eq (MP mp,pointer l, pointer r) ;
21750 @c void mp_try_eq (MP mp,pointer l, pointer r) {
21751 pointer p; /* dependency list for right operand minus left operand */
21752 int t; /* the type of list |p| */
21753 pointer q; /* the constant term of |p| is here */
21754 pointer pp; /* dependency list for right operand */
21755 int tt; /* the type of list |pp| */
21756 boolean copied; /* have we copied a list that ought to be recycled? */
21757 @<Remove the left operand from its container, negate it, and
21758 put it into dependency list~|p| with constant term~|q|@>;
21759 @<Add the right operand to list |p|@>;
21760 if ( info(p)==null ) {
21761 @<Deal with redundant or inconsistent equation@>;
21763 mp_linear_eq(mp, p,t);
21764 if ( r==null ) if ( mp->cur_type!=mp_known ) {
21765 if ( type(mp->cur_exp)==mp_known ) {
21766 pp=mp->cur_exp; mp->cur_exp=value(mp->cur_exp); mp->cur_type=mp_known;
21767 mp_free_node(mp, pp,value_node_size);
21773 @ @<Remove the left operand from its container, negate it, and...@>=
21775 if ( t==mp_known ) {
21776 t=mp_dependent; p=mp_const_dependency(mp, -value(l)); q=p;
21777 } else if ( t==mp_independent ) {
21778 t=mp_dependent; p=mp_single_dependency(mp, l); negate(value(p));
21781 p=dep_list(l); q=p;
21784 if ( info(q)==null ) break;
21787 link(prev_dep(l))=link(q); prev_dep(link(q))=prev_dep(l);
21791 @ @<Deal with redundant or inconsistent equation@>=
21793 if ( abs(value(p))>64 ) { /* off by .001 or more */
21794 print_err("Inconsistent equation");
21795 @.Inconsistent equation@>
21796 mp_print(mp, " (off by "); mp_print_scaled(mp, value(p));
21797 mp_print_char(mp, ')');
21798 help2("The equation I just read contradicts what was said before.")
21799 ("But don't worry; continue and I'll just ignore it.");
21800 mp_put_get_error(mp);
21801 } else if ( r==null ) {
21802 @<Exclaim about a redundant equation@>;
21804 mp_free_node(mp, p,dep_node_size);
21807 @ @<Add the right operand to list |p|@>=
21809 if ( mp->cur_type==mp_known ) {
21810 value(q)=value(q)+mp->cur_exp; goto DONE1;
21813 if ( tt==mp_independent ) pp=mp_single_dependency(mp, mp->cur_exp);
21814 else pp=dep_list(mp->cur_exp);
21817 if ( type(r)==mp_known ) {
21818 value(q)=value(q)+value(r); goto DONE1;
21821 if ( tt==mp_independent ) pp=mp_single_dependency(mp, r);
21822 else pp=dep_list(r);
21825 if ( tt!=mp_independent ) copied=false;
21826 else { copied=true; tt=mp_dependent; };
21827 @<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>;
21828 if ( copied ) mp_flush_node_list(mp, pp);
21831 @ @<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>=
21832 mp->watch_coefs=false;
21834 p=mp_p_plus_q(mp, p,pp,t);
21835 } else if ( t==mp_proto_dependent ) {
21836 p=mp_p_plus_fq(mp, p,unity,pp,mp_proto_dependent,mp_dependent);
21839 while ( info(q)!=null ) {
21840 value(q)=mp_round_fraction(mp, value(q)); q=link(q);
21842 t=mp_proto_dependent; p=mp_p_plus_q(mp, p,pp,t);
21844 mp->watch_coefs=true;
21846 @ Our next goal is to process type declarations. For this purpose it's
21847 convenient to have a procedure that scans a $\langle\,$declared
21848 variable$\,\rangle$ and returns the corresponding token list. After the
21849 following procedure has acted, the token after the declared variable
21850 will have been scanned, so it will appear in |cur_cmd|, |cur_mod|,
21853 @<Declare the function called |scan_declared_variable|@>=
21854 pointer mp_scan_declared_variable (MP mp) {
21855 pointer x; /* hash address of the variable's root */
21856 pointer h,t; /* head and tail of the token list to be returned */
21857 pointer l; /* hash address of left bracket */
21858 mp_get_symbol(mp); x=mp->cur_sym;
21859 if ( mp->cur_cmd!=tag_token ) mp_clear_symbol(mp, x,false);
21860 h=mp_get_avail(mp); info(h)=x; t=h;
21863 if ( mp->cur_sym==0 ) break;
21864 if ( mp->cur_cmd!=tag_token ) if ( mp->cur_cmd!=internal_quantity) {
21865 if ( mp->cur_cmd==left_bracket ) {
21866 @<Descend past a collective subscript@>;
21871 link(t)=mp_get_avail(mp); t=link(t); info(t)=mp->cur_sym;
21873 if ( (eq_type(x)%outer_tag)!=tag_token ) mp_clear_symbol(mp, x,false);
21874 if ( equiv(x)==null ) mp_new_root(mp, x);
21878 @ If the subscript isn't collective, we don't accept it as part of the
21881 @<Descend past a collective subscript@>=
21883 l=mp->cur_sym; mp_get_x_next(mp);
21884 if ( mp->cur_cmd!=right_bracket ) {
21885 mp_back_input(mp); mp->cur_sym=l; mp->cur_cmd=left_bracket; break;
21887 mp->cur_sym=collective_subscript;
21891 @ Type declarations are introduced by the following primitive operations.
21894 mp_primitive(mp, "numeric",type_name,mp_numeric_type);
21895 @:numeric_}{\&{numeric} primitive@>
21896 mp_primitive(mp, "string",type_name,mp_string_type);
21897 @:string_}{\&{string} primitive@>
21898 mp_primitive(mp, "boolean",type_name,mp_boolean_type);
21899 @:boolean_}{\&{boolean} primitive@>
21900 mp_primitive(mp, "path",type_name,mp_path_type);
21901 @:path_}{\&{path} primitive@>
21902 mp_primitive(mp, "pen",type_name,mp_pen_type);
21903 @:pen_}{\&{pen} primitive@>
21904 mp_primitive(mp, "picture",type_name,mp_picture_type);
21905 @:picture_}{\&{picture} primitive@>
21906 mp_primitive(mp, "transform",type_name,mp_transform_type);
21907 @:transform_}{\&{transform} primitive@>
21908 mp_primitive(mp, "color",type_name,mp_color_type);
21909 @:color_}{\&{color} primitive@>
21910 mp_primitive(mp, "rgbcolor",type_name,mp_color_type);
21911 @:color_}{\&{rgbcolor} primitive@>
21912 mp_primitive(mp, "cmykcolor",type_name,mp_cmykcolor_type);
21913 @:color_}{\&{cmykcolor} primitive@>
21914 mp_primitive(mp, "pair",type_name,mp_pair_type);
21915 @:pair_}{\&{pair} primitive@>
21917 @ @<Cases of |print_cmd...@>=
21918 case type_name: mp_print_type(mp, m); break;
21920 @ Now we are ready to handle type declarations, assuming that a
21921 |type_name| has just been scanned.
21923 @<Declare action procedures for use by |do_statement|@>=
21924 void mp_do_type_declaration (MP mp) ;
21927 void mp_do_type_declaration (MP mp) {
21928 small_number t; /* the type being declared */
21929 pointer p; /* token list for a declared variable */
21930 pointer q; /* value node for the variable */
21931 if ( mp->cur_mod>=mp_transform_type )
21934 t=mp->cur_mod+unknown_tag;
21936 p=mp_scan_declared_variable(mp);
21937 mp_flush_variable(mp, equiv(info(p)),link(p),false);
21938 q=mp_find_variable(mp, p);
21940 type(q)=t; value(q)=null;
21942 print_err("Declared variable conflicts with previous vardef");
21943 @.Declared variable conflicts...@>
21944 help2("You can't use, e.g., `numeric foo[]' after `vardef foo'.")
21945 ("Proceed, and I'll ignore the illegal redeclaration.");
21946 mp_put_get_error(mp);
21948 mp_flush_list(mp, p);
21949 if ( mp->cur_cmd<comma ) {
21950 @<Flush spurious symbols after the declared variable@>;
21952 } while (! end_of_statement);
21955 @ @<Flush spurious symbols after the declared variable@>=
21957 print_err("Illegal suffix of declared variable will be flushed");
21958 @.Illegal suffix...flushed@>
21959 help5("Variables in declarations must consist entirely of")
21960 ("names and collective subscripts, e.g., `x[]a'.")
21961 ("Are you trying to use a reserved word in a variable name?")
21962 ("I'm going to discard the junk I found here,")
21963 ("up to the next comma or the end of the declaration.");
21964 if ( mp->cur_cmd==numeric_token )
21965 mp->help_line[2]="Explicit subscripts like `x15a' aren't permitted.";
21966 mp_put_get_error(mp); mp->scanner_status=flushing;
21969 @<Decrease the string reference count...@>;
21970 } while (mp->cur_cmd<comma); /* either |end_of_statement| or |cur_cmd=comma| */
21971 mp->scanner_status=normal;
21974 @ \MP's |main_control| procedure just calls |do_statement| repeatedly
21975 until coming to the end of the user's program.
21976 Each execution of |do_statement| concludes with
21977 |cur_cmd=semicolon|, |end_group|, or |stop|.
21979 @c void mp_main_control (MP mp) {
21981 mp_do_statement(mp);
21982 if ( mp->cur_cmd==end_group ) {
21983 print_err("Extra `endgroup'");
21984 @.Extra `endgroup'@>
21985 help2("I'm not currently working on a `begingroup',")
21986 ("so I had better not try to end anything.");
21987 mp_flush_error(mp, 0);
21989 } while (mp->cur_cmd!=stop);
21991 int __attribute__((noinline))
21994 if (mp->history < mp_fatal_error_stop ) {
21995 @<Install and test the non-local jump buffer@>;
21996 mp_main_control(mp); /* come to life */
21997 mp_final_cleanup(mp); /* prepare for death */
21998 mp_close_files_and_terminate(mp);
22000 return mp->history;
22003 @ For |mp_execute|, we need to define a structure to store the
22004 redirected input and output. This structure holds the five relevant
22005 streams: the three informational output streams, the PostScript
22006 generation stream, and the input stream. These streams have many
22007 things in common, so it makes sense to give them their own structure
22010 \item{fptr} is a virtual file pointer
22011 \item{data} is the data this stream holds
22012 \item{cur} is a cursor pointing into |data|
22013 \item{size} is the allocated length of the data stream
22014 \item{used} is the actual length of the data stream
22016 There are small differences between input and output: |term_in| never
22017 uses |used|, whereas the other four never use |cur|.
22019 @<Exported types@>=
22020 typedef struct mp_stream {
22028 typedef struct mp_run_data {
22029 mp_stream term_out;
22030 mp_stream error_out;
22034 struct mp_edge_object *edges;
22037 @ We need a function to clear an output stream, this is called at the
22038 beginning of |mp_execute|. We also need one for destroying an output
22039 stream, this is called just before a stream is (re)opened.
22042 static void mp_reset_stream(mp_stream *str) {
22048 static void mp_free_stream(mp_stream *str) {
22050 mp_reset_stream(str);
22053 @ @<Declarations@>=
22054 static void mp_reset_stream(mp_stream *str);
22055 static void mp_free_stream(mp_stream *str);
22057 @ The global instance contains a pointer instead of the actual structure
22058 even though it is essentially static, because that makes it is easier to move
22062 mp_run_data *run_data;
22064 @ Another type is needed: the indirection will overload some of the
22065 file pointer objects in the instance (but not all). For clarity, an
22066 indirect object is used that wraps a |FILE *|.
22069 typedef struct File {
22073 @ Here are all of the functions that need to be overloaded for |mp_execute|.
22076 static void *mplib_open_file(MP mp, const char *fname, const char *fmode, int ftype);
22077 static int mplib_get_char(void *f, mp_run_data * mplib_data);
22078 static void mplib_unget_char(void *f, mp_run_data * mplib_data, int c);
22079 static char *mplib_read_ascii_file(MP mp, void *ff, size_t * size);
22080 static void mplib_write_ascii_file(MP mp, void *ff, const char *s);
22081 static void mplib_read_binary_file(MP mp, void *ff, void **data, size_t * size);
22082 static void mplib_write_binary_file(MP mp, void *ff, void *s, size_t size);
22083 static void mplib_close_file(MP mp, void *ff);
22084 static int mplib_eof_file(MP mp, void *ff);
22085 static void mplib_flush_file(MP mp, void *ff);
22086 static void mplib_shipout_backend(MP mp, int h);
22088 @ The |xmalloc(1,1)| calls make sure the stored indirection values are unique.
22090 @d reset_stream(a) do {
22091 mp_reset_stream(&(a));
22093 ff->f = xmalloc(1,1);
22099 static void *mplib_open_file(MP mp, const char *fname, const char *fmode, int ftype)
22101 File *ff = xmalloc(1, sizeof(File));
22102 mp_run_data *run = mp_rundata(mp);
22104 if (ftype == mp_filetype_terminal) {
22105 if (fmode[0] == 'r') {
22107 ff->f = xmalloc(1,1);
22108 run->term_in.fptr = ff->f;
22111 reset_stream(run->term_out);
22113 } else if (ftype == mp_filetype_error) {
22114 reset_stream(run->error_out);
22115 } else if (ftype == mp_filetype_log) {
22116 reset_stream(run->log_out);
22117 } else if (ftype == mp_filetype_postscript) {
22118 mp_free_stream(&(run->ps_out));
22119 ff->f = xmalloc(1,1);
22120 run->ps_out.fptr = ff->f;
22123 char *f = (mp->find_file)(mp, fname, fmode, ftype);
22126 realmode[0] = *fmode;
22129 ff->f = fopen(f, realmode);
22131 if ((fmode[0] == 'r') && (ff->f == NULL)) {
22139 static int mplib_get_char(void *f, mp_run_data * run)
22142 if (f == run->term_in.fptr && run->term_in.data != NULL) {
22143 if (run->term_in.size == 0) {
22144 if (run->term_in.cur != NULL) {
22145 run->term_in.cur = NULL;
22147 xfree(run->term_in.data);
22151 run->term_in.size--;
22152 c = *(run->term_in.cur)++;
22160 static void mplib_unget_char(void *f, mp_run_data * run, int c)
22162 if (f == run->term_in.fptr && run->term_in.cur != NULL) {
22163 run->term_in.size++;
22164 run->term_in.cur--;
22171 static char *mplib_read_ascii_file(MP mp, void *ff, size_t * size)
22176 size_t len = 0, lim = 128;
22177 mp_run_data *run = mp_rundata(mp);
22178 FILE *f = ((File *) ff)->f;
22182 c = mplib_get_char(f, run);
22188 while (c != EOF && c != '\n' && c != '\r') {
22190 s = xrealloc(s, (lim + (lim >> 2)),1);
22196 c = mplib_get_char(f, run);
22199 c = mplib_get_char(f, run);
22200 if (c != EOF && c != '\n')
22201 mplib_unget_char(f, run, c);
22209 static void mp_append_string (MP mp, mp_stream *a,const char *b) {
22211 if ((a->used+l)>=a->size) {
22212 a->size += 256+(a->size)/5+l;
22213 a->data = xrealloc(a->data,a->size,1);
22215 (void)strcpy(a->data+a->used,b);
22220 static void mplib_write_ascii_file(MP mp, void *ff, const char *s)
22223 void *f = ((File *) ff)->f;
22224 mp_run_data *run = mp_rundata(mp);
22226 if (f == run->term_out.fptr) {
22227 mp_append_string(mp,&(run->term_out), s);
22228 } else if (f == run->error_out.fptr) {
22229 mp_append_string(mp,&(run->error_out), s);
22230 } else if (f == run->log_out.fptr) {
22231 mp_append_string(mp,&(run->log_out), s);
22232 } else if (f == run->ps_out.fptr) {
22233 mp_append_string(mp,&(run->ps_out), s);
22235 fprintf((FILE *) f, "%s", s);
22241 static void mplib_read_binary_file(MP mp, void *ff, void **data, size_t * size)
22246 FILE *f = ((File *) ff)->f;
22248 len = fread(*data, 1, *size, f);
22253 static void mplib_write_binary_file(MP mp, void *ff, void *s, size_t size)
22257 FILE *f = ((File *) ff)->f;
22259 fwrite(s, size, 1, f);
22263 static void mplib_close_file(MP mp, void *ff)
22266 mp_run_data *run = mp_rundata(mp);
22267 void *f = ((File *) ff)->f;
22269 if (f != run->term_out.fptr
22270 && f != run->error_out.fptr
22271 && f != run->log_out.fptr
22272 && f != run->ps_out.fptr
22273 && f != run->term_in.fptr) {
22281 static int mplib_eof_file(MP mp, void *ff)
22284 mp_run_data *run = mp_rundata(mp);
22285 FILE *f = ((File *) ff)->f;
22288 if (f == run->term_in.fptr && run->term_in.data != NULL) {
22289 return (run->term_in.size == 0);
22296 static void mplib_flush_file(MP mp, void *ff)
22303 static void mplib_shipout_backend(MP mp, int h)
22305 struct mp_edge_object *hh = mp_gr_export(mp, h);
22307 mp_run_data *run = mp_rundata(mp);
22308 if (run->edges==NULL) {
22311 struct mp_edge_object *p = run->edges;
22312 while (p->_next!=NULL) { p = p->_next; }
22319 @ This is where we fill them all in.
22320 @<Prepare for non-interactive use@>=
22322 mp_run_data *f = mp_xmalloc(mp,1, sizeof(mp_run_data));
22323 memset(f, 0, sizeof(mp_run_data));
22325 mp->open_file = mplib_open_file;
22326 mp->close_file = mplib_close_file;
22327 mp->eof_file = mplib_eof_file;
22328 mp->flush_file = mplib_flush_file;
22329 mp->write_ascii_file = mplib_write_ascii_file;
22330 mp->read_ascii_file = mplib_read_ascii_file;
22331 mp->write_binary_file = mplib_write_binary_file;
22332 mp->read_binary_file = mplib_read_binary_file;
22333 mp->shipout_backend = mplib_shipout_backend;
22336 @ Perhaps this is the most important API function in the library.
22338 @<Exported function ...@>=
22339 mp_run_data *mp_rundata (MP mp) ;
22342 mp_run_data *mp_rundata (MP mp) {
22343 return mp->run_data;
22347 mp_free_stream(&(mp->run_data->term_in));
22348 mp_free_stream(&(mp->run_data->term_out));
22349 mp_free_stream(&(mp->run_data->log_out));
22350 mp_free_stream(&(mp->run_data->error_out));
22351 mp_free_stream(&(mp->run_data->ps_out));
22352 xfree(mp->run_data);
22354 @ @<Finish non-interactive use@>=
22355 xfree(mp->term_out);
22356 xfree(mp->term_in);
22357 xfree(mp->err_out);
22359 @ @<Start non-interactive work@>=
22361 @<Initialize the output routines@>;
22362 mp->input_ptr=0; mp->max_in_stack=0;
22363 mp->in_open=0; mp->open_parens=0; mp->max_buf_stack=0;
22364 mp->param_ptr=0; mp->max_param_stack=0;
22365 start = index = loc = mp->first = 0;
22366 line=0; name=is_term;
22367 mp->mpx_name[0]=absent;
22368 mp->force_eof=false;
22370 mp->scanner_status=normal;
22371 if (mp->mem_ident==NULL) {
22372 if ( ! mp_open_mem_file(mp) ) {
22373 mp->history = mp_fatal_error_stop;
22374 return mp->history;
22376 if ( ! mp_load_mem_file(mp) ) {
22377 (mp->close_file)(mp, mp->mem_file);
22378 mp->history = mp_fatal_error_stop;
22379 return mp->history;
22381 (mp->close_file)(mp, mp->mem_file);
22383 mp_fix_date_and_time(mp);
22384 if (mp->random_seed==0)
22385 mp->random_seed = (mp->internal[mp_time] / unity)+mp->internal[mp_day];
22386 mp_init_randoms(mp, mp->random_seed);
22387 @<Initialize the print |selector|...@>;
22388 mp_open_log_file(mp);
22390 mp_init_map_file(mp, mp->troff_mode);
22391 mp->history=mp_spotless; /* ready to go! */
22392 if (mp->troff_mode) {
22393 mp->internal[mp_gtroffmode]=unity;
22394 mp->internal[mp_prologues]=unity;
22398 int __attribute__((noinline))
22399 mp_execute (MP mp, char *s, size_t l) {
22401 mp_reset_stream(&(mp->run_data->term_out));
22402 mp_reset_stream(&(mp->run_data->log_out));
22403 mp_reset_stream(&(mp->run_data->error_out));
22404 mp_reset_stream(&(mp->run_data->ps_out));
22405 if (mp->finished) {
22406 return mp->history;
22407 } else if ((!mp->noninteractive) || (!mp->run_data)) {
22408 mp->history = mp_fatal_error_stop ;
22409 return mp->history;
22411 if (mp->history < mp_fatal_error_stop ) {
22412 mp->jump_buf = &buf;
22413 if (setjmp(*(mp->jump_buf)) != 0) {
22414 return mp->history;
22416 if (s==NULL) { /* this signals EOF */
22417 mp_final_cleanup(mp); /* prepare for death */
22418 mp_close_files_and_terminate(mp);
22419 return mp->history;
22422 mp->term_offset=0; mp->file_offset=0;
22423 /* Perhaps some sort of warning here when |data| is not
22424 * yet exhausted would be nice ... this happens after errors
22426 if (mp->run_data->term_in.data)
22427 xfree(mp->run_data->term_in.data);
22428 mp->run_data->term_in.data = xstrdup(s);
22429 mp->run_data->term_in.cur = mp->run_data->term_in.data;
22430 mp->run_data->term_in.size = l;
22431 if (mp->run_state == 0) {
22432 mp->selector=term_only;
22433 @<Start non-interactive work@>;
22436 mp_input_ln(mp,mp->term_in);
22437 mp_firm_up_the_line(mp);
22438 mp->buffer[limit]='%';
22442 mp_do_statement(mp);
22443 } while (mp->cur_cmd!=stop);
22444 mp_final_cleanup(mp);
22445 mp_close_files_and_terminate(mp);
22447 return mp->history;
22450 @ This function cleans up
22452 int __attribute__((noinline))
22453 mp_finish (MP mp) {
22454 int history = mp->history;
22455 if (!mp->finished) {
22456 if (mp->history < mp_fatal_error_stop ) {
22458 mp->jump_buf = &buf;
22459 if (setjmp(*(mp->jump_buf)) != 0) {
22460 history = mp->history;
22461 mp_close_files_and_terminate(mp);
22464 mp_final_cleanup(mp); /* prepare for death */
22465 mp_close_files_and_terminate(mp);
22473 @ People may want to know the library version
22475 const char * mp_metapost_version (void) {
22476 return metapost_version;
22479 @ @<Exported function headers@>=
22480 int mp_run (MP mp);
22481 int mp_execute (MP mp, char *s, size_t l);
22482 int mp_finish (MP mp);
22483 const char * mp_metapost_version (void);
22486 mp_primitive(mp, "end",stop,0);
22487 @:end_}{\&{end} primitive@>
22488 mp_primitive(mp, "dump",stop,1);
22489 @:dump_}{\&{dump} primitive@>
22491 @ @<Cases of |print_cmd...@>=
22493 if ( m==0 ) mp_print(mp, "end");
22494 else mp_print(mp, "dump");
22498 Let's turn now to statements that are classified as ``commands'' because
22499 of their imperative nature. We'll begin with simple ones, so that it
22500 will be clear how to hook command processing into the |do_statement| routine;
22501 then we'll tackle the tougher commands.
22503 Here's one of the simplest:
22505 @<Cases of |do_statement|...@>=
22506 case mp_random_seed: mp_do_random_seed(mp); break;
22508 @ @<Declare action procedures for use by |do_statement|@>=
22509 void mp_do_random_seed (MP mp) ;
22511 @ @c void mp_do_random_seed (MP mp) {
22513 if ( mp->cur_cmd!=assignment ) {
22514 mp_missing_err(mp, ":=");
22516 help1("Always say `randomseed:=<numeric expression>'.");
22519 mp_get_x_next(mp); mp_scan_expression(mp);
22520 if ( mp->cur_type!=mp_known ) {
22521 exp_err("Unknown value will be ignored");
22522 @.Unknown value...ignored@>
22523 help2("Your expression was too random for me to handle,")
22524 ("so I won't change the random seed just now.");
22525 mp_put_get_flush_error(mp, 0);
22527 @<Initialize the random seed to |cur_exp|@>;
22531 @ @<Initialize the random seed to |cur_exp|@>=
22533 mp_init_randoms(mp, mp->cur_exp);
22534 if ( mp->selector>=log_only && mp->selector<write_file) {
22535 mp->old_setting=mp->selector; mp->selector=log_only;
22536 mp_print_nl(mp, "{randomseed:=");
22537 mp_print_scaled(mp, mp->cur_exp);
22538 mp_print_char(mp, '}');
22539 mp_print_nl(mp, ""); mp->selector=mp->old_setting;
22543 @ And here's another simple one (somewhat different in flavor):
22545 @<Cases of |do_statement|...@>=
22547 mp_print_ln(mp); mp->interaction=mp->cur_mod;
22548 @<Initialize the print |selector| based on |interaction|@>;
22549 if ( mp->log_opened ) mp->selector=mp->selector+2;
22554 mp_primitive(mp, "batchmode",mode_command,mp_batch_mode);
22555 @:mp_batch_mode_}{\&{batchmode} primitive@>
22556 mp_primitive(mp, "nonstopmode",mode_command,mp_nonstop_mode);
22557 @:mp_nonstop_mode_}{\&{nonstopmode} primitive@>
22558 mp_primitive(mp, "scrollmode",mode_command,mp_scroll_mode);
22559 @:mp_scroll_mode_}{\&{scrollmode} primitive@>
22560 mp_primitive(mp, "errorstopmode",mode_command,mp_error_stop_mode);
22561 @:mp_error_stop_mode_}{\&{errorstopmode} primitive@>
22563 @ @<Cases of |print_cmd_mod|...@>=
22566 case mp_batch_mode: mp_print(mp, "batchmode"); break;
22567 case mp_nonstop_mode: mp_print(mp, "nonstopmode"); break;
22568 case mp_scroll_mode: mp_print(mp, "scrollmode"); break;
22569 default: mp_print(mp, "errorstopmode"); break;
22573 @ The `\&{inner}' and `\&{outer}' commands are only slightly harder.
22575 @<Cases of |do_statement|...@>=
22576 case protection_command: mp_do_protection(mp); break;
22579 mp_primitive(mp, "inner",protection_command,0);
22580 @:inner_}{\&{inner} primitive@>
22581 mp_primitive(mp, "outer",protection_command,1);
22582 @:outer_}{\&{outer} primitive@>
22584 @ @<Cases of |print_cmd...@>=
22585 case protection_command:
22586 if ( m==0 ) mp_print(mp, "inner");
22587 else mp_print(mp, "outer");
22590 @ @<Declare action procedures for use by |do_statement|@>=
22591 void mp_do_protection (MP mp) ;
22593 @ @c void mp_do_protection (MP mp) {
22594 int m; /* 0 to unprotect, 1 to protect */
22595 halfword t; /* the |eq_type| before we change it */
22598 mp_get_symbol(mp); t=eq_type(mp->cur_sym);
22600 if ( t>=outer_tag )
22601 eq_type(mp->cur_sym)=t-outer_tag;
22602 } else if ( t<outer_tag ) {
22603 eq_type(mp->cur_sym)=t+outer_tag;
22606 } while (mp->cur_cmd==comma);
22609 @ \MP\ never defines the tokens `\.(' and `\.)' to be primitives, but
22610 plain \MP\ begins with the declaration `\&{delimiters} \.{()}'. Such a
22611 declaration assigns the command code |left_delimiter| to `\.{(}' and
22612 |right_delimiter| to `\.{)}'; the |equiv| of each delimiter is the
22613 hash address of its mate.
22615 @<Cases of |do_statement|...@>=
22616 case delimiters: mp_def_delims(mp); break;
22618 @ @<Declare action procedures for use by |do_statement|@>=
22619 void mp_def_delims (MP mp) ;
22621 @ @c void mp_def_delims (MP mp) {
22622 pointer l_delim,r_delim; /* the new delimiter pair */
22623 mp_get_clear_symbol(mp); l_delim=mp->cur_sym;
22624 mp_get_clear_symbol(mp); r_delim=mp->cur_sym;
22625 eq_type(l_delim)=left_delimiter; equiv(l_delim)=r_delim;
22626 eq_type(r_delim)=right_delimiter; equiv(r_delim)=l_delim;
22630 @ Here is a procedure that is called when \MP\ has reached a point
22631 where some right delimiter is mandatory.
22633 @<Declare the procedure called |check_delimiter|@>=
22634 void mp_check_delimiter (MP mp,pointer l_delim, pointer r_delim) {
22635 if ( mp->cur_cmd==right_delimiter )
22636 if ( mp->cur_mod==l_delim )
22638 if ( mp->cur_sym!=r_delim ) {
22639 mp_missing_err(mp, str(text(r_delim)));
22641 help2("I found no right delimiter to match a left one. So I've")
22642 ("put one in, behind the scenes; this may fix the problem.");
22645 print_err("The token `"); mp_print_text(r_delim);
22646 @.The token...delimiter@>
22647 mp_print(mp, "' is no longer a right delimiter");
22648 help3("Strange: This token has lost its former meaning!")
22649 ("I'll read it as a right delimiter this time;")
22650 ("but watch out, I'll probably miss it later.");
22655 @ The next four commands save or change the values associated with tokens.
22657 @<Cases of |do_statement|...@>=
22660 mp_get_symbol(mp); mp_save_variable(mp, mp->cur_sym); mp_get_x_next(mp);
22661 } while (mp->cur_cmd==comma);
22663 case interim_command: mp_do_interim(mp); break;
22664 case let_command: mp_do_let(mp); break;
22665 case new_internal: mp_do_new_internal(mp); break;
22667 @ @<Declare action procedures for use by |do_statement|@>=
22668 void mp_do_statement (MP mp);
22669 void mp_do_interim (MP mp);
22671 @ @c void mp_do_interim (MP mp) {
22673 if ( mp->cur_cmd!=internal_quantity ) {
22674 print_err("The token `");
22675 @.The token...quantity@>
22676 if ( mp->cur_sym==0 ) mp_print(mp, "(%CAPSULE)");
22677 else mp_print_text(mp->cur_sym);
22678 mp_print(mp, "' isn't an internal quantity");
22679 help1("Something like `tracingonline' should follow `interim'.");
22682 mp_save_internal(mp, mp->cur_mod); mp_back_input(mp);
22684 mp_do_statement(mp);
22687 @ The following procedure is careful not to undefine the left-hand symbol
22688 too soon, lest commands like `{\tt let x=x}' have a surprising effect.
22690 @<Declare action procedures for use by |do_statement|@>=
22691 void mp_do_let (MP mp) ;
22693 @ @c void mp_do_let (MP mp) {
22694 pointer l; /* hash location of the left-hand symbol */
22695 mp_get_symbol(mp); l=mp->cur_sym; mp_get_x_next(mp);
22696 if ( mp->cur_cmd!=equals ) if ( mp->cur_cmd!=assignment ) {
22697 mp_missing_err(mp, "=");
22699 help3("You should have said `let symbol = something'.")
22700 ("But don't worry; I'll pretend that an equals sign")
22701 ("was present. The next token I read will be `something'.");
22705 switch (mp->cur_cmd) {
22706 case defined_macro: case secondary_primary_macro:
22707 case tertiary_secondary_macro: case expression_tertiary_macro:
22708 add_mac_ref(mp->cur_mod);
22713 mp_clear_symbol(mp, l,false); eq_type(l)=mp->cur_cmd;
22714 if ( mp->cur_cmd==tag_token ) equiv(l)=null;
22715 else equiv(l)=mp->cur_mod;
22719 @ @<Declarations@>=
22720 void mp_grow_internals (MP mp, int l);
22721 void mp_do_new_internal (MP mp) ;
22724 void mp_grow_internals (MP mp, int l) {
22728 if ( hash_end+l>max_halfword ) {
22729 mp_confusion(mp, "out of memory space"); /* can't be reached */
22731 int_name = xmalloc ((l+1),sizeof(char *));
22732 internal = xmalloc ((l+1),sizeof(scaled));
22733 for (k=0;k<=l; k++ ) {
22734 if (k<=mp->max_internal) {
22735 internal[k]=mp->internal[k];
22736 int_name[k]=mp->int_name[k];
22742 xfree(mp->internal); xfree(mp->int_name);
22743 mp->int_name = int_name;
22744 mp->internal = internal;
22745 mp->max_internal = l;
22749 void mp_do_new_internal (MP mp) {
22751 if ( mp->int_ptr==mp->max_internal ) {
22752 mp_grow_internals(mp, (mp->max_internal + (mp->max_internal>>2)));
22754 mp_get_clear_symbol(mp); incr(mp->int_ptr);
22755 eq_type(mp->cur_sym)=internal_quantity;
22756 equiv(mp->cur_sym)=mp->int_ptr;
22757 if(mp->int_name[mp->int_ptr]!=NULL)
22758 xfree(mp->int_name[mp->int_ptr]);
22759 mp->int_name[mp->int_ptr]=str(text(mp->cur_sym));
22760 mp->internal[mp->int_ptr]=0;
22762 } while (mp->cur_cmd==comma);
22765 @ @<Dealloc variables@>=
22766 for (k=0;k<=mp->max_internal;k++) {
22767 xfree(mp->int_name[k]);
22769 xfree(mp->internal);
22770 xfree(mp->int_name);
22773 @ The various `\&{show}' commands are distinguished by modifier fields
22776 @d show_token_code 0 /* show the meaning of a single token */
22777 @d show_stats_code 1 /* show current memory and string usage */
22778 @d show_code 2 /* show a list of expressions */
22779 @d show_var_code 3 /* show a variable and its descendents */
22780 @d show_dependencies_code 4 /* show dependent variables in terms of independents */
22783 mp_primitive(mp, "showtoken",show_command,show_token_code);
22784 @:show_token_}{\&{showtoken} primitive@>
22785 mp_primitive(mp, "showstats",show_command,show_stats_code);
22786 @:show_stats_}{\&{showstats} primitive@>
22787 mp_primitive(mp, "show",show_command,show_code);
22788 @:show_}{\&{show} primitive@>
22789 mp_primitive(mp, "showvariable",show_command,show_var_code);
22790 @:show_var_}{\&{showvariable} primitive@>
22791 mp_primitive(mp, "showdependencies",show_command,show_dependencies_code);
22792 @:show_dependencies_}{\&{showdependencies} primitive@>
22794 @ @<Cases of |print_cmd...@>=
22797 case show_token_code:mp_print(mp, "showtoken"); break;
22798 case show_stats_code:mp_print(mp, "showstats"); break;
22799 case show_code:mp_print(mp, "show"); break;
22800 case show_var_code:mp_print(mp, "showvariable"); break;
22801 default: mp_print(mp, "showdependencies"); break;
22805 @ @<Cases of |do_statement|...@>=
22806 case show_command:mp_do_show_whatever(mp); break;
22808 @ The value of |cur_mod| controls the |verbosity| in the |print_exp| routine:
22809 if it's |show_code|, complicated structures are abbreviated, otherwise
22812 @<Declare action procedures for use by |do_statement|@>=
22813 void mp_do_show (MP mp) ;
22815 @ @c void mp_do_show (MP mp) {
22817 mp_get_x_next(mp); mp_scan_expression(mp);
22818 mp_print_nl(mp, ">> ");
22820 mp_print_exp(mp, null,2); mp_flush_cur_exp(mp, 0);
22821 } while (mp->cur_cmd==comma);
22824 @ @<Declare action procedures for use by |do_statement|@>=
22825 void mp_disp_token (MP mp) ;
22827 @ @c void mp_disp_token (MP mp) {
22828 mp_print_nl(mp, "> ");
22830 if ( mp->cur_sym==0 ) {
22831 @<Show a numeric or string or capsule token@>;
22833 mp_print_text(mp->cur_sym); mp_print_char(mp, '=');
22834 if ( eq_type(mp->cur_sym)>=outer_tag ) mp_print(mp, "(outer) ");
22835 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod);
22836 if ( mp->cur_cmd==defined_macro ) {
22837 mp_print_ln(mp); mp_show_macro(mp, mp->cur_mod,null,100000);
22838 } /* this avoids recursion between |show_macro| and |print_cmd_mod| */
22843 @ @<Show a numeric or string or capsule token@>=
22845 if ( mp->cur_cmd==numeric_token ) {
22846 mp_print_scaled(mp, mp->cur_mod);
22847 } else if ( mp->cur_cmd==capsule_token ) {
22848 mp_print_capsule(mp,mp->cur_mod);
22850 mp_print_char(mp, '"');
22851 mp_print_str(mp, mp->cur_mod); mp_print_char(mp, '"');
22852 delete_str_ref(mp->cur_mod);
22856 @ The following cases of |print_cmd_mod| might arise in connection
22857 with |disp_token|, although they don't necessarily correspond to
22860 @<Cases of |print_cmd_...@>=
22861 case left_delimiter:
22862 case right_delimiter:
22863 if ( c==left_delimiter ) mp_print(mp, "left");
22864 else mp_print(mp, "right");
22865 mp_print(mp, " delimiter that matches ");
22869 if ( m==null ) mp_print(mp, "tag");
22870 else mp_print(mp, "variable");
22872 case defined_macro:
22873 mp_print(mp, "macro:");
22875 case secondary_primary_macro:
22876 case tertiary_secondary_macro:
22877 case expression_tertiary_macro:
22878 mp_print_cmd_mod(mp, macro_def,c);
22879 mp_print(mp, "'d macro:");
22880 mp_print_ln(mp); mp_show_token_list(mp, link(link(m)),null,1000,0);
22883 mp_print(mp, "[repeat the loop]");
22885 case internal_quantity:
22886 mp_print(mp, mp->int_name[m]);
22889 @ @<Declare action procedures for use by |do_statement|@>=
22890 void mp_do_show_token (MP mp) ;
22892 @ @c void mp_do_show_token (MP mp) {
22894 get_t_next; mp_disp_token(mp);
22896 } while (mp->cur_cmd==comma);
22899 @ @<Declare action procedures for use by |do_statement|@>=
22900 void mp_do_show_stats (MP mp) ;
22902 @ @c void mp_do_show_stats (MP mp) {
22903 mp_print_nl(mp, "Memory usage ");
22904 @.Memory usage...@>
22905 mp_print_int(mp, mp->var_used); mp_print_char(mp, '&'); mp_print_int(mp, mp->dyn_used);
22906 mp_print(mp, " ("); mp_print_int(mp, mp->hi_mem_min-mp->lo_mem_max-1);
22907 mp_print(mp, " still untouched)"); mp_print_ln(mp);
22908 mp_print_nl(mp, "String usage ");
22909 mp_print_int(mp, mp->strs_in_use-mp->init_str_use);
22910 mp_print_char(mp, '&'); mp_print_int(mp, mp->pool_in_use-mp->init_pool_ptr);
22911 mp_print(mp, " (");
22912 mp_print_int(mp, mp->max_strings-1-mp->strs_used_up); mp_print_char(mp, '&');
22913 mp_print_int(mp, mp->pool_size-mp->pool_ptr);
22914 mp_print(mp, " now untouched)"); mp_print_ln(mp);
22918 @ Here's a recursive procedure that gives an abbreviated account
22919 of a variable, for use by |do_show_var|.
22921 @<Declare action procedures for use by |do_statement|@>=
22922 void mp_disp_var (MP mp,pointer p) ;
22924 @ @c void mp_disp_var (MP mp,pointer p) {
22925 pointer q; /* traverses attributes and subscripts */
22926 int n; /* amount of macro text to show */
22927 if ( type(p)==mp_structured ) {
22928 @<Descend the structure@>;
22929 } else if ( type(p)>=mp_unsuffixed_macro ) {
22930 @<Display a variable macro@>;
22931 } else if ( type(p)!=undefined ){
22932 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22933 mp_print_char(mp, '=');
22934 mp_print_exp(mp, p,0);
22938 @ @<Descend the structure@>=
22941 do { mp_disp_var(mp, q); q=link(q); } while (q!=end_attr);
22943 while ( name_type(q)==mp_subscr ) {
22944 mp_disp_var(mp, q); q=link(q);
22948 @ @<Display a variable macro@>=
22950 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22951 if ( type(p)>mp_unsuffixed_macro )
22952 mp_print(mp, "@@#"); /* |suffixed_macro| */
22953 mp_print(mp, "=macro:");
22954 if ( (int)mp->file_offset>=mp->max_print_line-20 ) n=5;
22955 else n=mp->max_print_line-mp->file_offset-15;
22956 mp_show_macro(mp, value(p),null,n);
22959 @ @<Declare action procedures for use by |do_statement|@>=
22960 void mp_do_show_var (MP mp) ;
22962 @ @c void mp_do_show_var (MP mp) {
22965 if ( mp->cur_sym>0 ) if ( mp->cur_sym<=hash_end )
22966 if ( mp->cur_cmd==tag_token ) if ( mp->cur_mod!=null ) {
22967 mp_disp_var(mp, mp->cur_mod); goto DONE;
22972 } while (mp->cur_cmd==comma);
22975 @ @<Declare action procedures for use by |do_statement|@>=
22976 void mp_do_show_dependencies (MP mp) ;
22978 @ @c void mp_do_show_dependencies (MP mp) {
22979 pointer p; /* link that runs through all dependencies */
22981 while ( p!=dep_head ) {
22982 if ( mp_interesting(mp, p) ) {
22983 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22984 if ( type(p)==mp_dependent ) mp_print_char(mp, '=');
22985 else mp_print(mp, " = "); /* extra spaces imply proto-dependency */
22986 mp_print_dependency(mp, dep_list(p),type(p));
22989 while ( info(p)!=null ) p=link(p);
22995 @ Finally we are ready for the procedure that governs all of the
22998 @<Declare action procedures for use by |do_statement|@>=
22999 void mp_do_show_whatever (MP mp) ;
23001 @ @c void mp_do_show_whatever (MP mp) {
23002 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
23003 switch (mp->cur_mod) {
23004 case show_token_code:mp_do_show_token(mp); break;
23005 case show_stats_code:mp_do_show_stats(mp); break;
23006 case show_code:mp_do_show(mp); break;
23007 case show_var_code:mp_do_show_var(mp); break;
23008 case show_dependencies_code:mp_do_show_dependencies(mp); break;
23009 } /* there are no other cases */
23010 if ( mp->internal[mp_showstopping]>0 ){
23013 if ( mp->interaction<mp_error_stop_mode ) {
23014 help0; decr(mp->error_count);
23016 help1("This isn't an error message; I'm just showing something.");
23018 if ( mp->cur_cmd==semicolon ) mp_error(mp);
23019 else mp_put_get_error(mp);
23023 @ The `\&{addto}' command needs the following additional primitives:
23025 @d double_path_code 0 /* command modifier for `\&{doublepath}' */
23026 @d contour_code 1 /* command modifier for `\&{contour}' */
23027 @d also_code 2 /* command modifier for `\&{also}' */
23029 @ Pre and postscripts need two new identifiers:
23031 @d with_pre_script 11
23032 @d with_post_script 13
23035 mp_primitive(mp, "doublepath",thing_to_add,double_path_code);
23036 @:double_path_}{\&{doublepath} primitive@>
23037 mp_primitive(mp, "contour",thing_to_add,contour_code);
23038 @:contour_}{\&{contour} primitive@>
23039 mp_primitive(mp, "also",thing_to_add,also_code);
23040 @:also_}{\&{also} primitive@>
23041 mp_primitive(mp, "withpen",with_option,mp_pen_type);
23042 @:with_pen_}{\&{withpen} primitive@>
23043 mp_primitive(mp, "dashed",with_option,mp_picture_type);
23044 @:dashed_}{\&{dashed} primitive@>
23045 mp_primitive(mp, "withprescript",with_option,with_pre_script);
23046 @:with_pre_script_}{\&{withprescript} primitive@>
23047 mp_primitive(mp, "withpostscript",with_option,with_post_script);
23048 @:with_post_script_}{\&{withpostscript} primitive@>
23049 mp_primitive(mp, "withoutcolor",with_option,mp_no_model);
23050 @:with_color_}{\&{withoutcolor} primitive@>
23051 mp_primitive(mp, "withgreyscale",with_option,mp_grey_model);
23052 @:with_color_}{\&{withgreyscale} primitive@>
23053 mp_primitive(mp, "withcolor",with_option,mp_uninitialized_model);
23054 @:with_color_}{\&{withcolor} primitive@>
23055 /* \&{withrgbcolor} is an alias for \&{withcolor} */
23056 mp_primitive(mp, "withrgbcolor",with_option,mp_rgb_model);
23057 @:with_color_}{\&{withrgbcolor} primitive@>
23058 mp_primitive(mp, "withcmykcolor",with_option,mp_cmyk_model);
23059 @:with_color_}{\&{withcmykcolor} primitive@>
23061 @ @<Cases of |print_cmd...@>=
23063 if ( m==contour_code ) mp_print(mp, "contour");
23064 else if ( m==double_path_code ) mp_print(mp, "doublepath");
23065 else mp_print(mp, "also");
23068 if ( m==mp_pen_type ) mp_print(mp, "withpen");
23069 else if ( m==with_pre_script ) mp_print(mp, "withprescript");
23070 else if ( m==with_post_script ) mp_print(mp, "withpostscript");
23071 else if ( m==mp_no_model ) mp_print(mp, "withoutcolor");
23072 else if ( m==mp_rgb_model ) mp_print(mp, "withrgbcolor");
23073 else if ( m==mp_uninitialized_model ) mp_print(mp, "withcolor");
23074 else if ( m==mp_cmyk_model ) mp_print(mp, "withcmykcolor");
23075 else if ( m==mp_grey_model ) mp_print(mp, "withgreyscale");
23076 else mp_print(mp, "dashed");
23079 @ The |scan_with_list| procedure parses a $\langle$with list$\rangle$ and
23080 updates the list of graphical objects starting at |p|. Each $\langle$with
23081 clause$\rangle$ updates all graphical objects whose |type| is compatible.
23082 Other objects are ignored.
23084 @<Declare action procedures for use by |do_statement|@>=
23085 void mp_scan_with_list (MP mp,pointer p) ;
23087 @ @c void mp_scan_with_list (MP mp,pointer p) {
23088 small_number t; /* |cur_mod| of the |with_option| (should match |cur_type|) */
23089 pointer q; /* for list manipulation */
23090 int old_setting; /* saved |selector| setting */
23091 pointer k; /* for finding the near-last item in a list */
23092 str_number s; /* for string cleanup after combining */
23093 pointer cp,pp,dp,ap,bp;
23094 /* objects being updated; |void| initially; |null| to suppress update */
23095 cp=mp_void; pp=mp_void; dp=mp_void; ap=mp_void; bp=mp_void;
23097 while ( mp->cur_cmd==with_option ){
23100 if ( t!=mp_no_model ) mp_scan_expression(mp);
23101 if (((t==with_pre_script)&&(mp->cur_type!=mp_string_type))||
23102 ((t==with_post_script)&&(mp->cur_type!=mp_string_type))||
23103 ((t==mp_uninitialized_model)&&
23104 ((mp->cur_type!=mp_cmykcolor_type)&&(mp->cur_type!=mp_color_type)
23105 &&(mp->cur_type!=mp_known)&&(mp->cur_type!=mp_boolean_type)))||
23106 ((t==mp_cmyk_model)&&(mp->cur_type!=mp_cmykcolor_type))||
23107 ((t==mp_rgb_model)&&(mp->cur_type!=mp_color_type))||
23108 ((t==mp_grey_model)&&(mp->cur_type!=mp_known))||
23109 ((t==mp_pen_type)&&(mp->cur_type!=t))||
23110 ((t==mp_picture_type)&&(mp->cur_type!=t)) ) {
23111 @<Complain about improper type@>;
23112 } else if ( t==mp_uninitialized_model ) {
23113 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
23115 @<Transfer a color from the current expression to object~|cp|@>;
23116 mp_flush_cur_exp(mp, 0);
23117 } else if ( t==mp_rgb_model ) {
23118 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
23120 @<Transfer a rgbcolor from the current expression to object~|cp|@>;
23121 mp_flush_cur_exp(mp, 0);
23122 } else if ( t==mp_cmyk_model ) {
23123 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
23125 @<Transfer a cmykcolor from the current expression to object~|cp|@>;
23126 mp_flush_cur_exp(mp, 0);
23127 } else if ( t==mp_grey_model ) {
23128 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
23130 @<Transfer a greyscale from the current expression to object~|cp|@>;
23131 mp_flush_cur_exp(mp, 0);
23132 } else if ( t==mp_no_model ) {
23133 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
23135 @<Transfer a noncolor from the current expression to object~|cp|@>;
23136 } else if ( t==mp_pen_type ) {
23137 if ( pp==mp_void ) @<Make |pp| an object in list~|p| that needs a pen@>;
23139 if ( pen_p(pp)!=null ) mp_toss_knot_list(mp, pen_p(pp));
23140 pen_p(pp)=mp->cur_exp; mp->cur_type=mp_vacuous;
23142 } else if ( t==with_pre_script ) {
23145 while ( (ap!=null)&&(! has_color(ap)) )
23148 if ( pre_script(ap)!=null ) { /* build a new,combined string */
23150 old_setting=mp->selector;
23151 mp->selector=new_string;
23152 str_room(length(pre_script(ap))+length(mp->cur_exp)+2);
23153 mp_print_str(mp, mp->cur_exp);
23154 append_char(13); /* a forced \ps\ newline */
23155 mp_print_str(mp, pre_script(ap));
23156 pre_script(ap)=mp_make_string(mp);
23158 mp->selector=old_setting;
23160 pre_script(ap)=mp->cur_exp;
23162 mp->cur_type=mp_vacuous;
23164 } else if ( t==with_post_script ) {
23168 while ( link(k)!=null ) {
23170 if ( has_color(k) ) bp=k;
23173 if ( post_script(bp)!=null ) {
23175 old_setting=mp->selector;
23176 mp->selector=new_string;
23177 str_room(length(post_script(bp))+length(mp->cur_exp)+2);
23178 mp_print_str(mp, post_script(bp));
23179 append_char(13); /* a forced \ps\ newline */
23180 mp_print_str(mp, mp->cur_exp);
23181 post_script(bp)=mp_make_string(mp);
23183 mp->selector=old_setting;
23185 post_script(bp)=mp->cur_exp;
23187 mp->cur_type=mp_vacuous;
23190 if ( dp==mp_void ) {
23191 @<Make |dp| a stroked node in list~|p|@>;
23194 if ( dash_p(dp)!=null ) delete_edge_ref(dash_p(dp));
23195 dash_p(dp)=mp_make_dashes(mp, mp->cur_exp);
23196 dash_scale(dp)=unity;
23197 mp->cur_type=mp_vacuous;
23201 @<Copy the information from objects |cp|, |pp|, and |dp| into the rest
23205 @ @<Complain about improper type@>=
23206 { exp_err("Improper type");
23208 help2("Next time say `withpen <known pen expression>';")
23209 ("I'll ignore the bad `with' clause and look for another.");
23210 if ( t==with_pre_script )
23211 mp->help_line[1]="Next time say `withprescript <known string expression>';";
23212 else if ( t==with_post_script )
23213 mp->help_line[1]="Next time say `withpostscript <known string expression>';";
23214 else if ( t==mp_picture_type )
23215 mp->help_line[1]="Next time say `dashed <known picture expression>';";
23216 else if ( t==mp_uninitialized_model )
23217 mp->help_line[1]="Next time say `withcolor <known color expression>';";
23218 else if ( t==mp_rgb_model )
23219 mp->help_line[1]="Next time say `withrgbcolor <known color expression>';";
23220 else if ( t==mp_cmyk_model )
23221 mp->help_line[1]="Next time say `withcmykcolor <known cmykcolor expression>';";
23222 else if ( t==mp_grey_model )
23223 mp->help_line[1]="Next time say `withgreyscale <known numeric expression>';";;
23224 mp_put_get_flush_error(mp, 0);
23227 @ Forcing the color to be between |0| and |unity| here guarantees that no
23228 picture will ever contain a color outside the legal range for \ps\ graphics.
23230 @<Transfer a color from the current expression to object~|cp|@>=
23231 { if ( mp->cur_type==mp_color_type )
23232 @<Transfer a rgbcolor from the current expression to object~|cp|@>
23233 else if ( mp->cur_type==mp_cmykcolor_type )
23234 @<Transfer a cmykcolor from the current expression to object~|cp|@>
23235 else if ( mp->cur_type==mp_known )
23236 @<Transfer a greyscale from the current expression to object~|cp|@>
23237 else if ( mp->cur_exp==false_code )
23238 @<Transfer a noncolor from the current expression to object~|cp|@>;
23241 @ @<Transfer a rgbcolor from the current expression to object~|cp|@>=
23242 { q=value(mp->cur_exp);
23247 red_val(cp)=value(red_part_loc(q));
23248 green_val(cp)=value(green_part_loc(q));
23249 blue_val(cp)=value(blue_part_loc(q));
23250 color_model(cp)=mp_rgb_model;
23251 if ( red_val(cp)<0 ) red_val(cp)=0;
23252 if ( green_val(cp)<0 ) green_val(cp)=0;
23253 if ( blue_val(cp)<0 ) blue_val(cp)=0;
23254 if ( red_val(cp)>unity ) red_val(cp)=unity;
23255 if ( green_val(cp)>unity ) green_val(cp)=unity;
23256 if ( blue_val(cp)>unity ) blue_val(cp)=unity;
23259 @ @<Transfer a cmykcolor from the current expression to object~|cp|@>=
23260 { q=value(mp->cur_exp);
23261 cyan_val(cp)=value(cyan_part_loc(q));
23262 magenta_val(cp)=value(magenta_part_loc(q));
23263 yellow_val(cp)=value(yellow_part_loc(q));
23264 black_val(cp)=value(black_part_loc(q));
23265 color_model(cp)=mp_cmyk_model;
23266 if ( cyan_val(cp)<0 ) cyan_val(cp)=0;
23267 if ( magenta_val(cp)<0 ) magenta_val(cp)=0;
23268 if ( yellow_val(cp)<0 ) yellow_val(cp)=0;
23269 if ( black_val(cp)<0 ) black_val(cp)=0;
23270 if ( cyan_val(cp)>unity ) cyan_val(cp)=unity;
23271 if ( magenta_val(cp)>unity ) magenta_val(cp)=unity;
23272 if ( yellow_val(cp)>unity ) yellow_val(cp)=unity;
23273 if ( black_val(cp)>unity ) black_val(cp)=unity;
23276 @ @<Transfer a greyscale from the current expression to object~|cp|@>=
23283 color_model(cp)=mp_grey_model;
23284 if ( grey_val(cp)<0 ) grey_val(cp)=0;
23285 if ( grey_val(cp)>unity ) grey_val(cp)=unity;
23288 @ @<Transfer a noncolor from the current expression to object~|cp|@>=
23295 color_model(cp)=mp_no_model;
23298 @ @<Make |cp| a colored object in object list~|p|@>=
23300 while ( cp!=null ){
23301 if ( has_color(cp) ) break;
23306 @ @<Make |pp| an object in list~|p| that needs a pen@>=
23308 while ( pp!=null ) {
23309 if ( has_pen(pp) ) break;
23314 @ @<Make |dp| a stroked node in list~|p|@>=
23316 while ( dp!=null ) {
23317 if ( type(dp)==mp_stroked_code ) break;
23322 @ @<Copy the information from objects |cp|, |pp|, and |dp| into...@>=
23323 @<Copy |cp|'s color into the colored objects linked to~|cp|@>;
23324 if ( pp>mp_void ) {
23325 @<Copy |pen_p(pp)| into stroked and filled nodes linked to |pp|@>;
23327 if ( dp>mp_void ) {
23328 @<Make stroked nodes linked to |dp| refer to |dash_p(dp)|@>;
23332 @ @<Copy |cp|'s color into the colored objects linked to~|cp|@>=
23334 while ( q!=null ) {
23335 if ( has_color(q) ) {
23336 red_val(q)=red_val(cp);
23337 green_val(q)=green_val(cp);
23338 blue_val(q)=blue_val(cp);
23339 black_val(q)=black_val(cp);
23340 color_model(q)=color_model(cp);
23346 @ @<Copy |pen_p(pp)| into stroked and filled nodes linked to |pp|@>=
23348 while ( q!=null ) {
23349 if ( has_pen(q) ) {
23350 if ( pen_p(q)!=null ) mp_toss_knot_list(mp, pen_p(q));
23351 pen_p(q)=copy_pen(pen_p(pp));
23357 @ @<Make stroked nodes linked to |dp| refer to |dash_p(dp)|@>=
23359 while ( q!=null ) {
23360 if ( type(q)==mp_stroked_code ) {
23361 if ( dash_p(q)!=null ) delete_edge_ref(dash_p(q));
23362 dash_p(q)=dash_p(dp);
23363 dash_scale(q)=unity;
23364 if ( dash_p(q)!=null ) add_edge_ref(dash_p(q));
23370 @ One of the things we need to do when we've parsed an \&{addto} or
23371 similar command is find the header of a supposed \&{picture} variable, given
23372 a token list for that variable. Since the edge structure is about to be
23373 updated, we use |private_edges| to make sure that this is possible.
23375 @<Declare action procedures for use by |do_statement|@>=
23376 pointer mp_find_edges_var (MP mp, pointer t) ;
23378 @ @c pointer mp_find_edges_var (MP mp, pointer t) {
23380 pointer cur_edges; /* the return value */
23381 p=mp_find_variable(mp, t); cur_edges=null;
23383 mp_obliterated(mp, t); mp_put_get_error(mp);
23384 } else if ( type(p)!=mp_picture_type ) {
23385 print_err("Variable "); mp_show_token_list(mp, t,null,1000,0);
23386 @.Variable x is the wrong type@>
23387 mp_print(mp, " is the wrong type (");
23388 mp_print_type(mp, type(p)); mp_print_char(mp, ')');
23389 help2("I was looking for a \"known\" picture variable.")
23390 ("So I'll not change anything just now.");
23391 mp_put_get_error(mp);
23393 value(p)=mp_private_edges(mp, value(p));
23394 cur_edges=value(p);
23396 mp_flush_node_list(mp, t);
23400 @ @<Cases of |do_statement|...@>=
23401 case add_to_command: mp_do_add_to(mp); break;
23402 case bounds_command:mp_do_bounds(mp); break;
23405 mp_primitive(mp, "clip",bounds_command,mp_start_clip_code);
23406 @:clip_}{\&{clip} primitive@>
23407 mp_primitive(mp, "setbounds",bounds_command,mp_start_bounds_code);
23408 @:set_bounds_}{\&{setbounds} primitive@>
23410 @ @<Cases of |print_cmd...@>=
23411 case bounds_command:
23412 if ( m==mp_start_clip_code ) mp_print(mp, "clip");
23413 else mp_print(mp, "setbounds");
23416 @ The following function parses the beginning of an \&{addto} or \&{clip}
23417 command: it expects a variable name followed by a token with |cur_cmd=sep|
23418 and then an expression. The function returns the token list for the variable
23419 and stores the command modifier for the separator token in the global variable
23420 |last_add_type|. We must be careful because this variable might get overwritten
23421 any time we call |get_x_next|.
23424 quarterword last_add_type;
23425 /* command modifier that identifies the last \&{addto} command */
23427 @ @<Declare action procedures for use by |do_statement|@>=
23428 pointer mp_start_draw_cmd (MP mp,quarterword sep) ;
23430 @ @c pointer mp_start_draw_cmd (MP mp,quarterword sep) {
23431 pointer lhv; /* variable to add to left */
23432 quarterword add_type=0; /* value to be returned in |last_add_type| */
23434 mp_get_x_next(mp); mp->var_flag=sep; mp_scan_primary(mp);
23435 if ( mp->cur_type!=mp_token_list ) {
23436 @<Abandon edges command because there's no variable@>;
23438 lhv=mp->cur_exp; add_type=mp->cur_mod;
23439 mp->cur_type=mp_vacuous; mp_get_x_next(mp); mp_scan_expression(mp);
23441 mp->last_add_type=add_type;
23445 @ @<Abandon edges command because there's no variable@>=
23446 { exp_err("Not a suitable variable");
23447 @.Not a suitable variable@>
23448 help4("At this point I needed to see the name of a picture variable.")
23449 ("(Or perhaps you have indeed presented me with one; I might")
23450 ("have missed it, if it wasn't followed by the proper token.)")
23451 ("So I'll not change anything just now.");
23452 mp_put_get_flush_error(mp, 0);
23455 @ Here is an example of how to use |start_draw_cmd|.
23457 @<Declare action procedures for use by |do_statement|@>=
23458 void mp_do_bounds (MP mp) ;
23460 @ @c void mp_do_bounds (MP mp) {
23461 pointer lhv,lhe; /* variable on left, the corresponding edge structure */
23462 pointer p; /* for list manipulation */
23463 integer m; /* initial value of |cur_mod| */
23465 lhv=mp_start_draw_cmd(mp, to_token);
23467 lhe=mp_find_edges_var(mp, lhv);
23469 mp_flush_cur_exp(mp, 0);
23470 } else if ( mp->cur_type!=mp_path_type ) {
23471 exp_err("Improper `clip'");
23472 @.Improper `addto'@>
23473 help2("This expression should have specified a known path.")
23474 ("So I'll not change anything just now.");
23475 mp_put_get_flush_error(mp, 0);
23476 } else if ( left_type(mp->cur_exp)==mp_endpoint ) {
23477 @<Complain about a non-cycle@>;
23479 @<Make |cur_exp| into a \&{setbounds} or clipping path and add it to |lhe|@>;
23484 @ @<Complain about a non-cycle@>=
23485 { print_err("Not a cycle");
23487 help2("That contour should have ended with `..cycle' or `&cycle'.")
23488 ("So I'll not change anything just now."); mp_put_get_error(mp);
23491 @ @<Make |cur_exp| into a \&{setbounds} or clipping path and add...@>=
23492 { p=mp_new_bounds_node(mp, mp->cur_exp,m);
23493 link(p)=link(dummy_loc(lhe));
23494 link(dummy_loc(lhe))=p;
23495 if ( obj_tail(lhe)==dummy_loc(lhe) ) obj_tail(lhe)=p;
23496 p=mp_get_node(mp, mp->gr_object_size[stop_type(m)]);
23497 type(p)=stop_type(m);
23498 link(obj_tail(lhe))=p;
23500 mp_init_bbox(mp, lhe);
23503 @ The |do_add_to| procedure is a little like |do_clip| but there are a lot more
23504 cases to deal with.
23506 @<Declare action procedures for use by |do_statement|@>=
23507 void mp_do_add_to (MP mp) ;
23509 @ @c void mp_do_add_to (MP mp) {
23510 pointer lhv,lhe; /* variable on left, the corresponding edge structure */
23511 pointer p; /* the graphical object or list for |scan_with_list| to update */
23512 pointer e; /* an edge structure to be merged */
23513 quarterword add_type; /* |also_code|, |contour_code|, or |double_path_code| */
23514 lhv=mp_start_draw_cmd(mp, thing_to_add); add_type=mp->last_add_type;
23516 if ( add_type==also_code ) {
23517 @<Make sure the current expression is a suitable picture and set |e| and |p|
23520 @<Create a graphical object |p| based on |add_type| and the current
23523 mp_scan_with_list(mp, p);
23524 @<Use |p|, |e|, and |add_type| to augment |lhv| as requested@>;
23528 @ Setting |p:=null| causes the $\langle$with list$\rangle$ to be ignored;
23529 setting |e:=null| prevents anything from being added to |lhe|.
23531 @ @<Make sure the current expression is a suitable picture and set |e|...@>=
23534 if ( mp->cur_type!=mp_picture_type ) {
23535 exp_err("Improper `addto'");
23536 @.Improper `addto'@>
23537 help2("This expression should have specified a known picture.")
23538 ("So I'll not change anything just now."); mp_put_get_flush_error(mp, 0);
23540 e=mp_private_edges(mp, mp->cur_exp); mp->cur_type=mp_vacuous;
23541 p=link(dummy_loc(e));
23545 @ In this case |add_type<>also_code| so setting |p:=null| suppresses future
23546 attempts to add to the edge structure.
23548 @<Create a graphical object |p| based on |add_type| and the current...@>=
23550 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
23551 if ( mp->cur_type!=mp_path_type ) {
23552 exp_err("Improper `addto'");
23553 @.Improper `addto'@>
23554 help2("This expression should have specified a known path.")
23555 ("So I'll not change anything just now.");
23556 mp_put_get_flush_error(mp, 0);
23557 } else if ( add_type==contour_code ) {
23558 if ( left_type(mp->cur_exp)==mp_endpoint ) {
23559 @<Complain about a non-cycle@>;
23561 p=mp_new_fill_node(mp, mp->cur_exp);
23562 mp->cur_type=mp_vacuous;
23565 p=mp_new_stroked_node(mp, mp->cur_exp);
23566 mp->cur_type=mp_vacuous;
23570 @ @<Use |p|, |e|, and |add_type| to augment |lhv| as requested@>=
23571 lhe=mp_find_edges_var(mp, lhv);
23573 if ( (e==null)&&(p!=null) ) e=mp_toss_gr_object(mp, p);
23574 if ( e!=null ) delete_edge_ref(e);
23575 } else if ( add_type==also_code ) {
23577 @<Merge |e| into |lhe| and delete |e|@>;
23581 } else if ( p!=null ) {
23582 link(obj_tail(lhe))=p;
23584 if ( add_type==double_path_code )
23585 if ( pen_p(p)==null )
23586 pen_p(p)=mp_get_pen_circle(mp, 0);
23589 @ @<Merge |e| into |lhe| and delete |e|@>=
23590 { if ( link(dummy_loc(e))!=null ) {
23591 link(obj_tail(lhe))=link(dummy_loc(e));
23592 obj_tail(lhe)=obj_tail(e);
23593 obj_tail(e)=dummy_loc(e);
23594 link(dummy_loc(e))=null;
23595 mp_flush_dash_list(mp, lhe);
23597 mp_toss_edges(mp, e);
23600 @ @<Cases of |do_statement|...@>=
23601 case ship_out_command: mp_do_ship_out(mp); break;
23603 @ @<Declare action procedures for use by |do_statement|@>=
23604 @<Declare the function called |tfm_check|@>
23605 @<Declare the \ps\ output procedures@>
23606 void mp_do_ship_out (MP mp) ;
23608 @ @c void mp_do_ship_out (MP mp) {
23609 integer c; /* the character code */
23610 mp_get_x_next(mp); mp_scan_expression(mp);
23611 if ( mp->cur_type!=mp_picture_type ) {
23612 @<Complain that it's not a known picture@>;
23614 c=mp_round_unscaled(mp, mp->internal[mp_char_code]) % 256;
23615 if ( c<0 ) c=c+256;
23616 @<Store the width information for character code~|c|@>;
23617 mp_ship_out(mp, mp->cur_exp);
23618 mp_flush_cur_exp(mp, 0);
23622 @ @<Complain that it's not a known picture@>=
23624 exp_err("Not a known picture");
23625 help1("I can only output known pictures.");
23626 mp_put_get_flush_error(mp, 0);
23629 @ The \&{everyjob} command simply assigns a nonzero value to the global variable
23632 @<Cases of |do_statement|...@>=
23633 case every_job_command:
23634 mp_get_symbol(mp); mp->start_sym=mp->cur_sym; mp_get_x_next(mp);
23638 halfword start_sym; /* a symbolic token to insert at beginning of job */
23643 @ Finally, we have only the ``message'' commands remaining.
23646 @d err_message_code 1
23648 @d filename_template_code 3
23649 @d print_with_leading_zeroes(A) g = mp->pool_ptr;
23650 mp_print_int(mp, (A)); g = mp->pool_ptr-g;
23652 mp->pool_ptr = mp->pool_ptr - g;
23654 mp_print_char(mp, '0');
23657 mp_print_int(mp, (A));
23662 mp_primitive(mp, "message",message_command,message_code);
23663 @:message_}{\&{message} primitive@>
23664 mp_primitive(mp, "errmessage",message_command,err_message_code);
23665 @:err_message_}{\&{errmessage} primitive@>
23666 mp_primitive(mp, "errhelp",message_command,err_help_code);
23667 @:err_help_}{\&{errhelp} primitive@>
23668 mp_primitive(mp, "filenametemplate",message_command,filename_template_code);
23669 @:filename_template_}{\&{filenametemplate} primitive@>
23671 @ @<Cases of |print_cmd...@>=
23672 case message_command:
23673 if ( m<err_message_code ) mp_print(mp, "message");
23674 else if ( m==err_message_code ) mp_print(mp, "errmessage");
23675 else if ( m==filename_template_code ) mp_print(mp, "filenametemplate");
23676 else mp_print(mp, "errhelp");
23679 @ @<Cases of |do_statement|...@>=
23680 case message_command: mp_do_message(mp); break;
23682 @ @<Declare action procedures for use by |do_statement|@>=
23683 @<Declare a procedure called |no_string_err|@>
23684 void mp_do_message (MP mp) ;
23687 @c void mp_do_message (MP mp) {
23688 int m; /* the type of message */
23689 m=mp->cur_mod; mp_get_x_next(mp); mp_scan_expression(mp);
23690 if ( mp->cur_type!=mp_string_type )
23691 mp_no_string_err(mp, "A message should be a known string expression.");
23695 mp_print_nl(mp, ""); mp_print_str(mp, mp->cur_exp);
23697 case err_message_code:
23698 @<Print string |cur_exp| as an error message@>;
23700 case err_help_code:
23701 @<Save string |cur_exp| as the |err_help|@>;
23703 case filename_template_code:
23704 @<Save the filename template@>;
23706 } /* there are no other cases */
23708 mp_flush_cur_exp(mp, 0);
23711 @ @<Declare a procedure called |no_string_err|@>=
23712 void mp_no_string_err (MP mp, const char *s) {
23713 exp_err("Not a string");
23716 mp_put_get_error(mp);
23719 @ The global variable |err_help| is zero when the user has most recently
23720 given an empty help string, or if none has ever been given.
23722 @<Save string |cur_exp| as the |err_help|@>=
23724 if ( mp->err_help!=0 ) delete_str_ref(mp->err_help);
23725 if ( length(mp->cur_exp)==0 ) mp->err_help=0;
23726 else { mp->err_help=mp->cur_exp; add_str_ref(mp->err_help); }
23729 @ If \&{errmessage} occurs often in |mp_scroll_mode|, without user-defined
23730 \&{errhelp}, we don't want to give a long help message each time. So we
23731 give a verbose explanation only once.
23734 boolean long_help_seen; /* has the long \.{\\errmessage} help been used? */
23736 @ @<Set init...@>=mp->long_help_seen=false;
23738 @ @<Print string |cur_exp| as an error message@>=
23740 print_err(""); mp_print_str(mp, mp->cur_exp);
23741 if ( mp->err_help!=0 ) {
23742 mp->use_err_help=true;
23743 } else if ( mp->long_help_seen ) {
23744 help1("(That was another `errmessage'.)") ;
23746 if ( mp->interaction<mp_error_stop_mode ) mp->long_help_seen=true;
23747 help4("This error message was generated by an `errmessage'")
23748 ("command, so I can\'t give any explicit help.")
23749 ("Pretend that you're Miss Marple: Examine all clues,")
23751 ("and deduce the truth by inspired guesses.");
23753 mp_put_get_error(mp); mp->use_err_help=false;
23756 @ @<Cases of |do_statement|...@>=
23757 case write_command: mp_do_write(mp); break;
23759 @ @<Declare action procedures for use by |do_statement|@>=
23760 void mp_do_write (MP mp) ;
23762 @ @c void mp_do_write (MP mp) {
23763 str_number t; /* the line of text to be written */
23764 write_index n,n0; /* for searching |wr_fname| and |wr_file| arrays */
23765 int old_setting; /* for saving |selector| during output */
23767 mp_scan_expression(mp);
23768 if ( mp->cur_type!=mp_string_type ) {
23769 mp_no_string_err(mp, "The text to be written should be a known string expression");
23770 } else if ( mp->cur_cmd!=to_token ) {
23771 print_err("Missing `to' clause");
23772 help1("A write command should end with `to <filename>'");
23773 mp_put_get_error(mp);
23775 t=mp->cur_exp; mp->cur_type=mp_vacuous;
23777 mp_scan_expression(mp);
23778 if ( mp->cur_type!=mp_string_type )
23779 mp_no_string_err(mp, "I can\'t write to that file name. It isn't a known string");
23781 @<Write |t| to the file named by |cur_exp|@>;
23785 mp_flush_cur_exp(mp, 0);
23788 @ @<Write |t| to the file named by |cur_exp|@>=
23790 @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if
23791 |cur_exp| must be inserted@>;
23792 if ( mp_str_vs_str(mp, t,mp->eof_line)==0 ) {
23793 @<Record the end of file on |wr_file[n]|@>;
23795 old_setting=mp->selector;
23796 mp->selector=n+write_file;
23797 mp_print_str(mp, t); mp_print_ln(mp);
23798 mp->selector = old_setting;
23802 @ @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if...@>=
23804 char *fn = str(mp->cur_exp);
23806 n0=mp->write_files;
23807 while (mp_xstrcmp(fn,mp->wr_fname[n])!=0) {
23808 if ( n==0 ) { /* bottom reached */
23809 if ( n0==mp->write_files ) {
23810 if ( mp->write_files<mp->max_write_files ) {
23811 incr(mp->write_files);
23816 l = mp->max_write_files + (mp->max_write_files>>2);
23817 wr_file = xmalloc((l+1),sizeof(void *));
23818 wr_fname = xmalloc((l+1),sizeof(char *));
23819 for (k=0;k<=l;k++) {
23820 if (k<=mp->max_write_files) {
23821 wr_file[k]=mp->wr_file[k];
23822 wr_fname[k]=mp->wr_fname[k];
23828 xfree(mp->wr_file); xfree(mp->wr_fname);
23829 mp->max_write_files = l;
23830 mp->wr_file = wr_file;
23831 mp->wr_fname = wr_fname;
23835 mp_open_write_file(mp, fn ,n);
23838 if ( mp->wr_fname[n]==NULL ) n0=n;
23843 @ @<Record the end of file on |wr_file[n]|@>=
23844 { (mp->close_file)(mp,mp->wr_file[n]);
23845 xfree(mp->wr_fname[n]);
23846 if ( n==mp->write_files-1 ) mp->write_files=n;
23850 @* \[42] Writing font metric data.
23851 \TeX\ gets its knowledge about fonts from font metric files, also called
23852 \.{TFM} files; the `\.T' in `\.{TFM}' stands for \TeX,
23853 but other programs know about them too. One of \MP's duties is to
23854 write \.{TFM} files so that the user's fonts can readily be
23855 applied to typesetting.
23856 @:TFM files}{\.{TFM} files@>
23857 @^font metric files@>
23859 The information in a \.{TFM} file appears in a sequence of 8-bit bytes.
23860 Since the number of bytes is always a multiple of~4, we could
23861 also regard the file as a sequence of 32-bit words, but \MP\ uses the
23862 byte interpretation. The format of \.{TFM} files was designed by
23863 Lyle Ramshaw in 1980. The intent is to convey a lot of different kinds
23864 @^Ramshaw, Lyle Harold@>
23865 of information in a compact but useful form.
23868 void * tfm_file; /* the font metric output goes here */
23869 char * metric_file_name; /* full name of the font metric file */
23871 @ The first 24 bytes (6 words) of a \.{TFM} file contain twelve 16-bit
23872 integers that give the lengths of the various subsequent portions
23873 of the file. These twelve integers are, in order:
23874 $$\vbox{\halign{\hfil#&$\null=\null$#\hfil\cr
23875 |lf|&length of the entire file, in words;\cr
23876 |lh|&length of the header data, in words;\cr
23877 |bc|&smallest character code in the font;\cr
23878 |ec|&largest character code in the font;\cr
23879 |nw|&number of words in the width table;\cr
23880 |nh|&number of words in the height table;\cr
23881 |nd|&number of words in the depth table;\cr
23882 |ni|&number of words in the italic correction table;\cr
23883 |nl|&number of words in the lig/kern table;\cr
23884 |nk|&number of words in the kern table;\cr
23885 |ne|&number of words in the extensible character table;\cr
23886 |np|&number of font parameter words.\cr}}$$
23887 They are all nonnegative and less than $2^{15}$. We must have |bc-1<=ec<=255|,
23889 $$\hbox{|lf=6+lh+(ec-bc+1)+nw+nh+nd+ni+nl+nk+ne+np|.}$$
23890 Note that a font may contain as many as 256 characters (if |bc=0| and |ec=255|),
23891 and as few as 0 characters (if |bc=ec+1|).
23893 Incidentally, when two or more 8-bit bytes are combined to form an integer of
23894 16 or more bits, the most significant bytes appear first in the file.
23895 This is called BigEndian order.
23896 @^BigEndian order@>
23898 @ The rest of the \.{TFM} file may be regarded as a sequence of ten data
23901 The most important data type used here is a |fix_word|, which is
23902 a 32-bit representation of a binary fraction. A |fix_word| is a signed
23903 quantity, with the two's complement of the entire word used to represent
23904 negation. Of the 32 bits in a |fix_word|, exactly 12 are to the left of the
23905 binary point; thus, the largest |fix_word| value is $2048-2^{-20}$, and
23906 the smallest is $-2048$. We will see below, however, that all but two of
23907 the |fix_word| values must lie between $-16$ and $+16$.
23909 @ The first data array is a block of header information, which contains
23910 general facts about the font. The header must contain at least two words,
23911 |header[0]| and |header[1]|, whose meaning is explained below. Additional
23912 header information of use to other software routines might also be
23913 included, and \MP\ will generate it if the \.{headerbyte} command occurs.
23914 For example, 16 more words of header information are in use at the Xerox
23915 Palo Alto Research Center; the first ten specify the character coding
23916 scheme used (e.g., `\.{XEROX TEXT}' or `\.{TEX MATHSY}'), the next five
23917 give the font family name (e.g., `\.{HELVETICA}' or `\.{CMSY}'), and the
23918 last gives the ``face byte.''
23920 \yskip\hang|header[0]| is a 32-bit check sum that \MP\ will copy into
23921 the \.{GF} output file. This helps ensure consistency between files,
23922 since \TeX\ records the check sums from the \.{TFM}'s it reads, and these
23923 should match the check sums on actual fonts that are used. The actual
23924 relation between this check sum and the rest of the \.{TFM} file is not
23925 important; the check sum is simply an identification number with the
23926 property that incompatible fonts almost always have distinct check sums.
23929 \yskip\hang|header[1]| is a |fix_word| containing the design size of the
23930 font, in units of \TeX\ points. This number must be at least 1.0; it is
23931 fairly arbitrary, but usually the design size is 10.0 for a ``10 point''
23932 font, i.e., a font that was designed to look best at a 10-point size,
23933 whatever that really means. When a \TeX\ user asks for a font `\.{at}
23934 $\delta$ \.{pt}', the effect is to override the design size and replace it
23935 by $\delta$, and to multiply the $x$ and~$y$ coordinates of the points in
23936 the font image by a factor of $\delta$ divided by the design size. {\sl
23937 All other dimensions in the\/ \.{TFM} file are |fix_word|\kern-1pt\
23938 numbers in design-size units.} Thus, for example, the value of |param[6]|,
23939 which defines the \.{em} unit, is often the |fix_word| value $2^{20}=1.0$,
23940 since many fonts have a design size equal to one em. The other dimensions
23941 must be less than 16 design-size units in absolute value; thus,
23942 |header[1]| and |param[1]| are the only |fix_word| entries in the whole
23943 \.{TFM} file whose first byte might be something besides 0 or 255.
23946 @ Next comes the |char_info| array, which contains one |char_info_word|
23947 per character. Each word in this part of the file contains six fields
23948 packed into four bytes as follows.
23950 \yskip\hang first byte: |width_index| (8 bits)\par
23951 \hang second byte: |height_index| (4 bits) times 16, plus |depth_index|
23953 \hang third byte: |italic_index| (6 bits) times 4, plus |tag|
23955 \hang fourth byte: |remainder| (8 bits)\par
23957 The actual width of a character is \\{width}|[width_index]|, in design-size
23958 units; this is a device for compressing information, since many characters
23959 have the same width. Since it is quite common for many characters
23960 to have the same height, depth, or italic correction, the \.{TFM} format
23961 imposes a limit of 16 different heights, 16 different depths, and
23962 64 different italic corrections.
23964 Incidentally, the relation $\\{width}[0]=\\{height}[0]=\\{depth}[0]=
23965 \\{italic}[0]=0$ should always hold, so that an index of zero implies a
23966 value of zero. The |width_index| should never be zero unless the
23967 character does not exist in the font, since a character is valid if and
23968 only if it lies between |bc| and |ec| and has a nonzero |width_index|.
23970 @ The |tag| field in a |char_info_word| has four values that explain how to
23971 interpret the |remainder| field.
23973 \yskip\hang|tag=0| (|no_tag|) means that |remainder| is unused.\par
23974 \hang|tag=1| (|lig_tag|) means that this character has a ligature/kerning
23975 program starting at location |remainder| in the |lig_kern| array.\par
23976 \hang|tag=2| (|list_tag|) means that this character is part of a chain of
23977 characters of ascending sizes, and not the largest in the chain. The
23978 |remainder| field gives the character code of the next larger character.\par
23979 \hang|tag=3| (|ext_tag|) means that this character code represents an
23980 extensible character, i.e., a character that is built up of smaller pieces
23981 so that it can be made arbitrarily large. The pieces are specified in
23982 |exten[remainder]|.\par
23984 Characters with |tag=2| and |tag=3| are treated as characters with |tag=0|
23985 unless they are used in special circumstances in math formulas. For example,
23986 \TeX's \.{\\sum} operation looks for a |list_tag|, and the \.{\\left}
23987 operation looks for both |list_tag| and |ext_tag|.
23989 @d no_tag 0 /* vanilla character */
23990 @d lig_tag 1 /* character has a ligature/kerning program */
23991 @d list_tag 2 /* character has a successor in a charlist */
23992 @d ext_tag 3 /* character is extensible */
23994 @ The |lig_kern| array contains instructions in a simple programming language
23995 that explains what to do for special letter pairs. Each word in this array is a
23996 |lig_kern_command| of four bytes.
23998 \yskip\hang first byte: |skip_byte|, indicates that this is the final program
23999 step if the byte is 128 or more, otherwise the next step is obtained by
24000 skipping this number of intervening steps.\par
24001 \hang second byte: |next_char|, ``if |next_char| follows the current character,
24002 then perform the operation and stop, otherwise continue.''\par
24003 \hang third byte: |op_byte|, indicates a ligature step if less than~128,
24004 a kern step otherwise.\par
24005 \hang fourth byte: |remainder|.\par
24008 additional space equal to |kern[256*(op_byte-128)+remainder]| is inserted
24009 between the current character and |next_char|. This amount is
24010 often negative, so that the characters are brought closer together
24011 by kerning; but it might be positive.
24013 There are eight kinds of ligature steps, having |op_byte| codes $4a+2b+c$ where
24014 $0\le a\le b+c$ and $0\le b,c\le1$. The character whose code is
24015 |remainder| is inserted between the current character and |next_char|;
24016 then the current character is deleted if $b=0$, and |next_char| is
24017 deleted if $c=0$; then we pass over $a$~characters to reach the next
24018 current character (which may have a ligature/kerning program of its own).
24020 If the very first instruction of the |lig_kern| array has |skip_byte=255|,
24021 the |next_char| byte is the so-called right boundary character of this font;
24022 the value of |next_char| need not lie between |bc| and~|ec|.
24023 If the very last instruction of the |lig_kern| array has |skip_byte=255|,
24024 there is a special ligature/kerning program for a left boundary character,
24025 beginning at location |256*op_byte+remainder|.
24026 The interpretation is that \TeX\ puts implicit boundary characters
24027 before and after each consecutive string of characters from the same font.
24028 These implicit characters do not appear in the output, but they can affect
24029 ligatures and kerning.
24031 If the very first instruction of a character's |lig_kern| program has
24032 |skip_byte>128|, the program actually begins in location
24033 |256*op_byte+remainder|. This feature allows access to large |lig_kern|
24034 arrays, because the first instruction must otherwise
24035 appear in a location |<=255|.
24037 Any instruction with |skip_byte>128| in the |lig_kern| array must satisfy
24039 $$\hbox{|256*op_byte+remainder<nl|.}$$
24040 If such an instruction is encountered during
24041 normal program execution, it denotes an unconditional halt; no ligature
24042 command is performed.
24045 /* value indicating `\.{STOP}' in a lig/kern program */
24046 @d kern_flag (128) /* op code for a kern step */
24047 @d skip_byte(A) mp->lig_kern[(A)].b0
24048 @d next_char(A) mp->lig_kern[(A)].b1
24049 @d op_byte(A) mp->lig_kern[(A)].b2
24050 @d rem_byte(A) mp->lig_kern[(A)].b3
24052 @ Extensible characters are specified by an |extensible_recipe|, which
24053 consists of four bytes called |top|, |mid|, |bot|, and |rep| (in this
24054 order). These bytes are the character codes of individual pieces used to
24055 build up a large symbol. If |top|, |mid|, or |bot| are zero, they are not
24056 present in the built-up result. For example, an extensible vertical line is
24057 like an extensible bracket, except that the top and bottom pieces are missing.
24059 Let $T$, $M$, $B$, and $R$ denote the respective pieces, or an empty box
24060 if the piece isn't present. Then the extensible characters have the form
24061 $TR^kMR^kB$ from top to bottom, for some |k>=0|, unless $M$ is absent;
24062 in the latter case we can have $TR^kB$ for both even and odd values of~|k|.
24063 The width of the extensible character is the width of $R$; and the
24064 height-plus-depth is the sum of the individual height-plus-depths of the
24065 components used, since the pieces are butted together in a vertical list.
24067 @d ext_top(A) mp->exten[(A)].b0 /* |top| piece in a recipe */
24068 @d ext_mid(A) mp->exten[(A)].b1 /* |mid| piece in a recipe */
24069 @d ext_bot(A) mp->exten[(A)].b2 /* |bot| piece in a recipe */
24070 @d ext_rep(A) mp->exten[(A)].b3 /* |rep| piece in a recipe */
24072 @ The final portion of a \.{TFM} file is the |param| array, which is another
24073 sequence of |fix_word| values.
24075 \yskip\hang|param[1]=slant| is the amount of italic slant, which is used
24076 to help position accents. For example, |slant=.25| means that when you go
24077 up one unit, you also go .25 units to the right. The |slant| is a pure
24078 number; it is the only |fix_word| other than the design size itself that is
24079 not scaled by the design size.
24082 \hang|param[2]=space| is the normal spacing between words in text.
24083 Note that character 040 in the font need not have anything to do with
24086 \hang|param[3]=space_stretch| is the amount of glue stretching between words.
24088 \hang|param[4]=space_shrink| is the amount of glue shrinking between words.
24090 \hang|param[5]=x_height| is the size of one ex in the font; it is also
24091 the height of letters for which accents don't have to be raised or lowered.
24093 \hang|param[6]=quad| is the size of one em in the font.
24095 \hang|param[7]=extra_space| is the amount added to |param[2]| at the
24099 If fewer than seven parameters are present, \TeX\ sets the missing parameters
24104 @d space_stretch_code 3
24105 @d space_shrink_code 4
24108 @d extra_space_code 7
24110 @ So that is what \.{TFM} files hold. One of \MP's duties is to output such
24111 information, and it does this all at once at the end of a job.
24112 In order to prepare for such frenetic activity, it squirrels away the
24113 necessary facts in various arrays as information becomes available.
24115 Character dimensions (\&{charwd}, \&{charht}, \&{chardp}, and \&{charic})
24116 are stored respectively in |tfm_width|, |tfm_height|, |tfm_depth|, and
24117 |tfm_ital_corr|. Other information about a character (e.g., about
24118 its ligatures or successors) is accessible via the |char_tag| and
24119 |char_remainder| arrays. Other information about the font as a whole
24120 is kept in additional arrays called |header_byte|, |lig_kern|,
24121 |kern|, |exten|, and |param|.
24123 @d max_tfm_int 32510
24124 @d undefined_label max_tfm_int /* an undefined local label */
24127 #define TFM_ITEMS 257
24129 eight_bits ec; /* smallest and largest character codes shipped out */
24130 scaled tfm_width[TFM_ITEMS]; /* \&{charwd} values */
24131 scaled tfm_height[TFM_ITEMS]; /* \&{charht} values */
24132 scaled tfm_depth[TFM_ITEMS]; /* \&{chardp} values */
24133 scaled tfm_ital_corr[TFM_ITEMS]; /* \&{charic} values */
24134 boolean char_exists[TFM_ITEMS]; /* has this code been shipped out? */
24135 int char_tag[TFM_ITEMS]; /* |remainder| category */
24136 int char_remainder[TFM_ITEMS]; /* the |remainder| byte */
24137 char *header_byte; /* bytes of the \.{TFM} header */
24138 int header_last; /* last initialized \.{TFM} header byte */
24139 int header_size; /* size of the \.{TFM} header */
24140 four_quarters *lig_kern; /* the ligature/kern table */
24141 short nl; /* the number of ligature/kern steps so far */
24142 scaled *kern; /* distinct kerning amounts */
24143 short nk; /* the number of distinct kerns so far */
24144 four_quarters exten[TFM_ITEMS]; /* extensible character recipes */
24145 short ne; /* the number of extensible characters so far */
24146 scaled *param; /* \&{fontinfo} parameters */
24147 short np; /* the largest \&{fontinfo} parameter specified so far */
24148 short nw;short nh;short nd;short ni; /* sizes of \.{TFM} subtables */
24149 short skip_table[TFM_ITEMS]; /* local label status */
24150 boolean lk_started; /* has there been a lig/kern step in this command yet? */
24151 integer bchar; /* right boundary character */
24152 short bch_label; /* left boundary starting location */
24153 short ll;short lll; /* registers used for lig/kern processing */
24154 short label_loc[257]; /* lig/kern starting addresses */
24155 eight_bits label_char[257]; /* characters for |label_loc| */
24156 short label_ptr; /* highest position occupied in |label_loc| */
24158 @ @<Allocate or initialize ...@>=
24159 mp->header_last = 0; mp->header_size = 128; /* just for init */
24160 mp->header_byte = xmalloc(mp->header_size, sizeof(char));
24161 mp->lig_kern = NULL; /* allocated when needed */
24162 mp->kern = NULL; /* allocated when needed */
24163 mp->param = NULL; /* allocated when needed */
24165 @ @<Dealloc variables@>=
24166 xfree(mp->header_byte);
24167 xfree(mp->lig_kern);
24172 for (k=0;k<= 255;k++ ) {
24173 mp->tfm_width[k]=0; mp->tfm_height[k]=0; mp->tfm_depth[k]=0; mp->tfm_ital_corr[k]=0;
24174 mp->char_exists[k]=false; mp->char_tag[k]=no_tag; mp->char_remainder[k]=0;
24175 mp->skip_table[k]=undefined_label;
24177 memset(mp->header_byte,0,mp->header_size);
24178 mp->bc=255; mp->ec=0; mp->nl=0; mp->nk=0; mp->ne=0; mp->np=0;
24179 mp->internal[mp_boundary_char]=-unity;
24180 mp->bch_label=undefined_label;
24181 mp->label_loc[0]=-1; mp->label_ptr=0;
24183 @ @<Declarations@>=
24184 scaled mp_tfm_check (MP mp,small_number m) ;
24186 @ @<Declare the function called |tfm_check|@>=
24187 scaled mp_tfm_check (MP mp,small_number m) {
24188 if ( abs(mp->internal[m])>=fraction_half ) {
24189 print_err("Enormous "); mp_print(mp, mp->int_name[m]);
24190 @.Enormous charwd...@>
24191 @.Enormous chardp...@>
24192 @.Enormous charht...@>
24193 @.Enormous charic...@>
24194 @.Enormous designsize...@>
24195 mp_print(mp, " has been reduced");
24196 help1("Font metric dimensions must be less than 2048pt.");
24197 mp_put_get_error(mp);
24198 if ( mp->internal[m]>0 ) return (fraction_half-1);
24199 else return (1-fraction_half);
24201 return mp->internal[m];
24205 @ @<Store the width information for character code~|c|@>=
24206 if ( c<mp->bc ) mp->bc=c;
24207 if ( c>mp->ec ) mp->ec=c;
24208 mp->char_exists[c]=true;
24209 mp->tfm_width[c]=mp_tfm_check(mp, mp_char_wd);
24210 mp->tfm_height[c]=mp_tfm_check(mp, mp_char_ht);
24211 mp->tfm_depth[c]=mp_tfm_check(mp, mp_char_dp);
24212 mp->tfm_ital_corr[c]=mp_tfm_check(mp, mp_char_ic)
24214 @ Now let's consider \MP's special \.{TFM}-oriented commands.
24216 @<Cases of |do_statement|...@>=
24217 case tfm_command: mp_do_tfm_command(mp); break;
24219 @ @d char_list_code 0
24220 @d lig_table_code 1
24221 @d extensible_code 2
24222 @d header_byte_code 3
24223 @d font_dimen_code 4
24226 mp_primitive(mp, "charlist",tfm_command,char_list_code);
24227 @:char_list_}{\&{charlist} primitive@>
24228 mp_primitive(mp, "ligtable",tfm_command,lig_table_code);
24229 @:lig_table_}{\&{ligtable} primitive@>
24230 mp_primitive(mp, "extensible",tfm_command,extensible_code);
24231 @:extensible_}{\&{extensible} primitive@>
24232 mp_primitive(mp, "headerbyte",tfm_command,header_byte_code);
24233 @:header_byte_}{\&{headerbyte} primitive@>
24234 mp_primitive(mp, "fontdimen",tfm_command,font_dimen_code);
24235 @:font_dimen_}{\&{fontdimen} primitive@>
24237 @ @<Cases of |print_cmd...@>=
24240 case char_list_code:mp_print(mp, "charlist"); break;
24241 case lig_table_code:mp_print(mp, "ligtable"); break;
24242 case extensible_code:mp_print(mp, "extensible"); break;
24243 case header_byte_code:mp_print(mp, "headerbyte"); break;
24244 default: mp_print(mp, "fontdimen"); break;
24248 @ @<Declare action procedures for use by |do_statement|@>=
24249 eight_bits mp_get_code (MP mp) ;
24251 @ @c eight_bits mp_get_code (MP mp) { /* scans a character code value */
24252 integer c; /* the code value found */
24253 mp_get_x_next(mp); mp_scan_expression(mp);
24254 if ( mp->cur_type==mp_known ) {
24255 c=mp_round_unscaled(mp, mp->cur_exp);
24256 if ( c>=0 ) if ( c<256 ) return c;
24257 } else if ( mp->cur_type==mp_string_type ) {
24258 if ( length(mp->cur_exp)==1 ) {
24259 c=mp->str_pool[mp->str_start[mp->cur_exp]];
24263 exp_err("Invalid code has been replaced by 0");
24264 @.Invalid code...@>
24265 help2("I was looking for a number between 0 and 255, or for a")
24266 ("string of length 1. Didn't find it; will use 0 instead.");
24267 mp_put_get_flush_error(mp, 0); c=0;
24271 @ @<Declare action procedures for use by |do_statement|@>=
24272 void mp_set_tag (MP mp,halfword c, small_number t, halfword r) ;
24274 @ @c void mp_set_tag (MP mp,halfword c, small_number t, halfword r) {
24275 if ( mp->char_tag[c]==no_tag ) {
24276 mp->char_tag[c]=t; mp->char_remainder[c]=r;
24278 incr(mp->label_ptr); mp->label_loc[mp->label_ptr]=r;
24279 mp->label_char[mp->label_ptr]=c;
24282 @<Complain about a character tag conflict@>;
24286 @ @<Complain about a character tag conflict@>=
24288 print_err("Character ");
24289 if ( (c>' ')&&(c<127) ) mp_print_char(mp,c);
24290 else if ( c==256 ) mp_print(mp, "||");
24291 else { mp_print(mp, "code "); mp_print_int(mp, c); };
24292 mp_print(mp, " is already ");
24293 @.Character c is already...@>
24294 switch (mp->char_tag[c]) {
24295 case lig_tag: mp_print(mp, "in a ligtable"); break;
24296 case list_tag: mp_print(mp, "in a charlist"); break;
24297 case ext_tag: mp_print(mp, "extensible"); break;
24298 } /* there are no other cases */
24299 help2("It's not legal to label a character more than once.")
24300 ("So I'll not change anything just now.");
24301 mp_put_get_error(mp);
24304 @ @<Declare action procedures for use by |do_statement|@>=
24305 void mp_do_tfm_command (MP mp) ;
24307 @ @c void mp_do_tfm_command (MP mp) {
24308 int c,cc; /* character codes */
24309 int k; /* index into the |kern| array */
24310 int j; /* index into |header_byte| or |param| */
24311 switch (mp->cur_mod) {
24312 case char_list_code:
24314 /* we will store a list of character successors */
24315 while ( mp->cur_cmd==colon ) {
24316 cc=mp_get_code(mp); mp_set_tag(mp, c,list_tag,cc); c=cc;
24319 case lig_table_code:
24320 if (mp->lig_kern==NULL)
24321 mp->lig_kern = xmalloc((max_tfm_int+1),sizeof(four_quarters));
24322 if (mp->kern==NULL)
24323 mp->kern = xmalloc((max_tfm_int+1),sizeof(scaled));
24324 @<Store a list of ligature/kern steps@>;
24326 case extensible_code:
24327 @<Define an extensible recipe@>;
24329 case header_byte_code:
24330 case font_dimen_code:
24331 c=mp->cur_mod; mp_get_x_next(mp);
24332 mp_scan_expression(mp);
24333 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<half_unit) ) {
24334 exp_err("Improper location");
24335 @.Improper location@>
24336 help2("I was looking for a known, positive number.")
24337 ("For safety's sake I'll ignore the present command.");
24338 mp_put_get_error(mp);
24340 j=mp_round_unscaled(mp, mp->cur_exp);
24341 if ( mp->cur_cmd!=colon ) {
24342 mp_missing_err(mp, ":");
24344 help1("A colon should follow a headerbyte or fontinfo location.");
24347 if ( c==header_byte_code ) {
24348 @<Store a list of header bytes@>;
24350 if (mp->param==NULL)
24351 mp->param = xmalloc((max_tfm_int+1),sizeof(scaled));
24352 @<Store a list of font dimensions@>;
24356 } /* there are no other cases */
24359 @ @<Store a list of ligature/kern steps@>=
24361 mp->lk_started=false;
24364 if ((mp->cur_cmd==skip_to)&& mp->lk_started )
24365 @<Process a |skip_to| command and |goto done|@>;
24366 if ( mp->cur_cmd==bchar_label ) { c=256; mp->cur_cmd=colon; }
24367 else { mp_back_input(mp); c=mp_get_code(mp); };
24368 if ((mp->cur_cmd==colon)||(mp->cur_cmd==double_colon)) {
24369 @<Record a label in a lig/kern subprogram and |goto continue|@>;
24371 if ( mp->cur_cmd==lig_kern_token ) {
24372 @<Compile a ligature/kern command@>;
24374 print_err("Illegal ligtable step");
24375 @.Illegal ligtable step@>
24376 help1("I was looking for `=:' or `kern' here.");
24377 mp_back_error(mp); next_char(mp->nl)=qi(0);
24378 op_byte(mp->nl)=qi(0); rem_byte(mp->nl)=qi(0);
24379 skip_byte(mp->nl)=stop_flag+1; /* this specifies an unconditional stop */
24381 if ( mp->nl==max_tfm_int) mp_fatal_error(mp, "ligtable too large");
24383 if ( mp->cur_cmd==comma ) goto CONTINUE;
24384 if ( skip_byte(mp->nl-1)<stop_flag ) skip_byte(mp->nl-1)=stop_flag;
24389 mp_primitive(mp, "=:",lig_kern_token,0);
24390 @:=:_}{\.{=:} primitive@>
24391 mp_primitive(mp, "=:|",lig_kern_token,1);
24392 @:=:/_}{\.{=:\char'174} primitive@>
24393 mp_primitive(mp, "=:|>",lig_kern_token,5);
24394 @:=:/>_}{\.{=:\char'174>} primitive@>
24395 mp_primitive(mp, "|=:",lig_kern_token,2);
24396 @:=:/_}{\.{\char'174=:} primitive@>
24397 mp_primitive(mp, "|=:>",lig_kern_token,6);
24398 @:=:/>_}{\.{\char'174=:>} primitive@>
24399 mp_primitive(mp, "|=:|",lig_kern_token,3);
24400 @:=:/_}{\.{\char'174=:\char'174} primitive@>
24401 mp_primitive(mp, "|=:|>",lig_kern_token,7);
24402 @:=:/>_}{\.{\char'174=:\char'174>} primitive@>
24403 mp_primitive(mp, "|=:|>>",lig_kern_token,11);
24404 @:=:/>_}{\.{\char'174=:\char'174>>} primitive@>
24405 mp_primitive(mp, "kern",lig_kern_token,128);
24406 @:kern_}{\&{kern} primitive@>
24408 @ @<Cases of |print_cmd...@>=
24409 case lig_kern_token:
24411 case 0:mp_print(mp, "=:"); break;
24412 case 1:mp_print(mp, "=:|"); break;
24413 case 2:mp_print(mp, "|=:"); break;
24414 case 3:mp_print(mp, "|=:|"); break;
24415 case 5:mp_print(mp, "=:|>"); break;
24416 case 6:mp_print(mp, "|=:>"); break;
24417 case 7:mp_print(mp, "|=:|>"); break;
24418 case 11:mp_print(mp, "|=:|>>"); break;
24419 default: mp_print(mp, "kern"); break;
24423 @ Local labels are implemented by maintaining the |skip_table| array,
24424 where |skip_table[c]| is either |undefined_label| or the address of the
24425 most recent lig/kern instruction that skips to local label~|c|. In the
24426 latter case, the |skip_byte| in that instruction will (temporarily)
24427 be zero if there were no prior skips to this label, or it will be the
24428 distance to the prior skip.
24430 We may need to cancel skips that span more than 127 lig/kern steps.
24432 @d cancel_skips(A) mp->ll=(A);
24434 mp->lll=qo(skip_byte(mp->ll));
24435 skip_byte(mp->ll)=stop_flag; mp->ll=mp->ll-mp->lll;
24436 } while (mp->lll!=0)
24437 @d skip_error(A) { print_err("Too far to skip");
24438 @.Too far to skip@>
24439 help1("At most 127 lig/kern steps can separate skipto1 from 1::.");
24440 mp_error(mp); cancel_skips((A));
24443 @<Process a |skip_to| command and |goto done|@>=
24446 if ( mp->nl-mp->skip_table[c]>128 ) {
24447 skip_error(mp->skip_table[c]); mp->skip_table[c]=undefined_label;
24449 if ( mp->skip_table[c]==undefined_label ) skip_byte(mp->nl-1)=qi(0);
24450 else skip_byte(mp->nl-1)=qi(mp->nl-mp->skip_table[c]-1);
24451 mp->skip_table[c]=mp->nl-1; goto DONE;
24454 @ @<Record a label in a lig/kern subprogram and |goto continue|@>=
24456 if ( mp->cur_cmd==colon ) {
24457 if ( c==256 ) mp->bch_label=mp->nl;
24458 else mp_set_tag(mp, c,lig_tag,mp->nl);
24459 } else if ( mp->skip_table[c]<undefined_label ) {
24460 mp->ll=mp->skip_table[c]; mp->skip_table[c]=undefined_label;
24462 mp->lll=qo(skip_byte(mp->ll));
24463 if ( mp->nl-mp->ll>128 ) {
24464 skip_error(mp->ll); goto CONTINUE;
24466 skip_byte(mp->ll)=qi(mp->nl-mp->ll-1); mp->ll=mp->ll-mp->lll;
24467 } while (mp->lll!=0);
24472 @ @<Compile a ligature/kern...@>=
24474 next_char(mp->nl)=qi(c); skip_byte(mp->nl)=qi(0);
24475 if ( mp->cur_mod<128 ) { /* ligature op */
24476 op_byte(mp->nl)=qi(mp->cur_mod); rem_byte(mp->nl)=qi(mp_get_code(mp));
24478 mp_get_x_next(mp); mp_scan_expression(mp);
24479 if ( mp->cur_type!=mp_known ) {
24480 exp_err("Improper kern");
24482 help2("The amount of kern should be a known numeric value.")
24483 ("I'm zeroing this one. Proceed, with fingers crossed.");
24484 mp_put_get_flush_error(mp, 0);
24486 mp->kern[mp->nk]=mp->cur_exp;
24488 while ( mp->kern[k]!=mp->cur_exp ) incr(k);
24490 if ( mp->nk==max_tfm_int ) mp_fatal_error(mp, "too many TFM kerns");
24493 op_byte(mp->nl)=kern_flag+(k / 256);
24494 rem_byte(mp->nl)=qi((k % 256));
24496 mp->lk_started=true;
24499 @ @d missing_extensible_punctuation(A)
24500 { mp_missing_err(mp, (A));
24501 @.Missing `\char`\#'@>
24502 help1("I'm processing `extensible c: t,m,b,r'."); mp_back_error(mp);
24505 @<Define an extensible recipe@>=
24507 if ( mp->ne==256 ) mp_fatal_error(mp, "too many extensible recipies");
24508 c=mp_get_code(mp); mp_set_tag(mp, c,ext_tag,mp->ne);
24509 if ( mp->cur_cmd!=colon ) missing_extensible_punctuation(":");
24510 ext_top(mp->ne)=qi(mp_get_code(mp));
24511 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
24512 ext_mid(mp->ne)=qi(mp_get_code(mp));
24513 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
24514 ext_bot(mp->ne)=qi(mp_get_code(mp));
24515 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
24516 ext_rep(mp->ne)=qi(mp_get_code(mp));
24520 @ The header could contain ASCII zeroes, so can't use |strdup|.
24522 @<Store a list of header bytes@>=
24524 if ( j>=mp->header_size ) {
24525 int l = mp->header_size + (mp->header_size >> 2);
24526 char *t = xmalloc(l,sizeof(char));
24528 memcpy(t,mp->header_byte,mp->header_size);
24529 xfree (mp->header_byte);
24530 mp->header_byte = t;
24531 mp->header_size = l;
24533 mp->header_byte[j]=mp_get_code(mp);
24534 incr(j); incr(mp->header_last);
24535 } while (mp->cur_cmd==comma)
24537 @ @<Store a list of font dimensions@>=
24539 if ( j>max_tfm_int ) mp_fatal_error(mp, "too many fontdimens");
24540 while ( j>mp->np ) { incr(mp->np); mp->param[mp->np]=0; };
24541 mp_get_x_next(mp); mp_scan_expression(mp);
24542 if ( mp->cur_type!=mp_known ){
24543 exp_err("Improper font parameter");
24544 @.Improper font parameter@>
24545 help1("I'm zeroing this one. Proceed, with fingers crossed.");
24546 mp_put_get_flush_error(mp, 0);
24548 mp->param[j]=mp->cur_exp; incr(j);
24549 } while (mp->cur_cmd==comma)
24551 @ OK: We've stored all the data that is needed for the \.{TFM} file.
24552 All that remains is to output it in the correct format.
24554 An interesting problem needs to be solved in this connection, because
24555 the \.{TFM} format allows at most 256~widths, 16~heights, 16~depths,
24556 and 64~italic corrections. If the data has more distinct values than
24557 this, we want to meet the necessary restrictions by perturbing the
24558 given values as little as possible.
24560 \MP\ solves this problem in two steps. First the values of a given
24561 kind (widths, heights, depths, or italic corrections) are sorted;
24562 then the list of sorted values is perturbed, if necessary.
24564 The sorting operation is facilitated by having a special node of
24565 essentially infinite |value| at the end of the current list.
24567 @<Initialize table entries...@>=
24568 value(inf_val)=fraction_four;
24570 @ Straight linear insertion is good enough for sorting, since the lists
24571 are usually not terribly long. As we work on the data, the current list
24572 will start at |link(temp_head)| and end at |inf_val|; the nodes in this
24573 list will be in increasing order of their |value| fields.
24575 Given such a list, the |sort_in| function takes a value and returns a pointer
24576 to where that value can be found in the list. The value is inserted in
24577 the proper place, if necessary.
24579 At the time we need to do these operations, most of \MP's work has been
24580 completed, so we will have plenty of memory to play with. The value nodes
24581 that are allocated for sorting will never be returned to free storage.
24583 @d clear_the_list link(temp_head)=inf_val
24585 @c pointer mp_sort_in (MP mp,scaled v) {
24586 pointer p,q,r; /* list manipulation registers */
24590 if ( v<=value(q) ) break;
24593 if ( v<value(q) ) {
24594 r=mp_get_node(mp, value_node_size); value(r)=v; link(r)=q; link(p)=r;
24599 @ Now we come to the interesting part, where we reduce the list if necessary
24600 until it has the required size. The |min_cover| routine is basic to this
24601 process; it computes the minimum number~|m| such that the values of the
24602 current sorted list can be covered by |m|~intervals of width~|d|. It
24603 also sets the global value |perturbation| to the smallest value $d'>d$
24604 such that the covering found by this algorithm would be different.
24606 In particular, |min_cover(0)| returns the number of distinct values in the
24607 current list and sets |perturbation| to the minimum distance between
24610 @c integer mp_min_cover (MP mp,scaled d) {
24611 pointer p; /* runs through the current list */
24612 scaled l; /* the least element covered by the current interval */
24613 integer m; /* lower bound on the size of the minimum cover */
24614 m=0; p=link(temp_head); mp->perturbation=el_gordo;
24615 while ( p!=inf_val ){
24616 incr(m); l=value(p);
24617 do { p=link(p); } while (value(p)<=l+d);
24618 if ( value(p)-l<mp->perturbation )
24619 mp->perturbation=value(p)-l;
24625 scaled perturbation; /* quantity related to \.{TFM} rounding */
24626 integer excess; /* the list is this much too long */
24628 @ The smallest |d| such that a given list can be covered with |m| intervals
24629 is determined by the |threshold| routine, which is sort of an inverse
24630 to |min_cover|. The idea is to increase the interval size rapidly until
24631 finding the range, then to go sequentially until the exact borderline has
24634 @c scaled mp_threshold (MP mp,integer m) {
24635 scaled d; /* lower bound on the smallest interval size */
24636 mp->excess=mp_min_cover(mp, 0)-m;
24637 if ( mp->excess<=0 ) {
24641 d=mp->perturbation;
24642 } while (mp_min_cover(mp, d+d)>m);
24643 while ( mp_min_cover(mp, d)>m )
24644 d=mp->perturbation;
24649 @ The |skimp| procedure reduces the current list to at most |m| entries,
24650 by changing values if necessary. It also sets |info(p):=k| if |value(p)|
24651 is the |k|th distinct value on the resulting list, and it sets
24652 |perturbation| to the maximum amount by which a |value| field has
24653 been changed. The size of the resulting list is returned as the
24656 @c integer mp_skimp (MP mp,integer m) {
24657 scaled d; /* the size of intervals being coalesced */
24658 pointer p,q,r; /* list manipulation registers */
24659 scaled l; /* the least value in the current interval */
24660 scaled v; /* a compromise value */
24661 d=mp_threshold(mp, m); mp->perturbation=0;
24662 q=temp_head; m=0; p=link(temp_head);
24663 while ( p!=inf_val ) {
24664 incr(m); l=value(p); info(p)=m;
24665 if ( value(link(p))<=l+d ) {
24666 @<Replace an interval of values by its midpoint@>;
24673 @ @<Replace an interval...@>=
24676 p=link(p); info(p)=m;
24677 decr(mp->excess); if ( mp->excess==0 ) d=0;
24678 } while (value(link(p))<=l+d);
24679 v=l+halfp(value(p)-l);
24680 if ( value(p)-v>mp->perturbation )
24681 mp->perturbation=value(p)-v;
24684 r=link(r); value(r)=v;
24686 link(q)=p; /* remove duplicate values from the current list */
24689 @ A warning message is issued whenever something is perturbed by
24690 more than 1/16\thinspace pt.
24692 @c void mp_tfm_warning (MP mp,small_number m) {
24693 mp_print_nl(mp, "(some ");
24694 mp_print(mp, mp->int_name[m]);
24695 @.some charwds...@>
24696 @.some chardps...@>
24697 @.some charhts...@>
24698 @.some charics...@>
24699 mp_print(mp, " values had to be adjusted by as much as ");
24700 mp_print_scaled(mp, mp->perturbation); mp_print(mp, "pt)");
24703 @ Here's an example of how we use these routines.
24704 The width data needs to be perturbed only if there are 256 distinct
24705 widths, but \MP\ must check for this case even though it is
24708 An integer variable |k| will be defined when we use this code.
24709 The |dimen_head| array will contain pointers to the sorted
24710 lists of dimensions.
24712 @<Massage the \.{TFM} widths@>=
24714 for (k=mp->bc;k<=mp->ec;k++) {
24715 if ( mp->char_exists[k] )
24716 mp->tfm_width[k]=mp_sort_in(mp, mp->tfm_width[k]);
24718 mp->nw=mp_skimp(mp, 255)+1; mp->dimen_head[1]=link(temp_head);
24719 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_wd)
24722 pointer dimen_head[5]; /* lists of \.{TFM} dimensions */
24724 @ Heights, depths, and italic corrections are different from widths
24725 not only because their list length is more severely restricted, but
24726 also because zero values do not need to be put into the lists.
24728 @<Massage the \.{TFM} heights, depths, and italic corrections@>=
24730 for (k=mp->bc;k<=mp->ec;k++) {
24731 if ( mp->char_exists[k] ) {
24732 if ( mp->tfm_height[k]==0 ) mp->tfm_height[k]=zero_val;
24733 else mp->tfm_height[k]=mp_sort_in(mp, mp->tfm_height[k]);
24736 mp->nh=mp_skimp(mp, 15)+1; mp->dimen_head[2]=link(temp_head);
24737 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_ht);
24739 for (k=mp->bc;k<=mp->ec;k++) {
24740 if ( mp->char_exists[k] ) {
24741 if ( mp->tfm_depth[k]==0 ) mp->tfm_depth[k]=zero_val;
24742 else mp->tfm_depth[k]=mp_sort_in(mp, mp->tfm_depth[k]);
24745 mp->nd=mp_skimp(mp, 15)+1; mp->dimen_head[3]=link(temp_head);
24746 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_dp);
24748 for (k=mp->bc;k<=mp->ec;k++) {
24749 if ( mp->char_exists[k] ) {
24750 if ( mp->tfm_ital_corr[k]==0 ) mp->tfm_ital_corr[k]=zero_val;
24751 else mp->tfm_ital_corr[k]=mp_sort_in(mp, mp->tfm_ital_corr[k]);
24754 mp->ni=mp_skimp(mp, 63)+1; mp->dimen_head[4]=link(temp_head);
24755 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_ic)
24757 @ @<Initialize table entries...@>=
24758 value(zero_val)=0; info(zero_val)=0;
24760 @ Bytes 5--8 of the header are set to the design size, unless the user has
24761 some crazy reason for specifying them differently.
24764 Error messages are not allowed at the time this procedure is called,
24765 so a warning is printed instead.
24767 The value of |max_tfm_dimen| is calculated so that
24768 $$\hbox{|make_scaled(16*max_tfm_dimen,internal[mp_design_size])|}
24769 < \\{three\_bytes}.$$
24771 @d three_bytes 0100000000 /* $2^{24}$ */
24774 void mp_fix_design_size (MP mp) {
24775 scaled d; /* the design size */
24776 d=mp->internal[mp_design_size];
24777 if ( (d<unity)||(d>=fraction_half) ) {
24779 mp_print_nl(mp, "(illegal design size has been changed to 128pt)");
24780 @.illegal design size...@>
24781 d=040000000; mp->internal[mp_design_size]=d;
24783 if ( mp->header_byte[4]<0 ) if ( mp->header_byte[5]<0 )
24784 if ( mp->header_byte[6]<0 ) if ( mp->header_byte[7]<0 ) {
24785 mp->header_byte[4]=d / 04000000;
24786 mp->header_byte[5]=(d / 4096) % 256;
24787 mp->header_byte[6]=(d / 16) % 256;
24788 mp->header_byte[7]=(d % 16)*16;
24790 mp->max_tfm_dimen=16*mp->internal[mp_design_size]-1-mp->internal[mp_design_size] / 010000000;
24791 if ( mp->max_tfm_dimen>=fraction_half ) mp->max_tfm_dimen=fraction_half-1;
24794 @ The |dimen_out| procedure computes a |fix_word| relative to the
24795 design size. If the data was out of range, it is corrected and the
24796 global variable |tfm_changed| is increased by~one.
24798 @c integer mp_dimen_out (MP mp,scaled x) {
24799 if ( abs(x)>mp->max_tfm_dimen ) {
24800 incr(mp->tfm_changed);
24801 if ( x>0 ) x=mp->max_tfm_dimen; else x=-mp->max_tfm_dimen;
24803 x=mp_make_scaled(mp, x*16,mp->internal[mp_design_size]);
24808 scaled max_tfm_dimen; /* bound on widths, heights, kerns, etc. */
24809 integer tfm_changed; /* the number of data entries that were out of bounds */
24811 @ If the user has not specified any of the first four header bytes,
24812 the |fix_check_sum| procedure replaces them by a ``check sum'' computed
24813 from the |tfm_width| data relative to the design size.
24816 @c void mp_fix_check_sum (MP mp) {
24817 eight_bits k; /* runs through character codes */
24818 eight_bits B1,B2,B3,B4; /* bytes of the check sum */
24819 integer x; /* hash value used in check sum computation */
24820 if ( mp->header_byte[0]==0 && mp->header_byte[1]==0 &&
24821 mp->header_byte[2]==0 && mp->header_byte[3]==0 ) {
24822 @<Compute a check sum in |(b1,b2,b3,b4)|@>;
24823 mp->header_byte[0]=B1; mp->header_byte[1]=B2;
24824 mp->header_byte[2]=B3; mp->header_byte[3]=B4;
24829 @ @<Compute a check sum in |(b1,b2,b3,b4)|@>=
24830 B1=mp->bc; B2=mp->ec; B3=mp->bc; B4=mp->ec; mp->tfm_changed=0;
24831 for (k=mp->bc;k<=mp->ec;k++) {
24832 if ( mp->char_exists[k] ) {
24833 x=mp_dimen_out(mp, value(mp->tfm_width[k]))+(k+4)*020000000; /* this is positive */
24834 B1=(B1+B1+x) % 255;
24835 B2=(B2+B2+x) % 253;
24836 B3=(B3+B3+x) % 251;
24837 B4=(B4+B4+x) % 247;
24841 @ Finally we're ready to actually write the \.{TFM} information.
24842 Here are some utility routines for this purpose.
24844 @d tfm_out(A) do { /* output one byte to |tfm_file| */
24845 unsigned char s=(A);
24846 (mp->write_binary_file)(mp,mp->tfm_file,(void *)&s,1);
24849 @c void mp_tfm_two (MP mp,integer x) { /* output two bytes to |tfm_file| */
24850 tfm_out(x / 256); tfm_out(x % 256);
24852 void mp_tfm_four (MP mp,integer x) { /* output four bytes to |tfm_file| */
24853 if ( x>=0 ) tfm_out(x / three_bytes);
24855 x=x+010000000000; /* use two's complement for negative values */
24857 tfm_out((x / three_bytes) + 128);
24859 x=x % three_bytes; tfm_out(x / unity);
24860 x=x % unity; tfm_out(x / 0400);
24863 void mp_tfm_qqqq (MP mp,four_quarters x) { /* output four quarterwords to |tfm_file| */
24864 tfm_out(qo(x.b0)); tfm_out(qo(x.b1));
24865 tfm_out(qo(x.b2)); tfm_out(qo(x.b3));
24868 @ @<Finish the \.{TFM} file@>=
24869 if ( mp->job_name==NULL ) mp_open_log_file(mp);
24870 mp_pack_job_name(mp, ".tfm");
24871 while ( ! mp_b_open_out(mp, &mp->tfm_file, mp_filetype_metrics) )
24872 mp_prompt_file_name(mp, "file name for font metrics",".tfm");
24873 mp->metric_file_name=xstrdup(mp->name_of_file);
24874 @<Output the subfile sizes and header bytes@>;
24875 @<Output the character information bytes, then
24876 output the dimensions themselves@>;
24877 @<Output the ligature/kern program@>;
24878 @<Output the extensible character recipes and the font metric parameters@>;
24879 if ( mp->internal[mp_tracing_stats]>0 )
24880 @<Log the subfile sizes of the \.{TFM} file@>;
24881 mp_print_nl(mp, "Font metrics written on ");
24882 mp_print(mp, mp->metric_file_name); mp_print_char(mp, '.');
24883 @.Font metrics written...@>
24884 (mp->close_file)(mp,mp->tfm_file)
24886 @ Integer variables |lh|, |k|, and |lk_offset| will be defined when we use
24889 @<Output the subfile sizes and header bytes@>=
24891 LH=(k+3) / 4; /* this is the number of header words */
24892 if ( mp->bc>mp->ec ) mp->bc=1; /* if there are no characters, |ec=0| and |bc=1| */
24893 @<Compute the ligature/kern program offset and implant the
24894 left boundary label@>;
24895 mp_tfm_two(mp,6+LH+(mp->ec-mp->bc+1)+mp->nw+mp->nh+mp->nd+mp->ni+mp->nl
24896 +lk_offset+mp->nk+mp->ne+mp->np);
24897 /* this is the total number of file words that will be output */
24898 mp_tfm_two(mp, LH); mp_tfm_two(mp, mp->bc); mp_tfm_two(mp, mp->ec);
24899 mp_tfm_two(mp, mp->nw); mp_tfm_two(mp, mp->nh);
24900 mp_tfm_two(mp, mp->nd); mp_tfm_two(mp, mp->ni); mp_tfm_two(mp, mp->nl+lk_offset);
24901 mp_tfm_two(mp, mp->nk); mp_tfm_two(mp, mp->ne);
24902 mp_tfm_two(mp, mp->np);
24903 for (k=0;k< 4*LH;k++) {
24904 tfm_out(mp->header_byte[k]);
24907 @ @<Output the character information bytes...@>=
24908 for (k=mp->bc;k<=mp->ec;k++) {
24909 if ( ! mp->char_exists[k] ) {
24910 mp_tfm_four(mp, 0);
24912 tfm_out(info(mp->tfm_width[k])); /* the width index */
24913 tfm_out((info(mp->tfm_height[k]))*16+info(mp->tfm_depth[k]));
24914 tfm_out((info(mp->tfm_ital_corr[k]))*4+mp->char_tag[k]);
24915 tfm_out(mp->char_remainder[k]);
24919 for (k=1;k<=4;k++) {
24920 mp_tfm_four(mp, 0); p=mp->dimen_head[k];
24921 while ( p!=inf_val ) {
24922 mp_tfm_four(mp, mp_dimen_out(mp, value(p))); p=link(p);
24927 @ We need to output special instructions at the beginning of the
24928 |lig_kern| array in order to specify the right boundary character
24929 and/or to handle starting addresses that exceed 255. The |label_loc|
24930 and |label_char| arrays have been set up to record all the
24931 starting addresses; we have $-1=|label_loc|[0]<|label_loc|[1]\le\cdots
24932 \le|label_loc|[|label_ptr]|$.
24934 @<Compute the ligature/kern program offset...@>=
24935 mp->bchar=mp_round_unscaled(mp, mp->internal[mp_boundary_char]);
24936 if ((mp->bchar<0)||(mp->bchar>255))
24937 { mp->bchar=-1; mp->lk_started=false; lk_offset=0; }
24938 else { mp->lk_started=true; lk_offset=1; };
24939 @<Find the minimum |lk_offset| and adjust all remainders@>;
24940 if ( mp->bch_label<undefined_label )
24941 { skip_byte(mp->nl)=qi(255); next_char(mp->nl)=qi(0);
24942 op_byte(mp->nl)=qi(((mp->bch_label+lk_offset)/ 256));
24943 rem_byte(mp->nl)=qi(((mp->bch_label+lk_offset)% 256));
24944 incr(mp->nl); /* possibly |nl=lig_table_size+1| */
24947 @ @<Find the minimum |lk_offset|...@>=
24948 k=mp->label_ptr; /* pointer to the largest unallocated label */
24949 if ( mp->label_loc[k]+lk_offset>255 ) {
24950 lk_offset=0; mp->lk_started=false; /* location 0 can do double duty */
24952 mp->char_remainder[mp->label_char[k]]=lk_offset;
24953 while ( mp->label_loc[k-1]==mp->label_loc[k] ) {
24954 decr(k); mp->char_remainder[mp->label_char[k]]=lk_offset;
24956 incr(lk_offset); decr(k);
24957 } while (! (lk_offset+mp->label_loc[k]<256));
24958 /* N.B.: |lk_offset=256| satisfies this when |k=0| */
24960 if ( lk_offset>0 ) {
24962 mp->char_remainder[mp->label_char[k]]
24963 =mp->char_remainder[mp->label_char[k]]+lk_offset;
24968 @ @<Output the ligature/kern program@>=
24969 for (k=0;k<= 255;k++ ) {
24970 if ( mp->skip_table[k]<undefined_label ) {
24971 mp_print_nl(mp, "(local label "); mp_print_int(mp, k); mp_print(mp, ":: was missing)");
24972 @.local label l:: was missing@>
24973 cancel_skips(mp->skip_table[k]);
24976 if ( mp->lk_started ) { /* |lk_offset=1| for the special |bchar| */
24977 tfm_out(255); tfm_out(mp->bchar); mp_tfm_two(mp, 0);
24979 for (k=1;k<=lk_offset;k++) {/* output the redirection specs */
24980 mp->ll=mp->label_loc[mp->label_ptr];
24981 if ( mp->bchar<0 ) { tfm_out(254); tfm_out(0); }
24982 else { tfm_out(255); tfm_out(mp->bchar); };
24983 mp_tfm_two(mp, mp->ll+lk_offset);
24985 decr(mp->label_ptr);
24986 } while (! (mp->label_loc[mp->label_ptr]<mp->ll));
24989 for (k=0;k<=mp->nl-1;k++) mp_tfm_qqqq(mp, mp->lig_kern[k]);
24990 for (k=0;k<=mp->nk-1;k++) mp_tfm_four(mp, mp_dimen_out(mp, mp->kern[k]))
24992 @ @<Output the extensible character recipes...@>=
24993 for (k=0;k<=mp->ne-1;k++)
24994 mp_tfm_qqqq(mp, mp->exten[k]);
24995 for (k=1;k<=mp->np;k++) {
24997 if ( abs(mp->param[1])<fraction_half ) {
24998 mp_tfm_four(mp, mp->param[1]*16);
25000 incr(mp->tfm_changed);
25001 if ( mp->param[1]>0 ) mp_tfm_four(mp, el_gordo);
25002 else mp_tfm_four(mp, -el_gordo);
25005 mp_tfm_four(mp, mp_dimen_out(mp, mp->param[k]));
25008 if ( mp->tfm_changed>0 ) {
25009 if ( mp->tfm_changed==1 ) mp_print_nl(mp, "(a font metric dimension");
25010 @.a font metric dimension...@>
25012 mp_print_nl(mp, "("); mp_print_int(mp, mp->tfm_changed);
25013 @.font metric dimensions...@>
25014 mp_print(mp, " font metric dimensions");
25016 mp_print(mp, " had to be decreased)");
25019 @ @<Log the subfile sizes of the \.{TFM} file@>=
25023 if ( mp->bch_label<undefined_label ) decr(mp->nl);
25024 mp_snprintf(s,128,"(You used %iw,%ih,%id,%ii,%il,%ik,%ie,%ip metric file positions)",
25025 mp->nw, mp->nh, mp->nd, mp->ni, mp->nl, mp->nk, mp->ne,mp->np);
25029 @* \[43] Reading font metric data.
25031 \MP\ isn't a typesetting program but it does need to find the bounding box
25032 of a sequence of typeset characters. Thus it needs to read \.{TFM} files as
25033 well as write them.
25038 @ All the width, height, and depth information is stored in an array called
25039 |font_info|. This array is allocated sequentially and each font is stored
25040 as a series of |char_info| words followed by the width, height, and depth
25041 tables. Since |font_name| entries are permanent, their |str_ref| values are
25042 set to |max_str_ref|.
25045 typedef unsigned int font_number; /* |0..font_max| */
25047 @ The |font_info| array is indexed via a group directory arrays.
25048 For example, the |char_info| data for character~|c| in font~|f| will be
25049 in |font_info[char_base[f]+c].qqqq|.
25052 font_number font_max; /* maximum font number for included text fonts */
25053 size_t font_mem_size; /* number of words for \.{TFM} information for text fonts */
25054 memory_word *font_info; /* height, width, and depth data */
25055 char **font_enc_name; /* encoding names, if any */
25056 boolean *font_ps_name_fixed; /* are the postscript names fixed already? */
25057 int next_fmem; /* next unused entry in |font_info| */
25058 font_number last_fnum; /* last font number used so far */
25059 scaled *font_dsize; /* 16 times the ``design'' size in \ps\ points */
25060 char **font_name; /* name as specified in the \&{infont} command */
25061 char **font_ps_name; /* PostScript name for use when |internal[mp_prologues]>0| */
25062 font_number last_ps_fnum; /* last valid |font_ps_name| index */
25063 eight_bits *font_bc;
25064 eight_bits *font_ec; /* first and last character code */
25065 int *char_base; /* base address for |char_info| */
25066 int *width_base; /* index for zeroth character width */
25067 int *height_base; /* index for zeroth character height */
25068 int *depth_base; /* index for zeroth character depth */
25069 pointer *font_sizes;
25071 @ @<Allocate or initialize ...@>=
25072 mp->font_mem_size = 10000;
25073 mp->font_info = xmalloc ((mp->font_mem_size+1),sizeof(memory_word));
25074 memset (mp->font_info,0,sizeof(memory_word)*(mp->font_mem_size+1));
25075 mp->font_enc_name = NULL;
25076 mp->font_ps_name_fixed = NULL;
25077 mp->font_dsize = NULL;
25078 mp->font_name = NULL;
25079 mp->font_ps_name = NULL;
25080 mp->font_bc = NULL;
25081 mp->font_ec = NULL;
25082 mp->last_fnum = null_font;
25083 mp->char_base = NULL;
25084 mp->width_base = NULL;
25085 mp->height_base = NULL;
25086 mp->depth_base = NULL;
25087 mp->font_sizes = null;
25089 @ @<Dealloc variables@>=
25090 for (k=1;k<=(int)mp->last_fnum;k++) {
25091 xfree(mp->font_enc_name[k]);
25092 xfree(mp->font_name[k]);
25093 xfree(mp->font_ps_name[k]);
25095 xfree(mp->font_info);
25096 xfree(mp->font_enc_name);
25097 xfree(mp->font_ps_name_fixed);
25098 xfree(mp->font_dsize);
25099 xfree(mp->font_name);
25100 xfree(mp->font_ps_name);
25101 xfree(mp->font_bc);
25102 xfree(mp->font_ec);
25103 xfree(mp->char_base);
25104 xfree(mp->width_base);
25105 xfree(mp->height_base);
25106 xfree(mp->depth_base);
25107 xfree(mp->font_sizes);
25111 void mp_reallocate_fonts (MP mp, font_number l) {
25113 XREALLOC(mp->font_enc_name, l, char *);
25114 XREALLOC(mp->font_ps_name_fixed, l, boolean);
25115 XREALLOC(mp->font_dsize, l, scaled);
25116 XREALLOC(mp->font_name, l, char *);
25117 XREALLOC(mp->font_ps_name, l, char *);
25118 XREALLOC(mp->font_bc, l, eight_bits);
25119 XREALLOC(mp->font_ec, l, eight_bits);
25120 XREALLOC(mp->char_base, l, int);
25121 XREALLOC(mp->width_base, l, int);
25122 XREALLOC(mp->height_base, l, int);
25123 XREALLOC(mp->depth_base, l, int);
25124 XREALLOC(mp->font_sizes, l, pointer);
25125 for (f=(mp->last_fnum+1);f<=l;f++) {
25126 mp->font_enc_name[f]=NULL;
25127 mp->font_ps_name_fixed[f] = false;
25128 mp->font_name[f]=NULL;
25129 mp->font_ps_name[f]=NULL;
25130 mp->font_sizes[f]=null;
25135 @ @<Declare |mp_reallocate| functions@>=
25136 void mp_reallocate_fonts (MP mp, font_number l);
25139 @ A |null_font| containing no characters is useful for error recovery. Its
25140 |font_name| entry starts out empty but is reset each time an erroneous font is
25141 found. This helps to cut down on the number of duplicate error messages without
25142 wasting a lot of space.
25144 @d null_font 0 /* the |font_number| for an empty font */
25146 @<Set initial...@>=
25147 mp->font_dsize[null_font]=0;
25148 mp->font_bc[null_font]=1;
25149 mp->font_ec[null_font]=0;
25150 mp->char_base[null_font]=0;
25151 mp->width_base[null_font]=0;
25152 mp->height_base[null_font]=0;
25153 mp->depth_base[null_font]=0;
25155 mp->last_fnum=null_font;
25156 mp->last_ps_fnum=null_font;
25157 mp->font_name[null_font]=(char *)"nullfont";
25158 mp->font_ps_name[null_font]=(char *)"";
25159 mp->font_ps_name_fixed[null_font] = false;
25160 mp->font_enc_name[null_font]=NULL;
25161 mp->font_sizes[null_font]=null;
25163 @ Each |char_info| word is of type |four_quarters|. The |b0| field contains
25164 the |width index|; the |b1| field contains the height
25165 index; the |b2| fields contains the depth index, and the |b3| field used only
25166 for temporary storage. (It is used to keep track of which characters occur in
25167 an edge structure that is being shipped out.)
25168 The corresponding words in the width, height, and depth tables are stored as
25169 |scaled| values in units of \ps\ points.
25171 With the macros below, the |char_info| word for character~|c| in font~|f| is
25172 |char_info(f)(c)| and the width is
25173 $$\hbox{|char_width(f)(char_info(f)(c)).sc|.}$$
25175 @d char_info_end(A) (A)].qqqq
25176 @d char_info(A) mp->font_info[mp->char_base[(A)]+char_info_end
25177 @d char_width_end(A) (A).b0].sc
25178 @d char_width(A) mp->font_info[mp->width_base[(A)]+char_width_end
25179 @d char_height_end(A) (A).b1].sc
25180 @d char_height(A) mp->font_info[mp->height_base[(A)]+char_height_end
25181 @d char_depth_end(A) (A).b2].sc
25182 @d char_depth(A) mp->font_info[mp->depth_base[(A)]+char_depth_end
25183 @d ichar_exists(A) ((A).b0>0)
25185 @ The |font_ps_name| for a built-in font should be what PostScript expects.
25186 A preliminary name is obtained here from the \.{TFM} name as given in the
25187 |fname| argument. This gets updated later from an external table if necessary.
25189 @<Declare text measuring subroutines@>=
25190 @<Declare subroutines for parsing file names@>
25191 font_number mp_read_font_info (MP mp, char *fname) {
25192 boolean file_opened; /* has |tfm_infile| been opened? */
25193 font_number n; /* the number to return */
25194 halfword lf,tfm_lh,bc,ec,nw,nh,nd; /* subfile size parameters */
25195 size_t whd_size; /* words needed for heights, widths, and depths */
25196 int i,ii; /* |font_info| indices */
25197 int jj; /* counts bytes to be ignored */
25198 scaled z; /* used to compute the design size */
25200 /* height, width, or depth as a fraction of design size times $2^{-8}$ */
25201 eight_bits h_and_d; /* height and depth indices being unpacked */
25202 unsigned char tfbyte; /* a byte read from the file */
25204 @<Open |tfm_infile| for input@>;
25205 @<Read data from |tfm_infile|; if there is no room, say so and |goto done|;
25206 otherwise |goto bad_tfm| or |goto done| as appropriate@>;
25208 @<Complain that the \.{TFM} file is bad@>;
25210 if ( file_opened ) (mp->close_file)(mp,mp->tfm_infile);
25211 if ( n!=null_font ) {
25212 mp->font_ps_name[n]=mp_xstrdup(mp,fname);
25213 mp->font_name[n]=mp_xstrdup(mp,fname);
25218 @ \MP\ doesn't bother to check the entire \.{TFM} file for errors or explain
25219 precisely what is wrong if it does find a problem. Programs called \.{TFtoPL}
25220 @.TFtoPL@> @.PLtoTF@>
25221 and \.{PLtoTF} can be used to debug \.{TFM} files.
25223 @<Complain that the \.{TFM} file is bad@>=
25224 print_err("Font ");
25225 mp_print(mp, fname);
25226 if ( file_opened ) mp_print(mp, " not usable: TFM file is bad");
25227 else mp_print(mp, " not usable: TFM file not found");
25228 help3("I wasn't able to read the size data for this font so this")
25229 ("`infont' operation won't produce anything. If the font name")
25230 ("is right, you might ask an expert to make a TFM file");
25232 mp->help_line[0]="is right, try asking an expert to fix the TFM file";
25235 @ @<Read data from |tfm_infile|; if there is no room, say so...@>=
25236 @<Read the \.{TFM} size fields@>;
25237 @<Use the size fields to allocate space in |font_info|@>;
25238 @<Read the \.{TFM} header@>;
25239 @<Read the character data and the width, height, and depth tables and
25242 @ A bad \.{TFM} file can be shorter than it claims to be. The code given here
25243 might try to read past the end of the file if this happens. Changes will be
25244 needed if it causes a system error to refer to |tfm_infile^| or call
25245 |get_tfm_infile| when |eof(tfm_infile)| is true. For example, the definition
25246 @^system dependencies@>
25247 of |tfget| could be changed to
25248 ``|begin get(tfm_infile); if eof(tfm_infile) then goto bad_tfm; end|.''
25252 void *tfbyte_ptr = &tfbyte;
25253 (mp->read_binary_file)(mp,mp->tfm_infile,&tfbyte_ptr,&wanted);
25254 if (wanted==0) goto BAD_TFM;
25256 @d read_two(A) { (A)=tfbyte;
25257 if ( (A)>127 ) goto BAD_TFM;
25258 tfget; (A)=(A)*0400+tfbyte;
25260 @d tf_ignore(A) { for (jj=(A);jj>=1;jj--) tfget; }
25262 @<Read the \.{TFM} size fields@>=
25263 tfget; read_two(lf);
25264 tfget; read_two(tfm_lh);
25265 tfget; read_two(bc);
25266 tfget; read_two(ec);
25267 if ( (bc>1+ec)||(ec>255) ) goto BAD_TFM;
25268 tfget; read_two(nw);
25269 tfget; read_two(nh);
25270 tfget; read_two(nd);
25271 whd_size=(ec+1-bc)+nw+nh+nd;
25272 if ( lf<(int)(6+tfm_lh+whd_size) ) goto BAD_TFM;
25275 @ Offsets are added to |char_base[n]| and |width_base[n]| so that is not
25276 necessary to apply the |so| and |qo| macros when looking up the width of a
25277 character in the string pool. In order to ensure nonnegative |char_base|
25278 values when |bc>0|, it may be necessary to reserve a few unused |font_info|
25281 @<Use the size fields to allocate space in |font_info|@>=
25282 if ( mp->next_fmem<bc) mp->next_fmem=bc; /* ensure nonnegative |char_base| */
25283 if (mp->last_fnum==mp->font_max)
25284 mp_reallocate_fonts(mp,(mp->font_max+(mp->font_max>>2)));
25285 while (mp->next_fmem+whd_size>=mp->font_mem_size) {
25286 size_t l = mp->font_mem_size+(mp->font_mem_size>>2);
25287 memory_word *font_info;
25288 font_info = xmalloc ((l+1),sizeof(memory_word));
25289 memset (font_info,0,sizeof(memory_word)*(l+1));
25290 memcpy (font_info,mp->font_info,sizeof(memory_word)*(mp->font_mem_size+1));
25291 xfree(mp->font_info);
25292 mp->font_info = font_info;
25293 mp->font_mem_size = l;
25295 incr(mp->last_fnum);
25299 mp->char_base[n]=mp->next_fmem-bc;
25300 mp->width_base[n]=mp->next_fmem+ec-bc+1;
25301 mp->height_base[n]=mp->width_base[n]+nw;
25302 mp->depth_base[n]=mp->height_base[n]+nh;
25303 mp->next_fmem=mp->next_fmem+whd_size;
25306 @ @<Read the \.{TFM} header@>=
25307 if ( tfm_lh<2 ) goto BAD_TFM;
25309 tfget; read_two(z);
25310 tfget; z=z*0400+tfbyte;
25311 tfget; z=z*0400+tfbyte; /* now |z| is 16 times the design size */
25312 mp->font_dsize[n]=mp_take_fraction(mp, z,267432584);
25313 /* times ${72\over72.27}2^{28}$ to convert from \TeX\ points */
25314 tf_ignore(4*(tfm_lh-2))
25316 @ @<Read the character data and the width, height, and depth tables...@>=
25317 ii=mp->width_base[n];
25318 i=mp->char_base[n]+bc;
25320 tfget; mp->font_info[i].qqqq.b0=qi(tfbyte);
25321 tfget; h_and_d=tfbyte;
25322 mp->font_info[i].qqqq.b1=h_and_d / 16;
25323 mp->font_info[i].qqqq.b2=h_and_d % 16;
25327 while ( i<mp->next_fmem ) {
25328 @<Read a four byte dimension, scale it by the design size, store it in
25329 |font_info[i]|, and increment |i|@>;
25333 @ The raw dimension read into |d| should have magnitude at most $2^{24}$ when
25334 interpreted as an integer, and this includes a scale factor of $2^{20}$. Thus
25335 we can multiply it by sixteen and think of it as a |fraction| that has been
25336 divided by sixteen. This cancels the extra scale factor contained in
25339 @<Read a four byte dimension, scale it by the design size, store it in...@>=
25342 if ( d>=0200 ) d=d-0400;
25343 tfget; d=d*0400+tfbyte;
25344 tfget; d=d*0400+tfbyte;
25345 tfget; d=d*0400+tfbyte;
25346 mp->font_info[i].sc=mp_take_fraction(mp, d*16,mp->font_dsize[n]);
25350 @ This function does no longer use the file name parser, because |fname| is
25351 a C string already.
25352 @<Open |tfm_infile| for input@>=
25354 mp_ptr_scan_file(mp, fname);
25355 if ( strlen(mp->cur_area)==0 ) { xfree(mp->cur_area); }
25356 if ( strlen(mp->cur_ext)==0 ) { xfree(mp->cur_ext); mp->cur_ext=xstrdup(".tfm"); }
25358 mp->tfm_infile = (mp->open_file)(mp, mp->name_of_file, "r",mp_filetype_metrics);
25359 if ( !mp->tfm_infile ) goto BAD_TFM;
25362 @ When we have a font name and we don't know whether it has been loaded yet,
25363 we scan the |font_name| array before calling |read_font_info|.
25365 @<Declare text measuring subroutines@>=
25366 font_number mp_find_font (MP mp, char *f) {
25368 for (n=0;n<=mp->last_fnum;n++) {
25369 if (mp_xstrcmp(f,mp->font_name[n])==0 ) {
25374 n = mp_read_font_info(mp, f);
25379 @ This is an interface function for getting the width of character,
25380 as a double in ps units
25382 @c double mp_get_char_dimension (MP mp, char *fname, int c, int t) {
25387 for (n=0;n<=mp->last_fnum;n++) {
25388 if (mp_xstrcmp(fname,mp->font_name[n])==0 ) {
25395 cc = char_info(f)(c);
25396 if (! ichar_exists(cc) )
25399 w = char_width(f)(cc);
25401 w = char_height(f)(cc);
25403 w = char_depth(f)(cc);
25404 return w/655.35*(72.27/72);
25407 @ @<Exported function ...@>=
25408 double mp_get_char_dimension (MP mp, char *fname, int n, int t);
25411 @ One simple application of |find_font| is the implementation of the |font_size|
25412 operator that gets the design size for a given font name.
25414 @<Find the design size of the font whose name is |cur_exp|@>=
25415 mp_flush_cur_exp(mp, (mp->font_dsize[mp_find_font(mp, str(mp->cur_exp))]+8) / 16)
25417 @ If we discover that the font doesn't have a requested character, we omit it
25418 from the bounding box computation and expect the \ps\ interpreter to drop it.
25419 This routine issues a warning message if the user has asked for it.
25421 @<Declare text measuring subroutines@>=
25422 void mp_lost_warning (MP mp,font_number f, pool_pointer k) {
25423 if ( mp->internal[mp_tracing_lost_chars]>0 ) {
25424 mp_begin_diagnostic(mp);
25425 if ( mp->selector==log_only ) incr(mp->selector);
25426 mp_print_nl(mp, "Missing character: There is no ");
25427 @.Missing character@>
25428 mp_print_str(mp, mp->str_pool[k]);
25429 mp_print(mp, " in font ");
25430 mp_print(mp, mp->font_name[f]); mp_print_char(mp, '!');
25431 mp_end_diagnostic(mp, false);
25435 @ The whole purpose of saving the height, width, and depth information is to be
25436 able to find the bounding box of an item of text in an edge structure. The
25437 |set_text_box| procedure takes a text node and adds this information.
25439 @<Declare text measuring subroutines@>=
25440 void mp_set_text_box (MP mp,pointer p) {
25441 font_number f; /* |font_n(p)| */
25442 ASCII_code bc,ec; /* range of valid characters for font |f| */
25443 pool_pointer k,kk; /* current character and character to stop at */
25444 four_quarters cc; /* the |char_info| for the current character */
25445 scaled h,d; /* dimensions of the current character */
25447 height_val(p)=-el_gordo;
25448 depth_val(p)=-el_gordo;
25452 kk=str_stop(text_p(p));
25453 k=mp->str_start[text_p(p)];
25455 @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>;
25457 @<Set the height and depth to zero if the bounding box is empty@>;
25460 @ @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>=
25462 if ( (mp->str_pool[k]<bc)||(mp->str_pool[k]>ec) ) {
25463 mp_lost_warning(mp, f,k);
25465 cc=char_info(f)(mp->str_pool[k]);
25466 if ( ! ichar_exists(cc) ) {
25467 mp_lost_warning(mp, f,k);
25469 width_val(p)=width_val(p)+char_width(f)(cc);
25470 h=char_height(f)(cc);
25471 d=char_depth(f)(cc);
25472 if ( h>height_val(p) ) height_val(p)=h;
25473 if ( d>depth_val(p) ) depth_val(p)=d;
25479 @ Let's hope modern compilers do comparisons correctly when the difference would
25482 @<Set the height and depth to zero if the bounding box is empty@>=
25483 if ( height_val(p)<-depth_val(p) ) {
25488 @ The new primitives fontmapfile and fontmapline.
25490 @<Declare action procedures for use by |do_statement|@>=
25491 void mp_do_mapfile (MP mp) ;
25492 void mp_do_mapline (MP mp) ;
25494 @ @c void mp_do_mapfile (MP mp) {
25495 mp_get_x_next(mp); mp_scan_expression(mp);
25496 if ( mp->cur_type!=mp_string_type ) {
25497 @<Complain about improper map operation@>;
25499 mp_map_file(mp,mp->cur_exp);
25502 void mp_do_mapline (MP mp) {
25503 mp_get_x_next(mp); mp_scan_expression(mp);
25504 if ( mp->cur_type!=mp_string_type ) {
25505 @<Complain about improper map operation@>;
25507 mp_map_line(mp,mp->cur_exp);
25511 @ @<Complain about improper map operation@>=
25513 exp_err("Unsuitable expression");
25514 help1("Only known strings can be map files or map lines.");
25515 mp_put_get_error(mp);
25518 @ To print |scaled| value to PDF output we need some subroutines to ensure
25521 @d max_integer 0x7FFFFFFF /* $2^{31}-1$ */
25524 scaled one_bp; /* scaled value corresponds to 1bp */
25525 scaled one_hundred_bp; /* scaled value corresponds to 100bp */
25526 scaled one_hundred_inch; /* scaled value corresponds to 100in */
25527 integer ten_pow[10]; /* $10^0..10^9$ */
25528 integer scaled_out; /* amount of |scaled| that was taken out in |divide_scaled| */
25531 mp->one_bp = 65782; /* 65781.76 */
25532 mp->one_hundred_bp = 6578176;
25533 mp->one_hundred_inch = 473628672;
25534 mp->ten_pow[0] = 1;
25535 for (i = 1;i<= 9; i++ ) {
25536 mp->ten_pow[i] = 10*mp->ten_pow[i - 1];
25539 @ The following function divides |s| by |m|. |dd| is number of decimal digits.
25541 @c scaled mp_divide_scaled (MP mp,scaled s, scaled m, integer dd) {
25545 if ( s < 0 ) { sign = -sign; s = -s; }
25546 if ( m < 0 ) { sign = -sign; m = -m; }
25548 mp_confusion(mp, "arithmetic: divided by zero");
25549 else if ( m >= (max_integer / 10) )
25550 mp_confusion(mp, "arithmetic: number too big");
25553 for (i = 1;i<=dd;i++) {
25554 q = 10*q + (10*r) / m;
25557 if ( 2*r >= m ) { incr(q); r = r - m; }
25558 mp->scaled_out = sign*(s - (r / mp->ten_pow[dd]));
25562 @* \[44] Shipping pictures out.
25563 The |ship_out| procedure, to be described below, is given a pointer to
25564 an edge structure. Its mission is to output a file containing the \ps\
25565 description of an edge structure.
25567 @ Each time an edge structure is shipped out we write a new \ps\ output
25568 file named according to the current \&{charcode}.
25569 @:char_code_}{\&{charcode} primitive@>
25571 This is the only backend function that remains in the main |mpost.w| file.
25572 There are just too many variable accesses needed for status reporting
25573 etcetera to make it worthwile to move the code to |psout.w|.
25575 @<Internal library declarations@>=
25576 void mp_open_output_file (MP mp) ;
25579 char *mp_set_output_file_name (MP mp, integer c) {
25580 char *ss = NULL; /* filename extension proposal */
25581 char *nn = NULL; /* temp string for str() */
25582 int old_setting; /* previous |selector| setting */
25583 pool_pointer i; /* indexes into |filename_template| */
25584 integer cc; /* a temporary integer for template building */
25585 integer f,g=0; /* field widths */
25586 if ( mp->job_name==NULL ) mp_open_log_file(mp);
25587 if ( mp->filename_template==0 ) {
25588 char *s; /* a file extension derived from |c| */
25592 @<Use |c| to compute the file extension |s|@>;
25593 mp_pack_job_name(mp, s);
25595 } else { /* initializations */
25596 str_number s, n; /* a file extension derived from |c| */
25597 old_setting=mp->selector;
25598 mp->selector=new_string;
25600 i = mp->str_start[mp->filename_template];
25601 n = rts(""); /* initialize */
25602 while ( i<str_stop(mp->filename_template) ) {
25603 if ( mp->str_pool[i]=='%' ) {
25606 if ( i<str_stop(mp->filename_template) ) {
25607 if ( mp->str_pool[i]=='j' ) {
25608 mp_print(mp, mp->job_name);
25609 } else if ( mp->str_pool[i]=='d' ) {
25610 cc= mp_round_unscaled(mp, mp->internal[mp_day]);
25611 print_with_leading_zeroes(cc);
25612 } else if ( mp->str_pool[i]=='m' ) {
25613 cc= mp_round_unscaled(mp, mp->internal[mp_month]);
25614 print_with_leading_zeroes(cc);
25615 } else if ( mp->str_pool[i]=='y' ) {
25616 cc= mp_round_unscaled(mp, mp->internal[mp_year]);
25617 print_with_leading_zeroes(cc);
25618 } else if ( mp->str_pool[i]=='H' ) {
25619 cc= mp_round_unscaled(mp, mp->internal[mp_time]) / 60;
25620 print_with_leading_zeroes(cc);
25621 } else if ( mp->str_pool[i]=='M' ) {
25622 cc= mp_round_unscaled(mp, mp->internal[mp_time]) % 60;
25623 print_with_leading_zeroes(cc);
25624 } else if ( mp->str_pool[i]=='c' ) {
25625 if ( c<0 ) mp_print(mp, "ps");
25626 else print_with_leading_zeroes(c);
25627 } else if ( (mp->str_pool[i]>='0') &&
25628 (mp->str_pool[i]<='9') ) {
25630 f = (f*10) + mp->str_pool[i]-'0';
25633 mp_print_str(mp, mp->str_pool[i]);
25637 if ( mp->str_pool[i]=='.' )
25639 n = mp_make_string(mp);
25640 mp_print_str(mp, mp->str_pool[i]);
25644 s = mp_make_string(mp);
25645 mp->selector= old_setting;
25646 if (length(n)==0) {
25652 mp_pack_file_name(mp, nn,"",ss);
25660 char * mp_get_output_file_name (MP mp) {
25662 char *saved_name; /* saved |name_of_file| */
25663 saved_name = mp_xstrdup(mp, mp->name_of_file);
25664 junk = mp_set_output_file_name(mp, mp_round_unscaled(mp, mp->internal[mp_char_code]));
25666 mp_pack_file_name(mp, saved_name,NULL,NULL);
25668 return mp->name_of_file;
25671 void mp_open_output_file (MP mp) {
25672 char *ss; /* filename extension proposal */
25673 integer c; /* \&{charcode} rounded to the nearest integer */
25674 c=mp_round_unscaled(mp, mp->internal[mp_char_code]);
25675 ss = mp_set_output_file_name(mp, c);
25676 while ( ! mp_a_open_out(mp, (void *)&mp->ps_file, mp_filetype_postscript) )
25677 mp_prompt_file_name(mp, "file name for output",ss);
25679 @<Store the true output file name if appropriate@>;
25682 @ The file extension created here could be up to five characters long in
25683 extreme cases so it may have to be shortened on some systems.
25684 @^system dependencies@>
25686 @<Use |c| to compute the file extension |s|@>=
25689 mp_snprintf(s,7,".%i",(int)c);
25692 @ The user won't want to see all the output file names so we only save the
25693 first and last ones and a count of how many there were. For this purpose
25694 files are ordered primarily by \&{charcode} and secondarily by order of
25696 @:char_code_}{\&{charcode} primitive@>
25698 @<Store the true output file name if appropriate@>=
25699 if ((c<mp->first_output_code)&&(mp->first_output_code>=0)) {
25700 mp->first_output_code=c;
25701 xfree(mp->first_file_name);
25702 mp->first_file_name=xstrdup(mp->name_of_file);
25704 if ( c>=mp->last_output_code ) {
25705 mp->last_output_code=c;
25706 xfree(mp->last_file_name);
25707 mp->last_file_name=xstrdup(mp->name_of_file);
25711 char * first_file_name;
25712 char * last_file_name; /* full file names */
25713 integer first_output_code;integer last_output_code; /* rounded \&{charcode} values */
25714 @:char_code_}{\&{charcode} primitive@>
25715 integer total_shipped; /* total number of |ship_out| operations completed */
25718 mp->first_file_name=xstrdup("");
25719 mp->last_file_name=xstrdup("");
25720 mp->first_output_code=32768;
25721 mp->last_output_code=-32768;
25722 mp->total_shipped=0;
25724 @ @<Dealloc variables@>=
25725 xfree(mp->first_file_name);
25726 xfree(mp->last_file_name);
25728 @ @<Begin the progress report for the output of picture~|c|@>=
25729 if ( (int)mp->term_offset>mp->max_print_line-6 ) mp_print_ln(mp);
25730 else if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_char(mp, ' ');
25731 mp_print_char(mp, '[');
25732 if ( c>=0 ) mp_print_int(mp, c)
25734 @ @<End progress report@>=
25735 mp_print_char(mp, ']');
25737 incr(mp->total_shipped)
25739 @ @<Explain what output files were written@>=
25740 if ( mp->total_shipped>0 ) {
25741 mp_print_nl(mp, "");
25742 mp_print_int(mp, mp->total_shipped);
25743 if (mp->noninteractive) {
25744 mp_print(mp, " figure");
25745 if ( mp->total_shipped>1 ) mp_print_char(mp, 's');
25746 mp_print(mp, " created.");
25748 mp_print(mp, " output file");
25749 if ( mp->total_shipped>1 ) mp_print_char(mp, 's');
25750 mp_print(mp, " written: ");
25751 mp_print(mp, mp->first_file_name);
25752 if ( mp->total_shipped>1 ) {
25753 if ( 31+strlen(mp->first_file_name)+
25754 strlen(mp->last_file_name)> (unsigned)mp->max_print_line)
25756 mp_print(mp, " .. ");
25757 mp_print(mp, mp->last_file_name);
25762 @ @<Internal library declarations@>=
25763 boolean mp_has_font_size(MP mp, font_number f );
25766 boolean mp_has_font_size(MP mp, font_number f ) {
25767 return (mp->font_sizes[f]!=null);
25770 @ The \&{special} command saves up lines of text to be printed during the next
25771 |ship_out| operation. The saved items are stored as a list of capsule tokens.
25774 pointer last_pending; /* the last token in a list of pending specials */
25777 mp->last_pending=spec_head;
25779 @ @<Cases of |do_statement|...@>=
25780 case special_command:
25781 if ( mp->cur_mod==0 ) mp_do_special(mp); else
25782 if ( mp->cur_mod==1 ) mp_do_mapfile(mp); else
25786 @ @<Declare action procedures for use by |do_statement|@>=
25787 void mp_do_special (MP mp) ;
25789 @ @c void mp_do_special (MP mp) {
25790 mp_get_x_next(mp); mp_scan_expression(mp);
25791 if ( mp->cur_type!=mp_string_type ) {
25792 @<Complain about improper special operation@>;
25794 link(mp->last_pending)=mp_stash_cur_exp(mp);
25795 mp->last_pending=link(mp->last_pending);
25796 link(mp->last_pending)=null;
25800 @ @<Complain about improper special operation@>=
25802 exp_err("Unsuitable expression");
25803 help1("Only known strings are allowed for output as specials.");
25804 mp_put_get_error(mp);
25807 @ On the export side, we need an extra object type for special strings.
25809 @<Graphical object codes@>=
25812 @ @<Export pending specials@>=
25814 while ( p!=null ) {
25815 mp_special_object *tp;
25816 tp = (mp_special_object *)mp_new_graphic_object(mp,mp_special_code);
25817 gr_pre_script(tp) = str(value(p));
25818 if (hh->body==NULL) hh->body = (mp_graphic_object *)tp;
25819 else gr_link(hp) = (mp_graphic_object *)tp;
25820 hp = (mp_graphic_object *)tp;
25823 mp_flush_token_list(mp, link(spec_head));
25824 link(spec_head)=null;
25825 mp->last_pending=spec_head
25827 @ We are now ready for the main output procedure. Note that the |selector|
25828 setting is saved in a global variable so that |begin_diagnostic| can access it.
25830 @<Declare the \ps\ output procedures@>=
25831 void mp_ship_out (MP mp, pointer h) ;
25833 @ Once again, the |gr_XXXX| macros are defined in |mppsout.h|
25835 @d export_color(q,p)
25836 if ( color_model(p)==mp_uninitialized_model ) {
25837 gr_color_model(q) = (mp->internal[mp_default_color_model]>>16);
25838 gr_cyan_val(q) = 0;
25839 gr_magenta_val(q) = 0;
25840 gr_yellow_val(q) = 0;
25841 gr_black_val(q) = (gr_color_model(q)==mp_cmyk_model ? unity : 0);
25843 gr_color_model(q) = color_model(p);
25844 gr_cyan_val(q) = cyan_val(p);
25845 gr_magenta_val(q) = magenta_val(p);
25846 gr_yellow_val(q) = yellow_val(p);
25847 gr_black_val(q) = black_val(p);
25850 @d export_scripts(q,p)
25851 if (pre_script(p)!=null) gr_pre_script(q) = str(pre_script(p));
25852 if (post_script(p)!=null) gr_post_script(q) = str(post_script(p));
25855 struct mp_edge_object *mp_gr_export(MP mp, pointer h) {
25856 pointer p; /* the current graphical object */
25857 integer t; /* a temporary value */
25858 scaled d_width; /* the current pen width */
25859 mp_edge_object *hh; /* the first graphical object */
25860 struct mp_graphic_object *hq; /* something |hp| points to */
25861 struct mp_text_object *tt;
25862 struct mp_fill_object *tf;
25863 struct mp_stroked_object *ts;
25864 struct mp_clip_object *tc;
25865 struct mp_bounds_object *tb;
25866 struct mp_graphic_object *hp = NULL; /* the current graphical object */
25867 mp_set_bbox(mp, h, true);
25868 hh = mp_xmalloc(mp,1,sizeof(mp_edge_object));
25872 hh->_minx = minx_val(h);
25873 hh->_miny = miny_val(h);
25874 hh->_maxx = maxx_val(h);
25875 hh->_maxy = maxy_val(h);
25876 hh->_filename = mp_get_output_file_name(mp);
25877 @<Export pending specials@>;
25878 p=link(dummy_loc(h));
25879 while ( p!=null ) {
25880 hq = mp_new_graphic_object(mp,type(p));
25883 tf = (mp_fill_object *)hq;
25884 gr_pen_p(tf) = mp_export_knot_list(mp,pen_p(p));
25885 d_width = mp_get_pen_scale(mp, pen_p(p));
25886 if ((pen_p(p)==null) || pen_is_elliptical(pen_p(p))) {
25887 gr_path_p(tf) = mp_export_knot_list(mp,path_p(p));
25890 pc = mp_copy_path(mp, path_p(p));
25891 pp = mp_make_envelope(mp, pc, pen_p(p),ljoin_val(p),0,miterlim_val(p));
25892 gr_path_p(tf) = mp_export_knot_list(mp,pp);
25893 mp_toss_knot_list(mp, pp);
25894 pc = mp_htap_ypoc(mp, path_p(p));
25895 pp = mp_make_envelope(mp, pc, pen_p(p),ljoin_val(p),0,miterlim_val(p));
25896 gr_htap_p(tf) = mp_export_knot_list(mp,pp);
25897 mp_toss_knot_list(mp, pp);
25899 export_color(tf,p) ;
25900 export_scripts(tf,p);
25901 gr_ljoin_val(tf) = ljoin_val(p);
25902 gr_miterlim_val(tf) = miterlim_val(p);
25904 case mp_stroked_code:
25905 ts = (mp_stroked_object *)hq;
25906 gr_pen_p(ts) = mp_export_knot_list(mp,pen_p(p));
25907 d_width = mp_get_pen_scale(mp, pen_p(p));
25908 if (pen_is_elliptical(pen_p(p))) {
25909 gr_path_p(ts) = mp_export_knot_list(mp,path_p(p));
25912 pc=mp_copy_path(mp, path_p(p));
25914 if ( left_type(pc)!=mp_endpoint ) {
25915 left_type(mp_insert_knot(mp, pc,x_coord(pc),y_coord(pc)))=mp_endpoint;
25916 right_type(pc)=mp_endpoint;
25920 pc=mp_make_envelope(mp,pc,pen_p(p),ljoin_val(p),t,miterlim_val(p));
25921 gr_path_p(ts) = mp_export_knot_list(mp,pc);
25922 mp_toss_knot_list(mp, pc);
25924 export_color(ts,p) ;
25925 export_scripts(ts,p);
25926 gr_ljoin_val(ts) = ljoin_val(p);
25927 gr_miterlim_val(ts) = miterlim_val(p);
25928 gr_lcap_val(ts) = lcap_val(p);
25929 gr_dash_p(ts) = mp_export_dashes(mp,p,&d_width);
25932 tt = (mp_text_object *)hq;
25933 gr_text_p(tt) = str(text_p(p));
25934 gr_font_n(tt) = font_n(p);
25935 gr_font_name(tt) = mp_xstrdup(mp,mp->font_name[font_n(p)]);
25936 gr_font_dsize(tt) = mp->font_dsize[font_n(p)];
25937 export_color(tt,p) ;
25938 export_scripts(tt,p);
25939 gr_width_val(tt) = width_val(p);
25940 gr_height_val(tt) = height_val(p);
25941 gr_depth_val(tt) = depth_val(p);
25942 gr_tx_val(tt) = tx_val(p);
25943 gr_ty_val(tt) = ty_val(p);
25944 gr_txx_val(tt) = txx_val(p);
25945 gr_txy_val(tt) = txy_val(p);
25946 gr_tyx_val(tt) = tyx_val(p);
25947 gr_tyy_val(tt) = tyy_val(p);
25949 case mp_start_clip_code:
25950 tc = (mp_clip_object *)hq;
25951 gr_path_p(tc) = mp_export_knot_list(mp,path_p(p));
25953 case mp_start_bounds_code:
25954 tb = (mp_bounds_object *)hq;
25955 gr_path_p(tb) = mp_export_knot_list(mp,path_p(p));
25957 case mp_stop_clip_code:
25958 case mp_stop_bounds_code:
25959 /* nothing to do here */
25962 if (hh->body==NULL) hh->body=hq; else gr_link(hp) = hq;
25969 @ @<Exported function ...@>=
25970 struct mp_edge_object *mp_gr_export(MP mp, int h);
25972 @ This function is now nearly trivial.
25975 void mp_ship_out (MP mp, pointer h) { /* output edge structure |h| */
25976 integer c; /* \&{charcode} rounded to the nearest integer */
25977 c=mp_round_unscaled(mp, mp->internal[mp_char_code]);
25978 @<Begin the progress report for the output of picture~|c|@>;
25979 (mp->shipout_backend) (mp, h);
25980 @<End progress report@>;
25981 if ( mp->internal[mp_tracing_output]>0 )
25982 mp_print_edges(mp, h," (just shipped out)",true);
25985 @ @<Declarations@>=
25986 void mp_shipout_backend (MP mp, pointer h);
25989 void mp_shipout_backend (MP mp, pointer h) {
25990 mp_edge_object *hh; /* the first graphical object */
25991 hh = mp_gr_export(mp,h);
25992 (void)mp_gr_ship_out (hh,
25993 (mp->internal[mp_prologues]>>16),
25994 (mp->internal[mp_procset]>>16),
25996 mp_gr_toss_objects(hh);
25999 @ @<Exported types@>=
26000 typedef void (*mp_backend_writer)(MP, int);
26002 @ @<Option variables@>=
26003 mp_backend_writer shipout_backend;
26005 @ @<Allocate or initialize ...@>=
26006 set_callback_option(shipout_backend);
26008 @ Now that we've finished |ship_out|, let's look at the other commands
26009 by which a user can send things to the \.{GF} file.
26011 @ @<Determine if a character has been shipped out@>=
26013 mp->cur_exp=mp_round_unscaled(mp, mp->cur_exp) % 256;
26014 if ( mp->cur_exp<0 ) mp->cur_exp=mp->cur_exp+256;
26015 boolean_reset(mp->char_exists[mp->cur_exp]);
26016 mp->cur_type=mp_boolean_type;
26022 @ @<Allocate or initialize ...@>=
26023 mp_backend_initialize(mp);
26026 mp_backend_free(mp);
26029 @* \[45] Dumping and undumping the tables.
26030 After \.{INIMP} has seen a collection of macros, it
26031 can write all the necessary information on an auxiliary file so
26032 that production versions of \MP\ are able to initialize their
26033 memory at high speed. The present section of the program takes
26034 care of such output and input. We shall consider simultaneously
26035 the processes of storing and restoring,
26036 so that the inverse relation between them is clear.
26039 The global variable |mem_ident| is a string that is printed right
26040 after the |banner| line when \MP\ is ready to start. For \.{INIMP} this
26041 string says simply `\.{(INIMP)}'; for other versions of \MP\ it says,
26042 for example, `\.{(mem=plain 1990.4.14)}', showing the year,
26043 month, and day that the mem file was created. We have |mem_ident=0|
26044 before \MP's tables are loaded.
26050 mp->mem_ident=NULL;
26052 @ @<Initialize table entries...@>=
26053 mp->mem_ident=xstrdup(" (INIMP)");
26055 @ @<Declare act...@>=
26056 void mp_store_mem_file (MP mp) ;
26058 @ @c void mp_store_mem_file (MP mp) {
26059 integer k; /* all-purpose index */
26060 pointer p,q; /* all-purpose pointers */
26061 integer x; /* something to dump */
26062 four_quarters w; /* four ASCII codes */
26064 @<Create the |mem_ident|, open the mem file,
26065 and inform the user that dumping has begun@>;
26066 @<Dump constants for consistency check@>;
26067 @<Dump the string pool@>;
26068 @<Dump the dynamic memory@>;
26069 @<Dump the table of equivalents and the hash table@>;
26070 @<Dump a few more things and the closing check word@>;
26071 @<Close the mem file@>;
26074 @ Corresponding to the procedure that dumps a mem file, we also have a function
26075 that reads~one~in. The function returns |false| if the dumped mem is
26076 incompatible with the present \MP\ table sizes, etc.
26078 @d off_base 6666 /* go here if the mem file is unacceptable */
26079 @d too_small(A) { wake_up_terminal;
26080 wterm_ln("---! Must increase the "); wterm((A));
26081 @.Must increase the x@>
26086 boolean mp_load_mem_file (MP mp) {
26087 integer k; /* all-purpose index */
26088 pointer p,q; /* all-purpose pointers */
26089 integer x; /* something undumped */
26090 str_number s; /* some temporary string */
26091 four_quarters w; /* four ASCII codes */
26093 @<Undump constants for consistency check@>;
26094 @<Undump the string pool@>;
26095 @<Undump the dynamic memory@>;
26096 @<Undump the table of equivalents and the hash table@>;
26097 @<Undump a few more things and the closing check word@>;
26098 return true; /* it worked! */
26101 wterm_ln("(Fatal mem file error; I'm stymied)\n");
26102 @.Fatal mem file error@>
26106 @ @<Declarations@>=
26107 boolean mp_load_mem_file (MP mp) ;
26109 @ Mem files consist of |memory_word| items, and we use the following
26110 macros to dump words of different types:
26112 @d dump_wd(A) { WW=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
26113 @d dump_int(A) { int cint=(A); (mp->write_binary_file)(mp,mp->mem_file,&cint,sizeof(cint)); }
26114 @d dump_hh(A) { WW.hh=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
26115 @d dump_qqqq(A) { WW.qqqq=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
26116 @d dump_string(A) { dump_int(strlen(A)+1);
26117 (mp->write_binary_file)(mp,mp->mem_file,A,strlen(A)+1); }
26120 void * mem_file; /* for input or output of mem information */
26122 @ The inverse macros are slightly more complicated, since we need to check
26123 the range of the values we are reading in. We say `|undump(a)(b)(x)|' to
26124 read an integer value |x| that is supposed to be in the range |a<=x<=b|.
26127 size_t wanted = sizeof(A);
26129 (mp->read_binary_file)(mp, mp->mem_file,&A_ptr,&wanted);
26130 if (wanted!=sizeof(A)) goto OFF_BASE;
26134 size_t wanted = sizeof(A);
26136 (mp->read_binary_file)(mp, mp->mem_file,&A_ptr,&wanted);
26137 if (wanted!=sizeof(A)) goto OFF_BASE;
26140 @d undump_wd(A) { mgetw(WW); A=WW; }
26141 @d undump_int(A) { int cint; mgeti(cint); A=cint; }
26142 @d undump_hh(A) { mgetw(WW); A=WW.hh; }
26143 @d undump_qqqq(A) { mgetw(WW); A=WW.qqqq; }
26144 @d undump_strings(A,B,C) {
26145 undump_int(x); if ( (x<(A)) || (x>(B)) ) goto OFF_BASE; else C=str(x); }
26146 @d undump(A,B,C) { undump_int(x); if ( (x<(A)) || (x>(int)(B)) ) goto OFF_BASE; else C=x; }
26147 @d undump_size(A,B,C,D) { undump_int(x);
26148 if (x<(A)) goto OFF_BASE;
26149 if (x>(B)) { too_small((C)); } else { D=x;} }
26150 @d undump_string(A) do {
26156 the_string = xmalloc(XX,sizeof(char));
26157 (mp->read_binary_file)(mp,mp->mem_file,&the_string,&the_wanted);
26158 A = (char *)the_string;
26159 if (the_wanted!=(size_t)XX) goto OFF_BASE;
26162 @ The next few sections of the program should make it clear how we use the
26163 dump/undump macros.
26165 @<Dump constants for consistency check@>=
26166 dump_int(mp->mem_top);
26167 dump_int(mp->hash_size);
26168 dump_int(mp->hash_prime)
26169 dump_int(mp->param_size);
26170 dump_int(mp->max_in_open);
26172 @ Sections of a \.{WEB} program that are ``commented out'' still contribute
26173 strings to the string pool; therefore \.{INIMP} and \MP\ will have
26174 the same strings. (And it is, of course, a good thing that they do.)
26178 @<Undump constants for consistency check@>=
26179 undump_int(x); mp->mem_top = x;
26180 undump_int(x); if (mp->hash_size != x) goto OFF_BASE;
26181 undump_int(x); if (mp->hash_prime != x) goto OFF_BASE;
26182 undump_int(x); if (mp->param_size != x) goto OFF_BASE;
26183 undump_int(x); if (mp->max_in_open != x) goto OFF_BASE
26185 @ We do string pool compaction to avoid dumping unused strings.
26188 w.b0=qi(mp->str_pool[k]); w.b1=qi(mp->str_pool[k+1]);
26189 w.b2=qi(mp->str_pool[k+2]); w.b3=qi(mp->str_pool[k+3]);
26192 @<Dump the string pool@>=
26193 mp_do_compaction(mp, mp->pool_size);
26194 dump_int(mp->pool_ptr);
26195 dump_int(mp->max_str_ptr);
26196 dump_int(mp->str_ptr);
26198 while ( (mp->next_str[k]==k+1) && (k<=mp->max_str_ptr) )
26201 while ( k<=mp->max_str_ptr ) {
26202 dump_int(mp->next_str[k]); incr(k);
26206 dump_int(mp->str_start[k]); /* TODO: valgrind warning here */
26207 if ( k==mp->str_ptr ) {
26214 while (k+4<mp->pool_ptr ) {
26215 dump_four_ASCII; k=k+4;
26217 k=mp->pool_ptr-4; dump_four_ASCII;
26218 mp_print_ln(mp); mp_print(mp, "at most "); mp_print_int(mp, mp->max_str_ptr);
26219 mp_print(mp, " strings of total length ");
26220 mp_print_int(mp, mp->pool_ptr)
26222 @ @d undump_four_ASCII
26224 mp->str_pool[k]=qo(w.b0); mp->str_pool[k+1]=qo(w.b1);
26225 mp->str_pool[k+2]=qo(w.b2); mp->str_pool[k+3]=qo(w.b3)
26227 @<Undump the string pool@>=
26228 undump_int(mp->pool_ptr);
26229 mp_reallocate_pool(mp, mp->pool_ptr) ;
26230 undump_int(mp->max_str_ptr);
26231 mp_reallocate_strings (mp,mp->max_str_ptr) ;
26232 undump(0,mp->max_str_ptr,mp->str_ptr);
26233 undump(0,mp->max_str_ptr+1,s);
26234 for (k=0;k<=s-1;k++)
26235 mp->next_str[k]=k+1;
26236 for (k=s;k<=mp->max_str_ptr;k++)
26237 undump(s+1,mp->max_str_ptr+1,mp->next_str[k]);
26238 mp->fixed_str_use=0;
26241 undump(0,mp->pool_ptr,mp->str_start[k]);
26242 if ( k==mp->str_ptr ) break;
26243 mp->str_ref[k]=max_str_ref;
26244 incr(mp->fixed_str_use);
26245 mp->last_fixed_str=k; k=mp->next_str[k];
26248 while ( k+4<mp->pool_ptr ) {
26249 undump_four_ASCII; k=k+4;
26251 k=mp->pool_ptr-4; undump_four_ASCII;
26252 mp->init_str_use=mp->fixed_str_use; mp->init_pool_ptr=mp->pool_ptr;
26253 mp->max_pool_ptr=mp->pool_ptr;
26254 mp->strs_used_up=mp->fixed_str_use;
26255 mp->pool_in_use=mp->str_start[mp->str_ptr]; mp->strs_in_use=mp->fixed_str_use;
26256 mp->max_pl_used=mp->pool_in_use; mp->max_strs_used=mp->strs_in_use;
26257 mp->pact_count=0; mp->pact_chars=0; mp->pact_strs=0;
26259 @ By sorting the list of available spaces in the variable-size portion of
26260 |mem|, we are usually able to get by without having to dump very much
26261 of the dynamic memory.
26263 We recompute |var_used| and |dyn_used|, so that \.{INIMP} dumps valid
26264 information even when it has not been gathering statistics.
26266 @<Dump the dynamic memory@>=
26267 mp_sort_avail(mp); mp->var_used=0;
26268 dump_int(mp->lo_mem_max); dump_int(mp->rover);
26269 p=0; q=mp->rover; x=0;
26271 for (k=p;k<= q+1;k++)
26272 dump_wd(mp->mem[k]);
26273 x=x+q+2-p; mp->var_used=mp->var_used+q-p;
26274 p=q+node_size(q); q=rlink(q);
26275 } while (q!=mp->rover);
26276 mp->var_used=mp->var_used+mp->lo_mem_max-p;
26277 mp->dyn_used=mp->mem_end+1-mp->hi_mem_min;
26278 for (k=p;k<= mp->lo_mem_max;k++ )
26279 dump_wd(mp->mem[k]);
26280 x=x+mp->lo_mem_max+1-p;
26281 dump_int(mp->hi_mem_min); dump_int(mp->avail);
26282 for (k=mp->hi_mem_min;k<=mp->mem_end;k++ )
26283 dump_wd(mp->mem[k]);
26284 x=x+mp->mem_end+1-mp->hi_mem_min;
26286 while ( p!=null ) {
26287 decr(mp->dyn_used); p=link(p);
26289 dump_int(mp->var_used); dump_int(mp->dyn_used);
26290 mp_print_ln(mp); mp_print_int(mp, x);
26291 mp_print(mp, " memory locations dumped; current usage is ");
26292 mp_print_int(mp, mp->var_used); mp_print_char(mp, '&'); mp_print_int(mp, mp->dyn_used)
26294 @ @<Undump the dynamic memory@>=
26295 undump(lo_mem_stat_max+1000,hi_mem_stat_min-1,mp->lo_mem_max);
26296 undump(lo_mem_stat_max+1,mp->lo_mem_max,mp->rover);
26299 for (k=p;k<= q+1; k++)
26300 undump_wd(mp->mem[k]);
26302 if ( (p>mp->lo_mem_max)||((q>=rlink(q))&&(rlink(q)!=mp->rover)) )
26305 } while (q!=mp->rover);
26306 for (k=p;k<=mp->lo_mem_max;k++ )
26307 undump_wd(mp->mem[k]);
26308 undump(mp->lo_mem_max+1,hi_mem_stat_min,mp->hi_mem_min);
26309 undump(null,mp->mem_top,mp->avail); mp->mem_end=mp->mem_top;
26310 mp->last_pending=spec_head;
26311 for (k=mp->hi_mem_min;k<= mp->mem_end;k++)
26312 undump_wd(mp->mem[k]);
26313 undump_int(mp->var_used); undump_int(mp->dyn_used)
26315 @ A different scheme is used to compress the hash table, since its lower region
26316 is usually sparse. When |text(p)<>0| for |p<=hash_used|, we output three
26317 words: |p|, |hash[p]|, and |eqtb[p]|. The hash table is, of course, densely
26318 packed for |p>=hash_used|, so the remaining entries are output in~a~block.
26320 @<Dump the table of equivalents and the hash table@>=
26321 dump_int(mp->hash_used);
26322 mp->st_count=frozen_inaccessible-1-mp->hash_used;
26323 for (p=1;p<=mp->hash_used;p++) {
26324 if ( text(p)!=0 ) {
26325 dump_int(p); dump_hh(mp->hash[p]); dump_hh(mp->eqtb[p]); incr(mp->st_count);
26328 for (p=mp->hash_used+1;p<=(int)hash_end;p++) {
26329 dump_hh(mp->hash[p]); dump_hh(mp->eqtb[p]);
26331 dump_int(mp->st_count);
26332 mp_print_ln(mp); mp_print_int(mp, mp->st_count); mp_print(mp, " symbolic tokens")
26334 @ @<Undump the table of equivalents and the hash table@>=
26335 undump(1,frozen_inaccessible,mp->hash_used);
26338 undump(p+1,mp->hash_used,p);
26339 undump_hh(mp->hash[p]); undump_hh(mp->eqtb[p]);
26340 } while (p!=mp->hash_used);
26341 for (p=mp->hash_used+1;p<=(int)hash_end;p++ ) {
26342 undump_hh(mp->hash[p]); undump_hh(mp->eqtb[p]);
26344 undump_int(mp->st_count)
26346 @ We have already printed a lot of statistics, so we set |mp_tracing_stats:=0|
26347 to prevent them appearing again.
26349 @<Dump a few more things and the closing check word@>=
26350 dump_int(mp->max_internal);
26351 dump_int(mp->int_ptr);
26352 for (k=1;k<= mp->int_ptr;k++ ) {
26353 dump_int(mp->internal[k]);
26354 dump_string(mp->int_name[k]);
26356 dump_int(mp->start_sym);
26357 dump_int(mp->interaction);
26358 dump_string(mp->mem_ident);
26359 dump_int(mp->bg_loc); dump_int(mp->eg_loc); dump_int(mp->serial_no); dump_int(69073);
26360 mp->internal[mp_tracing_stats]=0
26362 @ @<Undump a few more things and the closing check word@>=
26364 if (x>mp->max_internal) mp_grow_internals(mp,x);
26365 undump_int(mp->int_ptr);
26366 for (k=1;k<= mp->int_ptr;k++) {
26367 undump_int(mp->internal[k]);
26368 undump_string(mp->int_name[k]);
26370 undump(0,frozen_inaccessible,mp->start_sym);
26371 if (mp->interaction==mp_unspecified_mode) {
26372 undump(mp_unspecified_mode,mp_error_stop_mode,mp->interaction);
26374 undump(mp_unspecified_mode,mp_error_stop_mode,x);
26376 undump_string(mp->mem_ident);
26377 undump(1,hash_end,mp->bg_loc);
26378 undump(1,hash_end,mp->eg_loc);
26379 undump_int(mp->serial_no);
26381 if (x!=69073) goto OFF_BASE
26383 @ @<Create the |mem_ident|...@>=
26385 xfree(mp->mem_ident);
26386 mp->mem_ident = xmalloc(256,1);
26387 char *tmp = xmalloc(11,1);
26388 sprintf(tmp,"%04d.%02d.%02d",
26389 (int)mp_round_unscaled(mp, mp->internal[mp_year]),
26390 (int)mp_round_unscaled(mp, mp->internal[mp_month]),
26391 (int)mp_round_unscaled(mp, mp->internal[mp_day]));
26392 mp_snprintf(mp->mem_ident,256," (mem=%s %s)",mp->job_name, tmp);
26394 mp_pack_job_name(mp, mem_extension);
26395 while (! mp_w_open_out(mp, &mp->mem_file) )
26396 mp_prompt_file_name(mp, "mem file name", mem_extension);
26397 mp_print_nl(mp, "Beginning to dump on file ");
26398 @.Beginning to dump...@>
26399 mp_print(mp, mp->name_of_file);
26400 mp_print_nl(mp, mp->mem_ident);
26403 @ @<Dealloc variables@>=
26404 xfree(mp->mem_ident);
26406 @ @<Close the mem file@>=
26407 (mp->close_file)(mp,mp->mem_file)
26409 @* \[46] The main program.
26410 This is it: the part of \MP\ that executes all those procedures we have
26413 Well---almost. We haven't put the parsing subroutines into the
26414 program yet; and we'd better leave space for a few more routines that may
26415 have been forgotten.
26417 @c @<Declare the basic parsing subroutines@>
26418 @<Declare miscellaneous procedures that were declared |forward|@>
26419 @<Last-minute procedures@>
26421 @ We've noted that there are two versions of \MP. One, called \.{INIMP},
26423 has to be run first; it initializes everything from scratch, without
26424 reading a mem file, and it has the capability of dumping a mem file.
26425 The other one is called `\.{VIRMP}'; it is a ``virgin'' program that needs
26427 to input a mem file in order to get started. \.{VIRMP} typically has
26428 a bit more memory capacity than \.{INIMP}, because it does not need the
26429 space consumed by the dumping/undumping routines and the numerous calls on
26432 The \.{VIRMP} program cannot read a mem file instantaneously, of course;
26433 the best implementations therefore allow for production versions of \MP\ that
26434 not only avoid the loading routine for object code, they also have
26435 a mem file pre-loaded.
26437 @ @<Option variables@>=
26438 int ini_version; /* are we iniMP? */
26440 @ @<Set |ini_version|@>=
26441 mp->ini_version = (opt->ini_version ? true : false);
26443 @ Here we do whatever is needed to complete \MP's job gracefully on the
26444 local operating system. The code here might come into play after a fatal
26445 error; it must therefore consist entirely of ``safe'' operations that
26446 cannot produce error messages. For example, it would be a mistake to call
26447 |str_room| or |make_string| at this time, because a call on |overflow|
26448 might lead to an infinite loop.
26449 @^system dependencies@>
26451 This program doesn't bother to close the input files that may still be open.
26454 boolean finished; /* set true by |close_files_and_terminate| */
26456 @ @<Set initial ...@>=
26457 mp->finished=false;
26459 @ @<Last-minute...@>=
26460 void mp_close_files_and_terminate (MP mp) {
26461 integer k; /* all-purpose index */
26462 integer LH; /* the length of the \.{TFM} header, in words */
26463 int lk_offset; /* extra words inserted at beginning of |lig_kern| array */
26464 pointer p; /* runs through a list of \.{TFM} dimensions */
26465 @<Close all open files in the |rd_file| and |wr_file| arrays@>;
26466 if ( mp->internal[mp_tracing_stats]>0 )
26467 @<Output statistics about this job@>;
26469 @<Do all the finishing work on the \.{TFM} file@>;
26470 @<Explain what output files were written@>;
26471 if ( mp->log_opened && ! mp->noninteractive ){
26473 (mp->close_file)(mp,mp->log_file);
26474 mp->selector=mp->selector-2;
26475 if ( mp->selector==term_only ) {
26476 mp_print_nl(mp, "Transcript written on ");
26477 @.Transcript written...@>
26478 mp_print(mp, mp->log_name); mp_print_char(mp, '.');
26482 mp->finished = true;
26485 @ @<Declarations@>=
26486 void mp_close_files_and_terminate (MP mp) ;
26488 @ @<Close all open files in the |rd_file| and |wr_file| arrays@>=
26489 if (mp->rd_fname!=NULL) {
26490 for (k=0;k<=(int)mp->read_files-1;k++ ) {
26491 if ( mp->rd_fname[k]!=NULL ) {
26492 (mp->close_file)(mp,mp->rd_file[k]);
26493 xfree(mp->rd_fname[k]);
26497 if (mp->wr_fname!=NULL) {
26498 for (k=0;k<=(int)mp->write_files-1;k++) {
26499 if ( mp->wr_fname[k]!=NULL ) {
26500 (mp->close_file)(mp,mp->wr_file[k]);
26501 xfree(mp->wr_fname[k]);
26507 for (k=0;k<(int)mp->max_read_files;k++ ) {
26508 if ( mp->rd_fname[k]!=NULL ) {
26509 (mp->close_file)(mp,mp->rd_file[k]);
26510 xfree(mp->rd_fname[k]);
26513 xfree(mp->rd_file);
26514 xfree(mp->rd_fname);
26515 for (k=0;k<(int)mp->max_write_files;k++) {
26516 if ( mp->wr_fname[k]!=NULL ) {
26517 (mp->close_file)(mp,mp->wr_file[k]);
26518 xfree(mp->wr_fname[k]);
26521 xfree(mp->wr_file);
26522 xfree(mp->wr_fname);
26525 @ We want to produce a \.{TFM} file if and only if |mp_fontmaking| is positive.
26527 We reclaim all of the variable-size memory at this point, so that
26528 there is no chance of another memory overflow after the memory capacity
26529 has already been exceeded.
26531 @<Do all the finishing work on the \.{TFM} file@>=
26532 if ( mp->internal[mp_fontmaking]>0 ) {
26533 @<Make the dynamic memory into one big available node@>;
26534 @<Massage the \.{TFM} widths@>;
26535 mp_fix_design_size(mp); mp_fix_check_sum(mp);
26536 @<Massage the \.{TFM} heights, depths, and italic corrections@>;
26537 mp->internal[mp_fontmaking]=0; /* avoid loop in case of fatal error */
26538 @<Finish the \.{TFM} file@>;
26541 @ @<Make the dynamic memory into one big available node@>=
26542 mp->rover=lo_mem_stat_max+1; link(mp->rover)=empty_flag; mp->lo_mem_max=mp->hi_mem_min-1;
26543 if ( mp->lo_mem_max-mp->rover>max_halfword ) mp->lo_mem_max=max_halfword+mp->rover;
26544 node_size(mp->rover)=mp->lo_mem_max-mp->rover;
26545 llink(mp->rover)=mp->rover; rlink(mp->rover)=mp->rover;
26546 link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null
26548 @ The present section goes directly to the log file instead of using
26549 |print| commands, because there's no need for these strings to take
26550 up |str_pool| memory when a non-{\bf stat} version of \MP\ is being used.
26552 @<Output statistics...@>=
26553 if ( mp->log_opened ) {
26556 wlog_ln("Here is how much of MetaPost's memory you used:");
26557 @.Here is how much...@>
26558 mp_snprintf(s,128," %i string%s out of %i",(int)mp->max_strs_used-mp->init_str_use,
26559 (mp->max_strs_used!=mp->init_str_use+1 ? "s" : ""),
26560 (int)(mp->max_strings-1-mp->init_str_use));
26562 mp_snprintf(s,128," %i string characters out of %i",
26563 (int)mp->max_pl_used-mp->init_pool_ptr,
26564 (int)mp->pool_size-mp->init_pool_ptr);
26566 mp_snprintf(s,128," %i words of memory out of %i",
26567 (int)mp->lo_mem_max+mp->mem_end-mp->hi_mem_min+2,
26570 mp_snprintf(s,128," %i symbolic tokens out of %i", (int)mp->st_count, (int)mp->hash_size);
26572 mp_snprintf(s,128," %ii,%in,%ip,%ib stack positions out of %ii,%in,%ip,%ib",
26573 (int)mp->max_in_stack,(int)mp->int_ptr,
26574 (int)mp->max_param_stack,(int)mp->max_buf_stack+1,
26575 (int)mp->stack_size,(int)mp->max_internal,(int)mp->param_size,(int)mp->buf_size);
26577 mp_snprintf(s,128," %i string compactions (moved %i characters, %i strings)",
26578 (int)mp->pact_count,(int)mp->pact_chars,(int)mp->pact_strs);
26582 @ It is nice to have have some of the stats available from the API.
26584 @<Exported function ...@>=
26585 int mp_memory_usage (MP mp );
26586 int mp_hash_usage (MP mp );
26587 int mp_param_usage (MP mp );
26588 int mp_open_usage (MP mp );
26591 int mp_memory_usage (MP mp ) {
26592 return (int)mp->lo_mem_max+mp->mem_end-mp->hi_mem_min+2;
26594 int mp_hash_usage (MP mp ) {
26595 return (int)mp->st_count;
26597 int mp_param_usage (MP mp ) {
26598 return (int)mp->max_param_stack;
26600 int mp_open_usage (MP mp ) {
26601 return (int)mp->max_in_stack;
26604 @ We get to the |final_cleanup| routine when \&{end} or \&{dump} has
26607 @<Last-minute...@>=
26608 void mp_final_cleanup (MP mp) {
26609 small_number c; /* 0 for \&{end}, 1 for \&{dump} */
26611 if ( mp->job_name==NULL ) mp_open_log_file(mp);
26612 while ( mp->input_ptr>0 ) {
26613 if ( token_state ) mp_end_token_list(mp);
26614 else mp_end_file_reading(mp);
26616 while ( mp->loop_ptr!=null ) mp_stop_iteration(mp);
26617 while ( mp->open_parens>0 ) {
26618 mp_print(mp, " )"); decr(mp->open_parens);
26620 while ( mp->cond_ptr!=null ) {
26621 mp_print_nl(mp, "(end occurred when ");
26622 @.end occurred...@>
26623 mp_print_cmd_mod(mp, fi_or_else,mp->cur_if);
26624 /* `\.{if}' or `\.{elseif}' or `\.{else}' */
26625 if ( mp->if_line!=0 ) {
26626 mp_print(mp, " on line "); mp_print_int(mp, mp->if_line);
26628 mp_print(mp, " was incomplete)");
26629 mp->if_line=if_line_field(mp->cond_ptr);
26630 mp->cur_if=name_type(mp->cond_ptr); mp->cond_ptr=link(mp->cond_ptr);
26632 if ( mp->history!=mp_spotless )
26633 if ( ((mp->history==mp_warning_issued)||(mp->interaction<mp_error_stop_mode)) )
26634 if ( mp->selector==term_and_log ) {
26635 mp->selector=term_only;
26636 mp_print_nl(mp, "(see the transcript file for additional information)");
26637 @.see the transcript file...@>
26638 mp->selector=term_and_log;
26641 if (mp->ini_version) {
26642 mp_store_mem_file(mp); return;
26644 mp_print_nl(mp, "(dump is performed only by INIMP)"); return;
26645 @.dump...only by INIMP@>
26649 @ @<Declarations@>=
26650 void mp_final_cleanup (MP mp) ;
26651 void mp_init_prim (MP mp) ;
26652 void mp_init_tab (MP mp) ;
26654 @ @<Last-minute...@>=
26655 void mp_init_prim (MP mp) { /* initialize all the primitives */
26659 void mp_init_tab (MP mp) { /* initialize other tables */
26660 integer k; /* all-purpose index */
26661 @<Initialize table entries (done by \.{INIMP} only)@>;
26665 @ When we begin the following code, \MP's tables may still contain garbage;
26666 thus we must proceed cautiously to get bootstrapped in.
26668 But when we finish this part of the program, \MP\ is ready to call on the
26669 |main_control| routine to do its work.
26671 @<Get the first line...@>=
26673 @<Initialize the input routines@>;
26674 if ( (mp->mem_ident==NULL)||(mp->buffer[loc]=='&') ) {
26675 if ( mp->mem_ident!=NULL ) {
26676 mp_do_initialize(mp); /* erase preloaded mem */
26678 if ( ! mp_open_mem_file(mp) ) {
26679 mp->history = mp_fatal_error_stop;
26682 if ( ! mp_load_mem_file(mp) ) {
26683 (mp->close_file)(mp, mp->mem_file);
26684 mp->history = mp_fatal_error_stop;
26687 (mp->close_file)(mp, mp->mem_file);
26688 while ( (loc<limit)&&(mp->buffer[loc]==' ') ) incr(loc);
26690 @<Initializations following first line@>;
26693 @ @<Initializations following first line@>=
26694 mp->buffer[limit]='%';
26695 mp_fix_date_and_time(mp);
26696 if (mp->random_seed==0)
26697 mp->random_seed = (mp->internal[mp_time] / unity)+mp->internal[mp_day];
26698 mp_init_randoms(mp, mp->random_seed);
26699 @<Initialize the print |selector|...@>;
26700 if ( loc<limit ) if ( mp->buffer[loc]!='\\' )
26701 mp_start_input(mp); /* \&{input} assumed */
26703 @ @<Run inimpost commands@>=
26705 mp_get_strings_started(mp);
26706 mp_init_tab(mp); /* initialize the tables */
26707 mp_init_prim(mp); /* call |primitive| for each primitive */
26708 mp->init_str_use=mp->str_ptr; mp->init_pool_ptr=mp->pool_ptr;
26709 mp->max_str_ptr=mp->str_ptr; mp->max_pool_ptr=mp->pool_ptr;
26710 mp_fix_date_and_time(mp);
26713 @ Saving the filename template
26715 @<Save the filename template@>=
26717 if ( mp->filename_template!=0 ) delete_str_ref(mp->filename_template);
26718 if ( length(mp->cur_exp)==0 ) mp->filename_template=0;
26720 mp->filename_template=mp->cur_exp; add_str_ref(mp->filename_template);
26724 @* \[47] Debugging.
26727 @* \[48] System-dependent changes.
26728 This section should be replaced, if necessary, by any special
26729 modification of the program
26730 that are necessary to make \MP\ work at a particular installation.
26731 It is usually best to design your change file so that all changes to
26732 previous sections preserve the section numbering; then everybody's version
26733 will be consistent with the published program. More extensive changes,
26734 which introduce new sections, can be inserted here; then only the index
26735 itself will get a new section number.
26736 @^system dependencies@>
26739 Here is where you can find all uses of each identifier in the program,
26740 with underlined entries pointing to where the identifier was defined.
26741 If the identifier is only one letter long, however, you get to see only
26742 the underlined entries. {\sl All references are to section numbers instead of
26745 This index also lists error messages and other aspects of the program
26746 that you might want to look up some day. For example, the entry
26747 for ``system dependencies'' lists all sections that should receive
26748 special attention from people who are installing \MP\ in a new
26749 operating environment. A list of various things that can't happen appears
26750 under ``this can't happen''.
26751 Approximately 25 sections are listed under ``inner loop''; these account
26752 for more than 60\pct! of \MP's running time, exclusive of input and output.