1 % $Id: mp.w 1299 2008-05-28 14:09:04Z taco $
2 % MetaPost, by John Hobby. Public domain.
4 % Much of this program was copied with permission from MF.web Version 1.9
5 % It interprets a language very similar to D.E. Knuth's METAFONT, but with
6 % changes designed to make it more suitable for PostScript output.
8 % TeX is a trademark of the American Mathematical Society.
9 % METAFONT is a trademark of Addison-Wesley Publishing Company.
10 % PostScript is a trademark of Adobe Systems Incorporated.
12 % Here is TeX material that gets inserted after \input webmac
13 \def\hang{\hangindent 3em\noindent\ignorespaces}
14 \def\textindent#1{\hangindent2.5em\noindent\hbox to2.5em{\hss#1 }\ignorespaces}
16 \def\psqrt#1{\sqrt{\mathstrut#1}}
18 \def\pct!{{\char`\%}} % percent sign in ordinary text
19 \font\tenlogo=logo10 % font used for the METAFONT logo
21 \def\MF{{\tenlogo META}\-{\tenlogo FONT}}
22 \def\MP{{\tenlogo META}\-{\tenlogo POST}}
23 \def\[#1]{\ignorespaces} % left over from pascal web
24 \def\<#1>{$\langle#1\rangle$}
25 \def\section{\mathhexbox278}
26 \let\swap=\leftrightarrow
27 \def\round{\mathop{\rm round}\nolimits}
28 \mathchardef\vb="026A % synonym for `\|'
30 \def\(#1){} % this is used to make section names sort themselves better
31 \def\9#1{} % this is used for sort keys in the index via @@:sort key}{entry@@>
38 This is \MP, a graphics-language processor based on D. E. Knuth's \MF.
40 The main purpose of the following program is to explain the algorithms of \MP\
41 as clearly as possible. However, the program has been written so that it
42 can be tuned to run efficiently in a wide variety of operating environments
43 by making comparatively few changes. Such flexibility is possible because
44 the documentation that follows is written in the \.{WEB} language, which is
45 at a higher level than C.
47 A large piece of software like \MP\ has inherent complexity that cannot
48 be reduced below a certain level of difficulty, although each individual
49 part is fairly simple by itself. The \.{WEB} language is intended to make
50 the algorithms as readable as possible, by reflecting the way the
51 individual program pieces fit together and by providing the
52 cross-references that connect different parts. Detailed comments about
53 what is going on, and about why things were done in certain ways, have
54 been liberally sprinkled throughout the program. These comments explain
55 features of the implementation, but they rarely attempt to explain the
56 \MP\ language itself, since the reader is supposed to be familiar with
57 {\sl The {\logos METAFONT\/}book} as well as the manual
59 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
60 {\sl A User's Manual for MetaPost}, Computing Science Technical Report 162,
61 AT\AM T Bell Laboratories.
63 @ The present implementation is a preliminary version, but the possibilities
64 for new features are limited by the desire to remain as nearly compatible
65 with \MF\ as possible.
67 On the other hand, the \.{WEB} description can be extended without changing
68 the core of the program, and it has been designed so that such
69 extensions are not extremely difficult to make.
70 The |banner| string defined here should be changed whenever \MP\
71 undergoes any modifications, so that it will be clear which version of
72 \MP\ might be the guilty party when a problem arises.
74 @^system dependencies@>
76 @d banner "This is MetaPost, Version 1.060" /* printed when \MP\ starts */
77 @d metapost_version "1.060"
78 @d mplib_version "0.60"
79 @d version_string " (Cweb version)"
84 @ The external library header for \MP\ is |mplib.h|. It contains a
85 few typedefs and the header defintions for the externally used
88 The most important of the typedefs is the definition of the structure
89 |MP_options|, that acts as a small, configurable front-end to the fairly
90 large |MP_instance| structure.
93 typedef struct MP_instance * MP;
95 typedef struct MP_options {
98 @<Exported function headers@>
100 @ The internal header file is much longer: it not only lists the complete
101 |MP_instance|, but also a lot of functions that have to be available to
102 the \ps\ backend, that is defined in a separate \.{WEB} file.
104 The variables from |MP_options| are included inside the |MP_instance|
109 typedef struct psout_data_struct * psout_data;
111 typedef signed int integer;
113 @<Types in the outer block@>
114 @<Constants in the outer block@>
115 # ifndef LIBAVL_ALLOCATOR
116 # define LIBAVL_ALLOCATOR
117 struct libavl_allocator {
118 void *(*libavl_malloc) (struct libavl_allocator *, size_t libavl_size);
119 void (*libavl_free) (struct libavl_allocator *, void *libavl_block);
122 typedef struct MP_instance {
126 @<Internal library declarations@>
135 #include <unistd.h> /* for access() */
136 #include <time.h> /* for struct tm \& co */
138 #include "mpmp.h" /* internal header */
139 #include "mppsout.h" /* internal header */
142 @<Basic printing procedures@>
143 @<Error handling procedures@>
145 @ Here are the functions that set up the \MP\ instance.
148 @<Declare |mp_reallocate| functions@>
149 struct MP_options *mp_options (void);
150 MP mp_new (struct MP_options *opt);
153 struct MP_options *mp_options (void) {
154 struct MP_options *opt;
155 opt = malloc(sizeof(MP_options));
157 memset (opt,0,sizeof(MP_options));
162 @ The |__attribute__| pragma is gcc-only.
164 @<Internal library ... @>=
165 #if !defined(__GNUC__) || (__GNUC__ < 2)
166 # define __attribute__(x)
167 #endif /* !defined(__GNUC__) || (__GNUC__ < 2) */
170 MP __attribute__ ((noinline))
171 mp_do_new (struct MP_options *opt, jmp_buf *buf) {
172 MP mp = malloc(sizeof(MP_instance));
176 @<Set |ini_version|@>;
177 @<Allocate or initialize variables@>
178 if (opt->main_memory>mp->mem_max)
179 mp_reallocate_memory(mp,opt->main_memory);
180 mp_reallocate_paths(mp,1000);
181 mp_reallocate_fonts(mp,8);
184 MP __attribute__ ((noinline))
185 mp_new (struct MP_options *opt) {
187 @<Setup the non-local jump buffer in |mp_new|@>;
188 return mp_do_new(opt, &buf);
193 void mp_free (MP mp) {
194 int k; /* loop variable */
195 @<Dealloc variables@>
200 void __attribute__((noinline))
201 mp_do_initialize ( MP mp) {
202 @<Local variables for initialization@>
203 @<Set initial values of key variables@>
205 int mp_initialize (MP mp) { /* this procedure gets things started properly */
206 mp->history=mp_fatal_error_stop; /* in case we quit during initialization */
208 @<Install and test the non-local jump buffer@>;
209 t_open_out; /* open the terminal for output */
210 @<Check the ``constant'' values...@>;
213 mp_snprintf(ss,256,"Ouch---my internal constants have been clobbered!\n"
214 "---case %i",(int)mp->bad);
215 do_fprintf(mp->err_out,(char *)ss);
219 mp_do_initialize(mp); /* erase preloaded mem */
220 if (mp->ini_version) {
221 @<Run inimpost commands@>;
223 @<Initialize the output routines@>;
224 @<Get the first line of input and prepare to start@>;
226 mp_init_map_file(mp, mp->troff_mode);
227 mp->history=mp_spotless; /* ready to go! */
228 if (mp->troff_mode) {
229 mp->internal[mp_gtroffmode]=unity;
230 mp->internal[mp_prologues]=unity;
232 if ( mp->start_sym>0 ) { /* insert the `\&{everyjob}' symbol */
233 mp->cur_sym=mp->start_sym; mp_back_input(mp);
239 @<Exported function headers@>=
240 extern struct MP_options *mp_options (void);
241 extern MP mp_new (struct MP_options *opt) ;
242 extern void mp_free (MP mp);
243 extern int mp_initialize (MP mp);
245 @ The overall \MP\ program begins with the heading just shown, after which
246 comes a bunch of procedure declarations and function declarations.
247 Finally we will get to the main program, which begins with the
248 comment `|start_here|'. If you want to skip down to the
249 main program now, you can look up `|start_here|' in the index.
250 But the author suggests that the best way to understand this program
251 is to follow pretty much the order of \MP's components as they appear in the
252 \.{WEB} description you are now reading, since the present ordering is
253 intended to combine the advantages of the ``bottom up'' and ``top down''
254 approaches to the problem of understanding a somewhat complicated system.
256 @ Some of the code below is intended to be used only when diagnosing the
257 strange behavior that sometimes occurs when \MP\ is being installed or
258 when system wizards are fooling around with \MP\ without quite knowing
259 what they are doing. Such code will not normally be compiled; it is
260 delimited by the preprocessor test `|#ifdef DEBUG .. #endif|'.
262 @ This program has two important variations: (1) There is a long and slow
263 version called \.{INIMP}, which does the extra calculations needed to
265 initialize \MP's internal tables; and (2)~there is a shorter and faster
266 production version, which cuts the initialization to a bare minimum.
268 Which is which is decided at runtime.
270 @ The following parameters can be changed at compile time to extend or
271 reduce \MP's capacity. They may have different values in \.{INIMP} and
272 in production versions of \MP.
274 @^system dependencies@>
277 #define file_name_size 255 /* file names shouldn't be longer than this */
278 #define bistack_size 1500 /* size of stack for bisection algorithms;
279 should probably be left at this value */
281 @ Like the preceding parameters, the following quantities can be changed
282 at compile time to extend or reduce \MP's capacity. But if they are changed,
283 it is necessary to rerun the initialization program \.{INIMP}
285 to generate new tables for the production \MP\ program.
286 One can't simply make helter-skelter changes to the following constants,
287 since certain rather complex initialization
288 numbers are computed from them.
291 int max_strings; /* maximum number of strings; must not exceed |max_halfword| */
292 int pool_size; /* maximum number of characters in strings, including all
293 error messages and help texts, and the names of all identifiers */
294 int mem_max; /* greatest index in \MP's internal |mem| array;
295 must be strictly less than |max_halfword|;
296 must be equal to |mem_top| in \.{INIMP}, otherwise |>=mem_top| */
297 int mem_top; /* largest index in the |mem| array dumped by \.{INIMP};
298 must not be greater than |mem_max| */
300 @ @<Option variables@>=
301 int error_line; /* width of context lines on terminal error messages */
302 int half_error_line; /* width of first lines of contexts in terminal
303 error messages; should be between 30 and |error_line-15| */
304 int max_print_line; /* width of longest text lines output; should be at least 60 */
305 int hash_size; /* maximum number of symbolic tokens,
306 must be less than |max_halfword-3*param_size| */
307 int hash_prime; /* a prime number equal to about 85\pct! of |hash_size| */
308 int param_size; /* maximum number of simultaneous macro parameters */
309 int max_in_open; /* maximum number of input files and error insertions that
310 can be going on simultaneously */
311 int main_memory; /* only for options, to set up |mem_max| and |mem_top| */
312 void *userdata; /* this allows the calling application to setup local */
315 @d set_value(a,b,c) do { a=c; if (b>c) a=b; } while (0)
320 set_value(mp->error_line,opt->error_line,79);
321 set_value(mp->half_error_line,opt->half_error_line,50);
322 set_value(mp->max_print_line,opt->max_print_line,100);
323 mp->main_memory=5000;
326 set_value(mp->hash_size,opt->hash_size,9500);
327 set_value(mp->hash_prime,opt->hash_prime,7919);
328 set_value(mp->param_size,opt->param_size,150);
329 set_value(mp->max_in_open,opt->max_in_open,10);
330 mp->userdata=opt->userdata;
332 @ In case somebody has inadvertently made bad settings of the ``constants,''
333 \MP\ checks them using a global variable called |bad|.
335 This is the first of many sections of \MP\ where global variables are
339 integer bad; /* is some ``constant'' wrong? */
341 @ Later on we will say `\ignorespaces|if (mem_max>=max_halfword) bad=10;|',
342 or something similar. (We can't do that until |max_halfword| has been defined.)
344 @<Check the ``constant'' values for consistency@>=
346 if ( (mp->half_error_line<30)||(mp->half_error_line>mp->error_line-15) ) mp->bad=1;
347 if ( mp->max_print_line<60 ) mp->bad=2;
348 if ( mp->mem_top<=1100 ) mp->bad=4;
349 if (mp->hash_prime>mp->hash_size ) mp->bad=5;
351 @ Some |goto| labels are used by the following definitions. The label
352 `|restart|' is occasionally used at the very beginning of a procedure; and
353 the label `|reswitch|' is occasionally used just prior to a |case|
354 statement in which some cases change the conditions and we wish to branch
355 to the newly applicable case. Loops that are set up with the |loop|
356 construction defined below are commonly exited by going to `|done|' or to
357 `|found|' or to `|not_found|', and they are sometimes repeated by going to
358 `|continue|'. If two or more parts of a subroutine start differently but
359 end up the same, the shared code may be gathered together at
362 @ Here are some macros for common programming idioms.
364 @d incr(A) (A)=(A)+1 /* increase a variable by unity */
365 @d decr(A) (A)=(A)-1 /* decrease a variable by unity */
366 @d negate(A) (A)=-(A) /* change the sign of a variable */
367 @d double(A) (A)=(A)+(A)
370 @d do_nothing /* empty statement */
371 @d Return goto exit /* terminate a procedure call */
372 @f return nil /* \.{WEB} will henceforth say |return| instead of \\{return} */
374 @* \[2] The character set.
375 In order to make \MP\ readily portable to a wide variety of
376 computers, all of its input text is converted to an internal eight-bit
377 code that includes standard ASCII, the ``American Standard Code for
378 Information Interchange.'' This conversion is done immediately when each
379 character is read in. Conversely, characters are converted from ASCII to
380 the user's external representation just before they are output to a
384 Such an internal code is relevant to users of \MP\ only with respect to
385 the \&{char} and \&{ASCII} operations, and the comparison of strings.
387 @ Characters of text that have been converted to \MP's internal form
388 are said to be of type |ASCII_code|, which is a subrange of the integers.
391 typedef unsigned char ASCII_code; /* eight-bit numbers */
393 @ The present specification of \MP\ has been written under the assumption
394 that the character set contains at least the letters and symbols associated
395 with ASCII codes 040 through 0176; all of these characters are now
396 available on most computer terminals.
398 We shall use the name |text_char| to stand for the data type of the characters
399 that are converted to and from |ASCII_code| when they are input and output.
400 We shall also assume that |text_char| consists of the elements
401 |chr(first_text_char)| through |chr(last_text_char)|, inclusive.
402 The following definitions should be adjusted if necessary.
403 @^system dependencies@>
405 @d first_text_char 0 /* ordinal number of the smallest element of |text_char| */
406 @d last_text_char 255 /* ordinal number of the largest element of |text_char| */
409 typedef unsigned char text_char; /* the data type of characters in text files */
411 @ @<Local variables for init...@>=
414 @ The \MP\ processor converts between ASCII code and
415 the user's external character set by means of arrays |xord| and |xchr|
416 that are analogous to Pascal's |ord| and |chr| functions.
418 @d xchr(A) mp->xchr[(A)]
419 @d xord(A) mp->xord[(A)]
422 ASCII_code xord[256]; /* specifies conversion of input characters */
423 text_char xchr[256]; /* specifies conversion of output characters */
425 @ The core system assumes all 8-bit is acceptable. If it is not,
426 a change file has to alter the below section.
427 @^system dependencies@>
429 Additionally, people with extended character sets can
430 assign codes arbitrarily, giving an |xchr| equivalent to whatever
431 characters the users of \MP\ are allowed to have in their input files.
432 Appropriate changes to \MP's |char_class| table should then be made.
433 (Unlike \TeX, each installation of \MP\ has a fixed assignment of category
434 codes, called the |char_class|.) Such changes make portability of programs
435 more difficult, so they should be introduced cautiously if at all.
436 @^character set dependencies@>
437 @^system dependencies@>
440 for (i=0;i<=0377;i++) { xchr(i)=i; }
442 @ The following system-independent code makes the |xord| array contain a
443 suitable inverse to the information in |xchr|. Note that if |xchr[i]=xchr[j]|
444 where |i<j<0177|, the value of |xord[xchr[i]]| will turn out to be
445 |j| or more; hence, standard ASCII code numbers will be used instead of
446 codes below 040 in case there is a coincidence.
449 for (i=first_text_char;i<=last_text_char;i++) {
452 for (i=0200;i<=0377;i++) { xord(xchr(i))=i;}
453 for (i=0;i<=0176;i++) { xord(xchr(i))=i;}
455 @* \[3] Input and output.
456 The bane of portability is the fact that different operating systems treat
457 input and output quite differently, perhaps because computer scientists
458 have not given sufficient attention to this problem. People have felt somehow
459 that input and output are not part of ``real'' programming. Well, it is true
460 that some kinds of programming are more fun than others. With existing
461 input/output conventions being so diverse and so messy, the only sources of
462 joy in such parts of the code are the rare occasions when one can find a
463 way to make the program a little less bad than it might have been. We have
464 two choices, either to attack I/O now and get it over with, or to postpone
465 I/O until near the end. Neither prospect is very attractive, so let's
468 The basic operations we need to do are (1)~inputting and outputting of
469 text, to or from a file or the user's terminal; (2)~inputting and
470 outputting of eight-bit bytes, to or from a file; (3)~instructing the
471 operating system to initiate (``open'') or to terminate (``close'') input or
472 output from a specified file; (4)~testing whether the end of an input
473 file has been reached; (5)~display of bits on the user's screen.
474 The bit-display operation will be discussed in a later section; we shall
475 deal here only with more traditional kinds of I/O.
477 @ Finding files happens in a slightly roundabout fashion: the \MP\
478 instance object contains a field that holds a function pointer that finds a
479 file, and returns its name, or NULL. For this, it receives three
480 parameters: the non-qualified name |fname|, the intended |fopen|
481 operation type |fmode|, and the type of the file |ftype|.
483 The file types that are passed on in |ftype| can be used to
484 differentiate file searches if a library like kpathsea is used,
485 the fopen mode is passed along for the same reason.
488 typedef unsigned char eight_bits ; /* unsigned one-byte quantity */
490 @ @<Exported types@>=
492 mp_filetype_terminal = 0, /* the terminal */
493 mp_filetype_error, /* the terminal */
494 mp_filetype_program , /* \MP\ language input */
495 mp_filetype_log, /* the log file */
496 mp_filetype_postscript, /* the postscript output */
497 mp_filetype_memfile, /* memory dumps */
498 mp_filetype_metrics, /* TeX font metric files */
499 mp_filetype_fontmap, /* PostScript font mapping files */
500 mp_filetype_font, /* PostScript type1 font programs */
501 mp_filetype_encoding, /* PostScript font encoding files */
502 mp_filetype_text /* first text file for readfrom and writeto primitives */
504 typedef char *(*mp_file_finder)(MP, const char *, const char *, int);
505 typedef void *(*mp_file_opener)(MP, const char *, const char *, int);
506 typedef char *(*mp_file_reader)(MP, void *, size_t *);
507 typedef void (*mp_binfile_reader)(MP, void *, void **, size_t *);
508 typedef void (*mp_file_closer)(MP, void *);
509 typedef int (*mp_file_eoftest)(MP, void *);
510 typedef void (*mp_file_flush)(MP, void *);
511 typedef void (*mp_file_writer)(MP, void *, const char *);
512 typedef void (*mp_binfile_writer)(MP, void *, void *, size_t);
515 @ @<Option variables@>=
516 mp_file_finder find_file;
517 mp_file_opener open_file;
518 mp_file_reader read_ascii_file;
519 mp_binfile_reader read_binary_file;
520 mp_file_closer close_file;
521 mp_file_eoftest eof_file;
522 mp_file_flush flush_file;
523 mp_file_writer write_ascii_file;
524 mp_binfile_writer write_binary_file;
526 @ The default function for finding files is |mp_find_file|. It is
527 pretty stupid: it will only find files in the current directory.
529 This function may disappear altogether, it is currently only
530 used for the default font map file.
533 char *mp_find_file (MP mp, const char *fname, const char *fmode, int ftype) {
535 if (fmode[0] != 'r' || (! access (fname,R_OK)) || ftype) {
536 return strdup(fname);
541 @ This has to be done very early on, so it is best to put it in with
542 the |mp_new| allocations
544 @d set_callback_option(A) do { mp->A = mp_##A;
545 if (opt->A!=NULL) mp->A = opt->A;
548 @<Allocate or initialize ...@>=
549 set_callback_option(find_file);
550 set_callback_option(open_file);
551 set_callback_option(read_ascii_file);
552 set_callback_option(read_binary_file);
553 set_callback_option(close_file);
554 set_callback_option(eof_file);
555 set_callback_option(flush_file);
556 set_callback_option(write_ascii_file);
557 set_callback_option(write_binary_file);
559 @ Because |mp_find_file| is used so early, it has to be in the helpers
563 char *mp_find_file (MP mp, const char *fname, const char *fmode, int ftype) ;
564 void *mp_open_file (MP mp , const char *fname, const char *fmode, int ftype) ;
565 char *mp_read_ascii_file (MP mp, void *f, size_t *size) ;
566 void mp_read_binary_file (MP mp, void *f, void **d, size_t *size) ;
567 void mp_close_file (MP mp, void *f) ;
568 int mp_eof_file (MP mp, void *f) ;
569 void mp_flush_file (MP mp, void *f) ;
570 void mp_write_ascii_file (MP mp, void *f, const char *s) ;
571 void mp_write_binary_file (MP mp, void *f, void *s, size_t t) ;
573 @ The function to open files can now be very short.
576 void *mp_open_file(MP mp, const char *fname, const char *fmode, int ftype) {
579 realmode[0] = *fmode;
583 if (ftype==mp_filetype_terminal) {
584 return (fmode[0] == 'r' ? stdin : stdout);
585 } else if (ftype==mp_filetype_error) {
587 } else if (fname != NULL && (fmode[0] != 'r' || (! access (fname,R_OK)))) {
588 return (void *)fopen(fname, realmode);
594 @ This is a legacy interface: (almost) all file names pass through |name_of_file|.
597 char name_of_file[file_name_size+1]; /* the name of a system file */
598 int name_length;/* this many characters are actually
599 relevant in |name_of_file| (the rest are blank) */
601 @ @<Option variables@>=
602 int print_found_names; /* configuration parameter */
604 @ If this parameter is true, the terminal and log will report the found
605 file names for input files instead of the requested ones.
606 It is off by default because it creates an extra filename lookup.
608 @<Allocate or initialize ...@>=
609 mp->print_found_names = (opt->print_found_names>0 ? true : false);
611 @ \MP's file-opening procedures return |false| if no file identified by
612 |name_of_file| could be opened.
614 The |OPEN_FILE| macro takes care of the |print_found_names| parameter.
615 It is not used for opening a mem file for read, because that file name
619 if (mp->print_found_names) {
620 char *s = (mp->find_file)(mp,mp->name_of_file,A,ftype);
622 *f = (mp->open_file)(mp,mp->name_of_file,A, ftype);
623 strncpy(mp->name_of_file,s,file_name_size);
629 *f = (mp->open_file)(mp,mp->name_of_file,A, ftype);
632 return (*f ? true : false)
635 boolean mp_a_open_in (MP mp, void **f, int ftype) {
636 /* open a text file for input */
640 boolean mp_w_open_in (MP mp, void **f) {
641 /* open a word file for input */
642 *f = (mp->open_file)(mp,mp->name_of_file,"r",mp_filetype_memfile);
643 return (*f ? true : false);
646 boolean mp_a_open_out (MP mp, void **f, int ftype) {
647 /* open a text file for output */
651 boolean mp_b_open_out (MP mp, void **f, int ftype) {
652 /* open a binary file for output */
656 boolean mp_w_open_out (MP mp, void **f) {
657 /* open a word file for output */
658 int ftype = mp_filetype_memfile;
663 char *mp_read_ascii_file (MP mp, void *ff, size_t *size) {
665 size_t len = 0, lim = 128;
667 FILE *f = (FILE *)ff;
669 (void) mp; /* for -Wunused */
677 if (s==NULL) return NULL;
678 while (c!=EOF && c!='\n' && c!='\r') {
680 s =realloc(s, (lim+(lim>>2)));
681 if (s==NULL) return NULL;
689 if (c!=EOF && c!='\n')
699 void mp_write_ascii_file (MP mp, void *f, const char *s) {
709 void mp_read_binary_file (MP mp, void *f, void **data, size_t *size) {
714 len = fread(*data,1,*size,(FILE *)f);
720 void mp_write_binary_file (MP mp, void *f, void *s, size_t size) {
724 fwrite(s,size,1,(FILE *)f);
730 void mp_close_file (MP mp, void *f) {
739 int mp_eof_file (MP mp, void *f) {
743 return feof((FILE *)f);
752 void mp_flush_file (MP mp, void *f) {
760 @ Input from text files is read one line at a time, using a routine called
761 |input_ln|. This function is defined in terms of global variables called
762 |buffer|, |first|, and |last| that will be described in detail later; for
763 now, it suffices for us to know that |buffer| is an array of |ASCII_code|
764 values, and that |first| and |last| are indices into this array
765 representing the beginning and ending of a line of text.
768 size_t buf_size; /* maximum number of characters simultaneously present in
769 current lines of open files */
770 ASCII_code *buffer; /* lines of characters being read */
771 size_t first; /* the first unused position in |buffer| */
772 size_t last; /* end of the line just input to |buffer| */
773 size_t max_buf_stack; /* largest index used in |buffer| */
775 @ @<Allocate or initialize ...@>=
777 mp->buffer = xmalloc((mp->buf_size+1),sizeof(ASCII_code));
779 @ @<Dealloc variables@>=
783 void mp_reallocate_buffer(MP mp, size_t l) {
785 if (l>max_halfword) {
786 mp_confusion(mp,"buffer size"); /* can't happen (I hope) */
788 buffer = xmalloc((l+1),sizeof(ASCII_code));
789 memcpy(buffer,mp->buffer,(mp->buf_size+1));
791 mp->buffer = buffer ;
795 @ The |input_ln| function brings the next line of input from the specified
796 field into available positions of the buffer array and returns the value
797 |true|, unless the file has already been entirely read, in which case it
798 returns |false| and sets |last:=first|. In general, the |ASCII_code|
799 numbers that represent the next line of the file are input into
800 |buffer[first]|, |buffer[first+1]|, \dots, |buffer[last-1]|; and the
801 global variable |last| is set equal to |first| plus the length of the
802 line. Trailing blanks are removed from the line; thus, either |last=first|
803 (in which case the line was entirely blank) or |buffer[last-1]<>" "|.
806 The variable |max_buf_stack|, which is used to keep track of how large
807 the |buf_size| parameter must be to accommodate the present job, is
808 also kept up to date by |input_ln|.
811 boolean mp_input_ln (MP mp, void *f ) {
812 /* inputs the next line or returns |false| */
815 mp->last=mp->first; /* cf.\ Matthew 19\thinspace:\thinspace30 */
816 s = (mp->read_ascii_file)(mp,f, &size);
820 mp->last = mp->first+size;
821 if ( mp->last>=mp->max_buf_stack ) {
822 mp->max_buf_stack=mp->last+1;
823 while ( mp->max_buf_stack>=mp->buf_size ) {
824 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
827 memcpy((mp->buffer+mp->first),s,size);
828 /* while ( mp->buffer[mp->last]==' ' ) mp->last--; */
834 @ The user's terminal acts essentially like other files of text, except
835 that it is used both for input and for output. When the terminal is
836 considered an input file, the file variable is called |term_in|, and when it
837 is considered an output file the file variable is |term_out|.
838 @^system dependencies@>
841 void * term_in; /* the terminal as an input file */
842 void * term_out; /* the terminal as an output file */
843 void * err_out; /* the terminal as an output file */
845 @ Here is how to open the terminal files. In the default configuration,
846 nothing happens except that the command line (if there is one) is copied
847 to the input buffer. The variable |command_line| will be filled by the
848 |main| procedure. The copying can not be done earlier in the program
849 logic because in the |INI| version, the |buffer| is also used for primitive
852 @^system dependencies@>
854 @d t_open_out do {/* open the terminal for text output */
855 mp->term_out = (mp->open_file)(mp,"terminal", "w", mp_filetype_terminal);
856 mp->err_out = (mp->open_file)(mp,"error", "w", mp_filetype_error);
858 @d t_open_in do { /* open the terminal for text input */
859 mp->term_in = (mp->open_file)(mp,"terminal", "r", mp_filetype_terminal);
860 if (mp->command_line!=NULL) {
861 mp->last = strlen(mp->command_line);
862 strncpy((char *)mp->buffer,mp->command_line,mp->last);
863 xfree(mp->command_line);
869 @d t_close_out do { /* close the terminal */
870 /* (mp->close_file)(mp,mp->term_out); */
871 /* (mp->close_file)(mp,mp->err_out); */
874 @d t_close_in do { /* close the terminal */
875 /* (mp->close_file)(mp,mp->term_in); */
878 @<Option variables@>=
881 @ @<Allocate or initialize ...@>=
882 mp->command_line = xstrdup(opt->command_line);
884 @ Sometimes it is necessary to synchronize the input/output mixture that
885 happens on the user's terminal, and three system-dependent
886 procedures are used for this
887 purpose. The first of these, |update_terminal|, is called when we want
888 to make sure that everything we have output to the terminal so far has
889 actually left the computer's internal buffers and been sent.
890 The second, |clear_terminal|, is called when we wish to cancel any
891 input that the user may have typed ahead (since we are about to
892 issue an unexpected error message). The third, |wake_up_terminal|,
893 is supposed to revive the terminal if the user has disabled it by
894 some instruction to the operating system. The following macros show how
895 these operations can be specified:
896 @^system dependencies@>
898 @d update_terminal (mp->flush_file)(mp,mp->term_out) /* empty the terminal output buffer */
899 @d clear_terminal do_nothing /* clear the terminal input buffer */
900 @d wake_up_terminal (mp->flush_file)(mp,mp->term_out)
901 /* cancel the user's cancellation of output */
903 @ We need a special routine to read the first line of \MP\ input from
904 the user's terminal. This line is different because it is read before we
905 have opened the transcript file; there is sort of a ``chicken and
906 egg'' problem here. If the user types `\.{input cmr10}' on the first
907 line, or if some macro invoked by that line does such an \.{input},
908 the transcript file will be named `\.{cmr10.log}'; but if no \.{input}
909 commands are performed during the first line of terminal input, the transcript
910 file will acquire its default name `\.{mpout.log}'. (The transcript file
911 will not contain error messages generated by the first line before the
912 first \.{input} command.)
914 The first line is even more special. It's nice to let the user start
915 running a \MP\ job by typing a command line like `\.{MP cmr10}'; in
916 such a case, \MP\ will operate as if the first line of input were
917 `\.{cmr10}', i.e., the first line will consist of the remainder of the
918 command line, after the part that invoked \MP.
920 @ Different systems have different ways to get started. But regardless of
921 what conventions are adopted, the routine that initializes the terminal
922 should satisfy the following specifications:
924 \yskip\textindent{1)}It should open file |term_in| for input from the
925 terminal. (The file |term_out| will already be open for output to the
928 \textindent{2)}If the user has given a command line, this line should be
929 considered the first line of terminal input. Otherwise the
930 user should be prompted with `\.{**}', and the first line of input
931 should be whatever is typed in response.
933 \textindent{3)}The first line of input, which might or might not be a
934 command line, should appear in locations |first| to |last-1| of the
937 \textindent{4)}The global variable |loc| should be set so that the
938 character to be read next by \MP\ is in |buffer[loc]|. This
939 character should not be blank, and we should have |loc<last|.
941 \yskip\noindent(It may be necessary to prompt the user several times
942 before a non-blank line comes in. The prompt is `\.{**}' instead of the
943 later `\.*' because the meaning is slightly different: `\.{input}' need
944 not be typed immediately after~`\.{**}'.)
946 @d loc mp->cur_input.loc_field /* location of first unread character in |buffer| */
948 @ The following program does the required initialization
949 without retrieving a possible command line.
950 It should be clear how to modify this routine to deal with command lines,
951 if the system permits them.
952 @^system dependencies@>
955 boolean mp_init_terminal (MP mp) { /* gets the terminal input started */
962 if (!mp->noninteractive) {
963 wake_up_terminal; do_fprintf(mp->term_out,"**"); update_terminal;
966 if ( ! mp_input_ln(mp, mp->term_in ) ) { /* this shouldn't happen */
967 do_fprintf(mp->term_out,"\n! End of file on the terminal... why?");
968 @.End of file on the terminal@>
972 while ( (loc<(int)mp->last)&&(mp->buffer[loc]==' ') )
974 if ( loc<(int)mp->last ) {
975 return true; /* return unless the line was all blank */
977 if (!mp->noninteractive) {
978 do_fprintf(mp->term_out,"Please type the name of your input file.\n");
984 boolean mp_init_terminal (MP mp) ;
987 @* \[4] String handling.
988 Symbolic token names and diagnostic messages are variable-length strings
989 of eight-bit characters. Many strings \MP\ uses are simply literals
990 in the compiled source, like the error messages and the names of the
991 internal parameters. Other strings are used or defined from the \MP\ input
992 language, and these have to be interned.
994 \MP\ uses strings more extensively than \MF\ does, but the necessary
995 operations can still be handled with a fairly simple data structure.
996 The array |str_pool| contains all of the (eight-bit) ASCII codes in all
997 of the strings, and the array |str_start| contains indices of the starting
998 points of each string. Strings are referred to by integer numbers, so that
999 string number |s| comprises the characters |str_pool[j]| for
1000 |str_start[s]<=j<str_start[ss]| where |ss=next_str[s]|. The string pool
1001 is allocated sequentially and |str_pool[pool_ptr]| is the next unused
1002 location. The first string number not currently in use is |str_ptr|
1003 and |next_str[str_ptr]| begins a list of free string numbers. String
1004 pool entries |str_start[str_ptr]| up to |pool_ptr| are reserved for a
1005 string currently being constructed.
1007 String numbers 0 to 255 are reserved for strings that correspond to single
1008 ASCII characters. This is in accordance with the conventions of \.{WEB},
1010 which converts single-character strings into the ASCII code number of the
1011 single character involved, while it converts other strings into integers
1012 and builds a string pool file. Thus, when the string constant \.{"."} appears
1013 in the program below, \.{WEB} converts it into the integer 46, which is the
1014 ASCII code for a period, while \.{WEB} will convert a string like \.{"hello"}
1015 into some integer greater than~255. String number 46 will presumably be the
1016 single character `\..'\thinspace; but some ASCII codes have no standard visible
1017 representation, and \MP\ may need to be able to print an arbitrary
1018 ASCII character, so the first 256 strings are used to specify exactly what
1019 should be printed for each of the 256 possibilities.
1022 typedef int pool_pointer; /* for variables that point into |str_pool| */
1023 typedef int str_number; /* for variables that point into |str_start| */
1026 ASCII_code *str_pool; /* the characters */
1027 pool_pointer *str_start; /* the starting pointers */
1028 str_number *next_str; /* for linking strings in order */
1029 pool_pointer pool_ptr; /* first unused position in |str_pool| */
1030 str_number str_ptr; /* number of the current string being created */
1031 pool_pointer init_pool_ptr; /* the starting value of |pool_ptr| */
1032 str_number init_str_use; /* the initial number of strings in use */
1033 pool_pointer max_pool_ptr; /* the maximum so far of |pool_ptr| */
1034 str_number max_str_ptr; /* the maximum so far of |str_ptr| */
1036 @ @<Allocate or initialize ...@>=
1037 mp->str_pool = xmalloc ((mp->pool_size +1),sizeof(ASCII_code));
1038 mp->str_start = xmalloc ((mp->max_strings+1),sizeof(pool_pointer));
1039 mp->next_str = xmalloc ((mp->max_strings+1),sizeof(str_number));
1041 @ @<Dealloc variables@>=
1042 xfree(mp->str_pool);
1043 xfree(mp->str_start);
1044 xfree(mp->next_str);
1046 @ Most printing is done from |char *|s, but sometimes not. Here are
1047 functions that convert an internal string into a |char *| for use
1048 by the printing routines, and vice versa.
1050 @d str(A) mp_str(mp,A)
1051 @d rts(A) mp_rts(mp,A)
1054 int mp_xstrcmp (const char *a, const char *b);
1055 char * mp_str (MP mp, str_number s);
1058 str_number mp_rts (MP mp, const char *s);
1059 str_number mp_make_string (MP mp);
1061 @ The attempt to catch interrupted strings that is in |mp_rts|, is not
1062 very good: it does not handle nesting over more than one level.
1065 int mp_xstrcmp (const char *a, const char *b) {
1066 if (a==NULL && b==NULL)
1076 char * mp_str (MP mp, str_number ss) {
1079 if (ss==mp->str_ptr) {
1083 s = xmalloc(len+1,sizeof(char));
1084 strncpy(s,(char *)(mp->str_pool+(mp->str_start[ss])),len);
1089 str_number mp_rts (MP mp, const char *s) {
1090 int r; /* the new string */
1091 int old; /* a possible string in progress */
1095 } else if (strlen(s)==1) {
1099 str_room((integer)strlen(s));
1100 if (mp->str_start[mp->str_ptr]<mp->pool_ptr)
1101 old = mp_make_string(mp);
1106 r = mp_make_string(mp);
1108 str_room(length(old));
1109 while (i<length(old)) {
1110 append_char((mp->str_start[old]+i));
1112 mp_flush_string(mp,old);
1118 @ Except for |strs_used_up|, the following string statistics are only
1119 maintained when code between |stat| $\ldots$ |tats| delimiters is not
1123 integer strs_used_up; /* strings in use or unused but not reclaimed */
1124 integer pool_in_use; /* total number of cells of |str_pool| actually in use */
1125 integer strs_in_use; /* total number of strings actually in use */
1126 integer max_pl_used; /* maximum |pool_in_use| so far */
1127 integer max_strs_used; /* maximum |strs_in_use| so far */
1129 @ Several of the elementary string operations are performed using \.{WEB}
1130 macros instead of functions, because many of the
1131 operations are done quite frequently and we want to avoid the
1132 overhead of procedure calls. For example, here is
1133 a simple macro that computes the length of a string.
1136 @d str_stop(A) mp->str_start[mp->next_str[(A)]] /* one cell past the end of string
1138 @d length(A) (str_stop((A))-mp->str_start[(A)]) /* the number of characters in string \# */
1140 @ The length of the current string is called |cur_length|. If we decide that
1141 the current string is not needed, |flush_cur_string| resets |pool_ptr| so that
1142 |cur_length| becomes zero.
1144 @d cur_length (mp->pool_ptr - mp->str_start[mp->str_ptr])
1145 @d flush_cur_string mp->pool_ptr=mp->str_start[mp->str_ptr]
1147 @ Strings are created by appending character codes to |str_pool|.
1148 The |append_char| macro, defined here, does not check to see if the
1149 value of |pool_ptr| has gotten too high; this test is supposed to be
1150 made before |append_char| is used.
1152 To test if there is room to append |l| more characters to |str_pool|,
1153 we shall write |str_room(l)|, which tries to make sure there is enough room
1154 by compacting the string pool if necessary. If this does not work,
1155 |do_compaction| aborts \MP\ and gives an apologetic error message.
1157 @d append_char(A) /* put |ASCII_code| \# at the end of |str_pool| */
1158 { mp->str_pool[mp->pool_ptr]=(A); incr(mp->pool_ptr);
1160 @d str_room(A) /* make sure that the pool hasn't overflowed */
1161 { if ( mp->pool_ptr+(A) > mp->max_pool_ptr ) {
1162 if ( mp->pool_ptr+(A) > mp->pool_size ) mp_do_compaction(mp, (A));
1163 else mp->max_pool_ptr=mp->pool_ptr+(A); }
1166 @ The following routine is similar to |str_room(1)| but it uses the
1167 argument |mp->pool_size| to prevent |do_compaction| from aborting when
1168 string space is exhausted.
1170 @<Declare the procedure called |unit_str_room|@>=
1171 void mp_unit_str_room (MP mp);
1174 void mp_unit_str_room (MP mp) {
1175 if ( mp->pool_ptr>=mp->pool_size ) mp_do_compaction(mp, mp->pool_size);
1176 if ( mp->pool_ptr>=mp->max_pool_ptr ) mp->max_pool_ptr=mp->pool_ptr+1;
1179 @ \MP's string expressions are implemented in a brute-force way: Every
1180 new string or substring that is needed is simply copied into the string pool.
1181 Space is eventually reclaimed by a procedure called |do_compaction| with
1182 the aid of a simple system system of reference counts.
1183 @^reference counts@>
1185 The number of references to string number |s| will be |str_ref[s]|. The
1186 special value |str_ref[s]=max_str_ref=127| is used to denote an unknown
1187 positive number of references; such strings will never be recycled. If
1188 a string is ever referred to more than 126 times, simultaneously, we
1189 put it in this category. Hence a single byte suffices to store each |str_ref|.
1191 @d max_str_ref 127 /* ``infinite'' number of references */
1192 @d add_str_ref(A) { if ( mp->str_ref[(A)]<max_str_ref ) incr(mp->str_ref[(A)]);
1198 @ @<Allocate or initialize ...@>=
1199 mp->str_ref = xmalloc ((mp->max_strings+1),sizeof(int));
1201 @ @<Dealloc variables@>=
1204 @ Here's what we do when a string reference disappears:
1206 @d delete_str_ref(A) {
1207 if ( mp->str_ref[(A)]<max_str_ref ) {
1208 if ( mp->str_ref[(A)]>1 ) decr(mp->str_ref[(A)]);
1209 else mp_flush_string(mp, (A));
1213 @<Declare the procedure called |flush_string|@>=
1214 void mp_flush_string (MP mp,str_number s) ;
1217 @ We can't flush the first set of static strings at all, so there
1218 is no point in trying
1221 void mp_flush_string (MP mp,str_number s) {
1223 mp->pool_in_use=mp->pool_in_use-length(s);
1224 decr(mp->strs_in_use);
1225 if ( mp->next_str[s]!=mp->str_ptr ) {
1229 decr(mp->strs_used_up);
1231 mp->pool_ptr=mp->str_start[mp->str_ptr];
1235 @ C literals cannot be simply added, they need to be set so they can't
1238 @d intern(A) mp_intern(mp,(A))
1241 str_number mp_intern (MP mp, const char *s) {
1244 mp->str_ref[r] = max_str_ref;
1249 str_number mp_intern (MP mp, const char *s);
1252 @ Once a sequence of characters has been appended to |str_pool|, it
1253 officially becomes a string when the function |make_string| is called.
1254 This function returns the identification number of the new string as its
1257 When getting the next unused string number from the linked list, we pretend
1259 $$ \hbox{|max_str_ptr+1|, |max_str_ptr+2|, $\ldots$, |mp->max_strings|} $$
1260 are linked sequentially even though the |next_str| entries have not been
1261 initialized yet. We never allow |str_ptr| to reach |mp->max_strings|;
1262 |do_compaction| is responsible for making sure of this.
1265 @<Declare the procedure called |do_compaction|@>
1266 @<Declare the procedure called |unit_str_room|@>
1267 str_number mp_make_string (MP mp);
1270 str_number mp_make_string (MP mp) { /* current string enters the pool */
1271 str_number s; /* the new string */
1274 mp->str_ptr=mp->next_str[s];
1275 if ( mp->str_ptr>mp->max_str_ptr ) {
1276 if ( mp->str_ptr==mp->max_strings ) {
1278 mp_do_compaction(mp, 0);
1282 if ( mp->strs_used_up!=mp->max_str_ptr ) mp_confusion(mp, "s");
1283 @:this can't happen s}{\quad \.s@>
1285 mp->max_str_ptr=mp->str_ptr;
1286 mp->next_str[mp->str_ptr]=mp->max_str_ptr+1;
1290 mp->str_start[mp->str_ptr]=mp->pool_ptr;
1291 incr(mp->strs_used_up);
1292 incr(mp->strs_in_use);
1293 mp->pool_in_use=mp->pool_in_use+length(s);
1294 if ( mp->pool_in_use>mp->max_pl_used )
1295 mp->max_pl_used=mp->pool_in_use;
1296 if ( mp->strs_in_use>mp->max_strs_used )
1297 mp->max_strs_used=mp->strs_in_use;
1301 @ The most interesting string operation is string pool compaction. The idea
1302 is to recover unused space in the |str_pool| array by recopying the strings
1303 to close the gaps created when some strings become unused. All string
1304 numbers~$k$ where |str_ref[k]=0| are to be linked into the list of free string
1305 numbers after |str_ptr|. If this fails to free enough pool space we issue an
1306 |overflow| error unless |needed=mp->pool_size|. Calling |do_compaction|
1307 with |needed=mp->pool_size| supresses all overflow tests.
1309 The compaction process starts with |last_fixed_str| because all lower numbered
1310 strings are permanently allocated with |max_str_ref| in their |str_ref| entries.
1313 str_number last_fixed_str; /* last permanently allocated string */
1314 str_number fixed_str_use; /* number of permanently allocated strings */
1316 @ @<Declare the procedure called |do_compaction|@>=
1317 void mp_do_compaction (MP mp, pool_pointer needed) ;
1320 void mp_do_compaction (MP mp, pool_pointer needed) {
1321 str_number str_use; /* a count of strings in use */
1322 str_number r,s,t; /* strings being manipulated */
1323 pool_pointer p,q; /* destination and source for copying string characters */
1324 @<Advance |last_fixed_str| as far as possible and set |str_use|@>;
1325 r=mp->last_fixed_str;
1328 while ( s!=mp->str_ptr ) {
1329 while ( mp->str_ref[s]==0 ) {
1330 @<Advance |s| and add the old |s| to the list of free string numbers;
1331 then |break| if |s=str_ptr|@>;
1333 r=s; s=mp->next_str[s];
1335 @<Move string |r| back so that |str_start[r]=p|; make |p| the location
1336 after the end of the string@>;
1339 @<Move the current string back so that it starts at |p|@>;
1340 if ( needed<mp->pool_size ) {
1341 @<Make sure that there is room for another string with |needed| characters@>;
1343 @<Account for the compaction and make sure the statistics agree with the
1345 mp->strs_used_up=str_use;
1348 @ @<Advance |last_fixed_str| as far as possible and set |str_use|@>=
1349 t=mp->next_str[mp->last_fixed_str];
1350 while (t!=mp->str_ptr && mp->str_ref[t]==max_str_ref) {
1351 incr(mp->fixed_str_use);
1352 mp->last_fixed_str=t;
1355 str_use=mp->fixed_str_use
1357 @ Because of the way |flush_string| has been written, it should never be
1358 necessary to |break| here. The extra line of code seems worthwhile to
1359 preserve the generality of |do_compaction|.
1361 @<Advance |s| and add the old |s| to the list of free string numbers;...@>=
1366 mp->next_str[t]=mp->next_str[mp->str_ptr];
1367 mp->next_str[mp->str_ptr]=t;
1368 if ( s==mp->str_ptr ) goto DONE;
1371 @ The string currently starts at |str_start[r]| and ends just before
1372 |str_start[s]|. We don't change |str_start[s]| because it might be needed
1373 to locate the next string.
1375 @<Move string |r| back so that |str_start[r]=p|; make |p| the location...@>=
1378 while ( q<mp->str_start[s] ) {
1379 mp->str_pool[p]=mp->str_pool[q];
1383 @ Pointers |str_start[str_ptr]| and |pool_ptr| have not been updated. When
1384 we do this, anything between them should be moved.
1386 @ @<Move the current string back so that it starts at |p|@>=
1387 q=mp->str_start[mp->str_ptr];
1388 mp->str_start[mp->str_ptr]=p;
1389 while ( q<mp->pool_ptr ) {
1390 mp->str_pool[p]=mp->str_pool[q];
1395 @ We must remember that |str_ptr| is not allowed to reach |mp->max_strings|.
1397 @<Make sure that there is room for another string with |needed| char...@>=
1398 if ( str_use>=mp->max_strings-1 )
1399 mp_reallocate_strings (mp,str_use);
1400 if ( mp->pool_ptr+needed>mp->max_pool_ptr ) {
1401 mp_reallocate_pool(mp, mp->pool_ptr+needed);
1402 mp->max_pool_ptr=mp->pool_ptr+needed;
1406 void mp_reallocate_strings (MP mp, str_number str_use) ;
1407 void mp_reallocate_pool(MP mp, pool_pointer needed) ;
1410 void mp_reallocate_strings (MP mp, str_number str_use) {
1411 while ( str_use>=mp->max_strings-1 ) {
1412 int l = mp->max_strings + (mp->max_strings>>2);
1413 XREALLOC (mp->str_ref, l, int);
1414 XREALLOC (mp->str_start, l, pool_pointer);
1415 XREALLOC (mp->next_str, l, str_number);
1416 mp->max_strings = l;
1419 void mp_reallocate_pool(MP mp, pool_pointer needed) {
1420 while ( needed>mp->pool_size ) {
1421 int l = mp->pool_size + (mp->pool_size>>2);
1422 XREALLOC (mp->str_pool, l, ASCII_code);
1427 @ @<Account for the compaction and make sure the statistics agree with...@>=
1428 if ( (mp->str_start[mp->str_ptr]!=mp->pool_in_use)||(str_use!=mp->strs_in_use) )
1429 mp_confusion(mp, "string");
1430 @:this can't happen string}{\quad string@>
1431 incr(mp->pact_count);
1432 mp->pact_chars=mp->pact_chars+mp->pool_ptr-str_stop(mp->last_fixed_str);
1433 mp->pact_strs=mp->pact_strs+str_use-mp->fixed_str_use;
1435 s=mp->str_ptr; t=str_use;
1436 while ( s<=mp->max_str_ptr ){
1437 if ( t>mp->max_str_ptr ) mp_confusion(mp, "\"");
1438 incr(t); s=mp->next_str[s];
1440 if ( t<=mp->max_str_ptr ) mp_confusion(mp, "\"");
1443 @ A few more global variables are needed to keep track of statistics when
1444 |stat| $\ldots$ |tats| blocks are not commented out.
1447 integer pact_count; /* number of string pool compactions so far */
1448 integer pact_chars; /* total number of characters moved during compactions */
1449 integer pact_strs; /* total number of strings moved during compactions */
1451 @ @<Initialize compaction statistics@>=
1456 @ The following subroutine compares string |s| with another string of the
1457 same length that appears in |buffer| starting at position |k|;
1458 the result is |true| if and only if the strings are equal.
1461 boolean mp_str_eq_buf (MP mp,str_number s, integer k) {
1462 /* test equality of strings */
1463 pool_pointer j; /* running index */
1465 while ( j<str_stop(s) ) {
1466 if ( mp->str_pool[j++]!=mp->buffer[k++] )
1472 @ Here is a similar routine, but it compares two strings in the string pool,
1473 and it does not assume that they have the same length. If the first string
1474 is lexicographically greater than, less than, or equal to the second,
1475 the result is respectively positive, negative, or zero.
1478 integer mp_str_vs_str (MP mp, str_number s, str_number t) {
1479 /* test equality of strings */
1480 pool_pointer j,k; /* running indices */
1481 integer ls,lt; /* lengths */
1482 integer l; /* length remaining to test */
1483 ls=length(s); lt=length(t);
1484 if ( ls<=lt ) l=ls; else l=lt;
1485 j=mp->str_start[s]; k=mp->str_start[t];
1487 if ( mp->str_pool[j]!=mp->str_pool[k] ) {
1488 return (mp->str_pool[j]-mp->str_pool[k]);
1495 @ The initial values of |str_pool|, |str_start|, |pool_ptr|,
1496 and |str_ptr| are computed by the \.{INIMP} program, based in part
1497 on the information that \.{WEB} has output while processing \MP.
1502 void mp_get_strings_started (MP mp) {
1503 /* initializes the string pool,
1504 but returns |false| if something goes wrong */
1505 int k; /* small indices or counters */
1506 str_number g; /* a new string */
1507 mp->pool_ptr=0; mp->str_ptr=0; mp->max_pool_ptr=0; mp->max_str_ptr=0;
1510 mp->pool_in_use=0; mp->strs_in_use=0;
1511 mp->max_pl_used=0; mp->max_strs_used=0;
1512 @<Initialize compaction statistics@>;
1514 @<Make the first 256 strings@>;
1515 g=mp_make_string(mp); /* string 256 == "" */
1516 mp->str_ref[g]=max_str_ref;
1517 mp->last_fixed_str=mp->str_ptr-1;
1518 mp->fixed_str_use=mp->str_ptr;
1523 void mp_get_strings_started (MP mp);
1525 @ The first 256 strings will consist of a single character only.
1527 @<Make the first 256...@>=
1528 for (k=0;k<=255;k++) {
1530 g=mp_make_string(mp);
1531 mp->str_ref[g]=max_str_ref;
1534 @ The first 128 strings will contain 95 standard ASCII characters, and the
1535 other 33 characters will be printed in three-symbol form like `\.{\^\^A}'
1536 unless a system-dependent change is made here. Installations that have
1537 an extended character set, where for example |xchr[032]=@t\.{'^^Z'}@>|,
1538 would like string 032 to be printed as the single character 032 instead
1539 of the three characters 0136, 0136, 0132 (\.{\^\^Z}). On the other hand,
1540 even people with an extended character set will want to represent string
1541 015 by \.{\^\^M}, since 015 is ASCII's ``carriage return'' code; the idea is
1542 to produce visible strings instead of tabs or line-feeds or carriage-returns
1543 or bell-rings or characters that are treated anomalously in text files.
1545 Unprintable characters of codes 128--255 are, similarly, rendered
1546 \.{\^\^80}--\.{\^\^ff}.
1548 The boolean expression defined here should be |true| unless \MP\ internal
1549 code number~|k| corresponds to a non-troublesome visible symbol in the
1550 local character set.
1551 If character |k| cannot be printed, and |k<0200|, then character |k+0100| or
1552 |k-0100| must be printable; moreover, ASCII codes |[060..071, 0141..0146]|
1554 @^character set dependencies@>
1555 @^system dependencies@>
1557 @<Character |k| cannot be printed@>=
1560 @* \[5] On-line and off-line printing.
1561 Messages that are sent to a user's terminal and to the transcript-log file
1562 are produced by several `|print|' procedures. These procedures will
1563 direct their output to a variety of places, based on the setting of
1564 the global variable |selector|, which has the following possible
1568 \hang |term_and_log|, the normal setting, prints on the terminal and on the
1571 \hang |log_only|, prints only on the transcript file.
1573 \hang |term_only|, prints only on the terminal.
1575 \hang |no_print|, doesn't print at all. This is used only in rare cases
1576 before the transcript file is open.
1578 \hang |pseudo|, puts output into a cyclic buffer that is used
1579 by the |show_context| routine; when we get to that routine we shall discuss
1580 the reasoning behind this curious mode.
1582 \hang |new_string|, appends the output to the current string in the
1585 \hang |>=write_file| prints on one of the files used for the \&{write}
1586 @:write_}{\&{write} primitive@>
1590 \noindent The symbolic names `|term_and_log|', etc., have been assigned
1591 numeric codes that satisfy the convenient relations |no_print+1=term_only|,
1592 |no_print+2=log_only|, |term_only+2=log_only+1=term_and_log|. These
1593 relations are not used when |selector| could be |pseudo|, or |new_string|.
1594 We need not check for unprintable characters when |selector<pseudo|.
1596 Three additional global variables, |tally|, |term_offset| and |file_offset|
1597 record the number of characters that have been printed
1598 since they were most recently cleared to zero. We use |tally| to record
1599 the length of (possibly very long) stretches of printing; |term_offset|,
1600 and |file_offset|, on the other hand, keep track of how many
1601 characters have appeared so far on the current line that has been output
1602 to the terminal, the transcript file, or the \ps\ output file, respectively.
1604 @d new_string 0 /* printing is deflected to the string pool */
1605 @d pseudo 2 /* special |selector| setting for |show_context| */
1606 @d no_print 3 /* |selector| setting that makes data disappear */
1607 @d term_only 4 /* printing is destined for the terminal only */
1608 @d log_only 5 /* printing is destined for the transcript file only */
1609 @d term_and_log 6 /* normal |selector| setting */
1610 @d write_file 7 /* first write file selector */
1613 void * log_file; /* transcript of \MP\ session */
1614 void * ps_file; /* the generic font output goes here */
1615 unsigned int selector; /* where to print a message */
1616 unsigned char dig[23]; /* digits in a number being output */
1617 integer tally; /* the number of characters recently printed */
1618 unsigned int term_offset;
1619 /* the number of characters on the current terminal line */
1620 unsigned int file_offset;
1621 /* the number of characters on the current file line */
1622 ASCII_code *trick_buf; /* circular buffer for pseudoprinting */
1623 integer trick_count; /* threshold for pseudoprinting, explained later */
1624 integer first_count; /* another variable for pseudoprinting */
1626 @ @<Allocate or initialize ...@>=
1627 memset(mp->dig,0,23);
1628 mp->trick_buf = xmalloc((mp->error_line+1),sizeof(ASCII_code));
1630 @ @<Dealloc variables@>=
1631 xfree(mp->trick_buf);
1633 @ @<Initialize the output routines@>=
1634 mp->selector=term_only; mp->tally=0; mp->term_offset=0; mp->file_offset=0;
1636 @ Macro abbreviations for output to the terminal and to the log file are
1637 defined here for convenience. Some systems need special conventions
1638 for terminal output, and it is possible to adhere to those conventions
1639 by changing |wterm|, |wterm_ln|, and |wterm_cr| here.
1640 @^system dependencies@>
1642 @d do_fprintf(f,b) (mp->write_ascii_file)(mp,f,b)
1643 @d wterm(A) do_fprintf(mp->term_out,(A))
1644 @d wterm_chr(A) { unsigned char ss[2]; ss[0]=(A); ss[1]=0; do_fprintf(mp->term_out,(char *)ss); }
1645 @d wterm_cr do_fprintf(mp->term_out,"\n")
1646 @d wterm_ln(A) { wterm_cr; do_fprintf(mp->term_out,(A)); }
1647 @d wlog(A) do_fprintf(mp->log_file,(A))
1648 @d wlog_chr(A) { unsigned char ss[2]; ss[0]=(A); ss[1]=0; do_fprintf(mp->log_file,(char *)ss); }
1649 @d wlog_cr do_fprintf(mp->log_file, "\n")
1650 @d wlog_ln(A) { wlog_cr; do_fprintf(mp->log_file,(A)); }
1653 @ To end a line of text output, we call |print_ln|. Cases |0..max_write_files|
1654 use an array |wr_file| that will be declared later.
1656 @d mp_print_text(A) mp_print_str(mp,text((A)))
1659 void mp_print_ln (MP mp);
1660 void mp_print_visible_char (MP mp, ASCII_code s);
1661 void mp_print_char (MP mp, ASCII_code k);
1662 void mp_print (MP mp, const char *s);
1663 void mp_print_str (MP mp, str_number s);
1664 void mp_print_nl (MP mp, const char *s);
1665 void mp_print_two (MP mp,scaled x, scaled y) ;
1666 void mp_print_scaled (MP mp,scaled s);
1668 @ @<Basic print...@>=
1669 void mp_print_ln (MP mp) { /* prints an end-of-line */
1670 switch (mp->selector) {
1673 mp->term_offset=0; mp->file_offset=0;
1676 wlog_cr; mp->file_offset=0;
1679 wterm_cr; mp->term_offset=0;
1686 do_fprintf(mp->wr_file[(mp->selector-write_file)],"\n");
1688 } /* note that |tally| is not affected */
1690 @ The |print_visible_char| procedure sends one character to the desired
1691 destination, using the |xchr| array to map it into an external character
1692 compatible with |input_ln|. (It assumes that it is always called with
1693 a visible ASCII character.) All printing comes through |print_ln| or
1694 |print_char|, which ultimately calls |print_visible_char|, hence these
1695 routines are the ones that limit lines to at most |max_print_line| characters.
1696 But we must make an exception for the \ps\ output file since it is not safe
1697 to cut up lines arbitrarily in \ps.
1699 Procedure |unit_str_room| needs to be declared |forward| here because it calls
1700 |do_compaction| and |do_compaction| can call the error routines. Actually,
1701 |unit_str_room| avoids |overflow| errors but it can call |confusion|.
1703 @<Basic printing...@>=
1704 void mp_print_visible_char (MP mp, ASCII_code s) { /* prints a single character */
1705 switch (mp->selector) {
1707 wterm_chr(xchr(s)); wlog_chr(xchr(s));
1708 incr(mp->term_offset); incr(mp->file_offset);
1709 if ( mp->term_offset==(unsigned)mp->max_print_line ) {
1710 wterm_cr; mp->term_offset=0;
1712 if ( mp->file_offset==(unsigned)mp->max_print_line ) {
1713 wlog_cr; mp->file_offset=0;
1717 wlog_chr(xchr(s)); incr(mp->file_offset);
1718 if ( mp->file_offset==(unsigned)mp->max_print_line ) mp_print_ln(mp);
1721 wterm_chr(xchr(s)); incr(mp->term_offset);
1722 if ( mp->term_offset==(unsigned)mp->max_print_line ) mp_print_ln(mp);
1727 if ( mp->tally<mp->trick_count )
1728 mp->trick_buf[mp->tally % mp->error_line]=s;
1731 if ( mp->pool_ptr>=mp->max_pool_ptr ) {
1732 mp_unit_str_room(mp);
1733 if ( mp->pool_ptr>=mp->pool_size )
1734 goto DONE; /* drop characters if string space is full */
1739 { char ss[2]; ss[0] = xchr(s); ss[1]=0;
1740 do_fprintf(mp->wr_file[(mp->selector-write_file)],(char *)ss);
1747 @ The |print_char| procedure sends one character to the desired destination.
1748 File names and string expressions might contain |ASCII_code| values that
1749 can't be printed using |print_visible_char|. These characters will be
1750 printed in three- or four-symbol form like `\.{\^\^A}' or `\.{\^\^e4}'.
1751 (This procedure assumes that it is safe to bypass all checks for unprintable
1752 characters when |selector| is in the range |0..max_write_files-1|.
1753 The user might want to write unprintable characters.
1755 @d print_lc_hex(A) do { l=(A);
1756 mp_print_visible_char(mp, (l<10 ? l+'0' : l-10+'a'));
1759 @<Basic printing...@>=
1760 void mp_print_char (MP mp, ASCII_code k) { /* prints a single character */
1761 int l; /* small index or counter */
1762 if ( mp->selector<pseudo || mp->selector>=write_file) {
1763 mp_print_visible_char(mp, k);
1764 } else if ( @<Character |k| cannot be printed@> ) {
1767 mp_print_visible_char(mp, k+0100);
1768 } else if ( k<0200 ) {
1769 mp_print_visible_char(mp, k-0100);
1771 print_lc_hex(k / 16);
1772 print_lc_hex(k % 16);
1775 mp_print_visible_char(mp, k);
1779 @ An entire string is output by calling |print|. Note that if we are outputting
1780 the single standard ASCII character \.c, we could call |print("c")|, since
1781 |"c"=99| is the number of a single-character string, as explained above. But
1782 |print_char("c")| is quicker, so \MP\ goes directly to the |print_char|
1783 routine when it knows that this is safe. (The present implementation
1784 assumes that it is always safe to print a visible ASCII character.)
1785 @^system dependencies@>
1788 void mp_do_print (MP mp, const char *ss, unsigned int len) { /* prints string |s| */
1791 mp_print_char(mp, ss[j]); incr(j);
1797 void mp_print (MP mp, const char *ss) {
1798 mp_do_print(mp, ss, strlen(ss));
1800 void mp_print_str (MP mp, str_number s) {
1801 pool_pointer j; /* current character code position */
1802 if ( (s<0)||(s>mp->max_str_ptr) ) {
1803 mp_do_print(mp,"???",3); /* this can't happen */
1807 mp_do_print(mp, (char *)(mp->str_pool+j), (str_stop(s)-j));
1811 @ Here is the very first thing that \MP\ prints: a headline that identifies
1812 the version number and base name. The |term_offset| variable is temporarily
1813 incorrect, but the discrepancy is not serious since we assume that the banner
1814 and mem identifier together will occupy at most |max_print_line|
1815 character positions.
1817 @<Initialize the output...@>=
1819 wterm (version_string);
1820 if (mp->mem_ident!=NULL)
1821 mp_print(mp,mp->mem_ident);
1825 @ The procedure |print_nl| is like |print|, but it makes sure that the
1826 string appears at the beginning of a new line.
1829 void mp_print_nl (MP mp, const char *s) { /* prints string |s| at beginning of line */
1830 switch(mp->selector) {
1832 if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_ln(mp);
1835 if ( mp->file_offset>0 ) mp_print_ln(mp);
1838 if ( mp->term_offset>0 ) mp_print_ln(mp);
1844 } /* there are no other cases */
1848 @ An array of digits in the range |0..9| is printed by |print_the_digs|.
1851 void mp_print_the_digs (MP mp, eight_bits k) {
1852 /* prints |dig[k-1]|$\,\ldots\,$|dig[0]| */
1854 decr(k); mp_print_char(mp, '0'+mp->dig[k]);
1858 @ The following procedure, which prints out the decimal representation of a
1859 given integer |n|, has been written carefully so that it works properly
1860 if |n=0| or if |(-n)| would cause overflow. It does not apply |%| or |/|
1861 to negative arguments, since such operations are not implemented consistently
1865 void mp_print_int (MP mp,integer n) { /* prints an integer in decimal form */
1866 integer m; /* used to negate |n| in possibly dangerous cases */
1867 int k = 0; /* index to current digit; we assume that $|n|<10^{23}$ */
1869 mp_print_char(mp, '-');
1870 if ( n>-100000000 ) {
1873 m=-1-n; n=m / 10; m=(m % 10)+1; k=1;
1877 mp->dig[0]=0; incr(n);
1882 mp->dig[k]=n % 10; n=n / 10; incr(k);
1884 mp_print_the_digs(mp, k);
1888 void mp_print_int (MP mp,integer n);
1890 @ \MP\ also makes use of a trivial procedure to print two digits. The
1891 following subroutine is usually called with a parameter in the range |0<=n<=99|.
1894 void mp_print_dd (MP mp,integer n) { /* prints two least significant digits */
1896 mp_print_char(mp, '0'+(n / 10));
1897 mp_print_char(mp, '0'+(n % 10));
1902 void mp_print_dd (MP mp,integer n);
1904 @ Here is a procedure that asks the user to type a line of input,
1905 assuming that the |selector| setting is either |term_only| or |term_and_log|.
1906 The input is placed into locations |first| through |last-1| of the
1907 |buffer| array, and echoed on the transcript file if appropriate.
1909 This procedure is never called when |interaction<mp_scroll_mode|.
1911 @d prompt_input(A) do {
1912 if (!mp->noninteractive) {
1913 wake_up_terminal; mp_print(mp, (A));
1916 } while (0) /* prints a string and gets a line of input */
1919 void mp_term_input (MP mp) { /* gets a line from the terminal */
1920 size_t k; /* index into |buffer| */
1921 update_terminal; /* Now the user sees the prompt for sure */
1922 if (!mp_input_ln(mp, mp->term_in )) {
1923 if (!mp->noninteractive) {
1924 mp_fatal_error(mp, "End of file on the terminal!");
1925 @.End of file on the terminal@>
1926 } else { /* we are done with this input chunk */
1927 longjmp(*(mp->jump_buf),1);
1930 if (!mp->noninteractive) {
1931 mp->term_offset=0; /* the user's line ended with \<\rm return> */
1932 decr(mp->selector); /* prepare to echo the input */
1933 if ( mp->last!=mp->first ) {
1934 for (k=mp->first;k<=mp->last-1;k++) {
1935 mp_print_char(mp, mp->buffer[k]);
1939 mp->buffer[mp->last]='%';
1940 incr(mp->selector); /* restore previous status */
1944 @* \[6] Reporting errors.
1945 When something anomalous is detected, \MP\ typically does something like this:
1946 $$\vbox{\halign{#\hfil\cr
1947 |print_err("Something anomalous has been detected");|\cr
1948 |help3("This is the first line of my offer to help.")|\cr
1949 |("This is the second line. I'm trying to")|\cr
1950 |("explain the best way for you to proceed.");|\cr
1952 A two-line help message would be given using |help2|, etc.; these informal
1953 helps should use simple vocabulary that complements the words used in the
1954 official error message that was printed. (Outside the U.S.A., the help
1955 messages should preferably be translated into the local vernacular. Each
1956 line of help is at most 60 characters long, in the present implementation,
1957 so that |max_print_line| will not be exceeded.)
1959 The |print_err| procedure supplies a `\.!' before the official message,
1960 and makes sure that the terminal is awake if a stop is going to occur.
1961 The |error| procedure supplies a `\..' after the official message, then it
1962 shows the location of the error; and if |interaction=error_stop_mode|,
1963 it also enters into a dialog with the user, during which time the help
1964 message may be printed.
1965 @^system dependencies@>
1967 @ The global variable |interaction| has four settings, representing increasing
1968 amounts of user interaction:
1971 enum mp_interaction_mode {
1972 mp_unspecified_mode=0, /* extra value for command-line switch */
1973 mp_batch_mode, /* omits all stops and omits terminal output */
1974 mp_nonstop_mode, /* omits all stops */
1975 mp_scroll_mode, /* omits error stops */
1976 mp_error_stop_mode /* stops at every opportunity to interact */
1979 @ @<Option variables@>=
1980 int interaction; /* current level of interaction */
1981 int noninteractive; /* do we have a terminal? */
1983 @ Set it here so it can be overwritten by the commandline
1985 @<Allocate or initialize ...@>=
1986 mp->interaction=opt->interaction;
1987 if (mp->interaction==mp_unspecified_mode || mp->interaction>mp_error_stop_mode)
1988 mp->interaction=mp_error_stop_mode;
1989 if (mp->interaction<mp_unspecified_mode)
1990 mp->interaction=mp_batch_mode;
1991 mp->noninteractive=opt->noninteractive;
1995 @d print_err(A) mp_print_err(mp,(A))
1998 void mp_print_err(MP mp, const char * A);
2001 void mp_print_err(MP mp, const char * A) {
2002 if ( mp->interaction==mp_error_stop_mode )
2004 mp_print_nl(mp, "! ");
2010 @ \MP\ is careful not to call |error| when the print |selector| setting
2011 might be unusual. The only possible values of |selector| at the time of
2014 \yskip\hang|no_print| (when |interaction=mp_batch_mode|
2015 and |log_file| not yet open);
2017 \hang|term_only| (when |interaction>mp_batch_mode| and |log_file| not yet open);
2019 \hang|log_only| (when |interaction=mp_batch_mode| and |log_file| is open);
2021 \hang|term_and_log| (when |interaction>mp_batch_mode| and |log_file| is open).
2023 @<Initialize the print |selector| based on |interaction|@>=
2024 if ( mp->interaction==mp_batch_mode ) mp->selector=no_print; else mp->selector=term_only
2026 @ A global variable |deletions_allowed| is set |false| if the |get_next|
2027 routine is active when |error| is called; this ensures that |get_next|
2028 will never be called recursively.
2031 The global variable |history| records the worst level of error that
2032 has been detected. It has four possible values: |spotless|, |warning_issued|,
2033 |error_message_issued|, and |fatal_error_stop|.
2035 Another global variable, |error_count|, is increased by one when an
2036 |error| occurs without an interactive dialog, and it is reset to zero at
2037 the end of every statement. If |error_count| reaches 100, \MP\ decides
2038 that there is no point in continuing further.
2041 enum mp_history_states {
2042 mp_spotless=0, /* |history| value when nothing has been amiss yet */
2043 mp_warning_issued, /* |history| value when |begin_diagnostic| has been called */
2044 mp_error_message_issued, /* |history| value when |error| has been called */
2045 mp_fatal_error_stop, /* |history| value when termination was premature */
2046 mp_system_error_stop /* |history| value when termination was due to disaster */
2050 boolean deletions_allowed; /* is it safe for |error| to call |get_next|? */
2051 int history; /* has the source input been clean so far? */
2052 int error_count; /* the number of scrolled errors since the last statement ended */
2054 @ The value of |history| is initially |fatal_error_stop|, but it will
2055 be changed to |spotless| if \MP\ survives the initialization process.
2057 @<Allocate or ...@>=
2058 mp->deletions_allowed=true; mp->error_count=0; /* |history| is initialized elsewhere */
2060 @ Since errors can be detected almost anywhere in \MP, we want to declare the
2061 error procedures near the beginning of the program. But the error procedures
2062 in turn use some other procedures, which need to be declared |forward|
2063 before we get to |error| itself.
2065 It is possible for |error| to be called recursively if some error arises
2066 when |get_next| is being used to delete a token, and/or if some fatal error
2067 occurs while \MP\ is trying to fix a non-fatal one. But such recursion
2069 is never more than two levels deep.
2072 void mp_get_next (MP mp);
2073 void mp_term_input (MP mp);
2074 void mp_show_context (MP mp);
2075 void mp_begin_file_reading (MP mp);
2076 void mp_open_log_file (MP mp);
2077 void mp_clear_for_error_prompt (MP mp);
2078 void mp_debug_help (MP mp);
2079 @<Declare the procedure called |flush_string|@>
2082 void mp_normalize_selector (MP mp);
2084 @ Individual lines of help are recorded in the array |help_line|, which
2085 contains entries in positions |0..(help_ptr-1)|. They should be printed
2086 in reverse order, i.e., with |help_line[0]| appearing last.
2088 @d hlp1(A) mp->help_line[0]=(A); }
2089 @d hlp2(A) mp->help_line[1]=(A); hlp1
2090 @d hlp3(A) mp->help_line[2]=(A); hlp2
2091 @d hlp4(A) mp->help_line[3]=(A); hlp3
2092 @d hlp5(A) mp->help_line[4]=(A); hlp4
2093 @d hlp6(A) mp->help_line[5]=(A); hlp5
2094 @d help0 mp->help_ptr=0 /* sometimes there might be no help */
2095 @d help1 { mp->help_ptr=1; hlp1 /* use this with one help line */
2096 @d help2 { mp->help_ptr=2; hlp2 /* use this with two help lines */
2097 @d help3 { mp->help_ptr=3; hlp3 /* use this with three help lines */
2098 @d help4 { mp->help_ptr=4; hlp4 /* use this with four help lines */
2099 @d help5 { mp->help_ptr=5; hlp5 /* use this with five help lines */
2100 @d help6 { mp->help_ptr=6; hlp6 /* use this with six help lines */
2103 const char * help_line[6]; /* helps for the next |error| */
2104 unsigned int help_ptr; /* the number of help lines present */
2105 boolean use_err_help; /* should the |err_help| string be shown? */
2106 str_number err_help; /* a string set up by \&{errhelp} */
2107 str_number filename_template; /* a string set up by \&{filenametemplate} */
2109 @ @<Allocate or ...@>=
2110 mp->help_ptr=0; mp->use_err_help=false; mp->err_help=0; mp->filename_template=0;
2112 @ The |jump_out| procedure just cuts across all active procedure levels and
2113 goes to |end_of_MP|. This is the only nonlocal |goto| statement in the
2114 whole program. It is used when there is no recovery from a particular error.
2116 The program uses a |jump_buf| to handle this, this is initialized at three
2117 spots: the start of |mp_new|, the start of |mp_initialize|, and the start
2118 of |mp_run|. Those are the only library enty points.
2120 @^system dependencies@>
2125 @ @<Install and test the non-local jump buffer@>=
2126 mp->jump_buf = &buf;
2127 if (setjmp(*(mp->jump_buf)) != 0) { return mp->history; }
2129 @ @<Setup the non-local jump buffer in |mp_new|@>=
2130 if (setjmp(buf) != 0) { return NULL; }
2133 @ If the array of internals is still |NULL| when |jump_out| is called, a
2134 crash occured during initialization, and it is not safe to run the normal
2138 void mp_jump_out (MP mp) {
2139 if (mp->internal!=NULL && mp->history < mp_system_error_stop)
2140 mp_close_files_and_terminate(mp);
2141 longjmp(*(mp->jump_buf),1);
2144 @ Here now is the general |error| routine.
2147 void mp_error (MP mp) { /* completes the job of error reporting */
2148 ASCII_code c; /* what the user types */
2149 integer s1,s2,s3; /* used to save global variables when deleting tokens */
2150 pool_pointer j; /* character position being printed */
2151 if ( mp->history<mp_error_message_issued )
2152 mp->history=mp_error_message_issued;
2153 mp_print_char(mp, '.'); mp_show_context(mp);
2154 if ((!mp->noninteractive) && (mp->interaction==mp_error_stop_mode )) {
2155 @<Get user's advice and |return|@>;
2157 incr(mp->error_count);
2158 if ( mp->error_count==100 ) {
2159 mp_print_nl(mp,"(That makes 100 errors; please try again.)");
2160 @.That makes 100 errors...@>
2161 mp->history=mp_fatal_error_stop; mp_jump_out(mp);
2163 @<Put help message on the transcript file@>;
2165 void mp_warn (MP mp, const char *msg) {
2166 int saved_selector = mp->selector;
2167 mp_normalize_selector(mp);
2168 mp_print_nl(mp,"Warning: ");
2171 mp->selector = saved_selector;
2174 @ @<Exported function ...@>=
2175 void mp_error (MP mp);
2176 void mp_warn (MP mp, const char *msg);
2179 @ @<Get user's advice...@>=
2182 mp_clear_for_error_prompt(mp); prompt_input("? ");
2184 if ( mp->last==mp->first ) return;
2185 c=mp->buffer[mp->first];
2186 if ( c>='a' ) c=c+'A'-'a'; /* convert to uppercase */
2187 @<Interpret code |c| and |return| if done@>;
2190 @ It is desirable to provide an `\.E' option here that gives the user
2191 an easy way to return from \MP\ to the system editor, with the offending
2192 line ready to be edited. But such an extension requires some system
2193 wizardry, so the present implementation simply types out the name of the
2195 edited and the relevant line number.
2196 @^system dependencies@>
2199 typedef void (*mp_run_editor_command)(MP, char *, int);
2201 @ @<Option variables@>=
2202 mp_run_editor_command run_editor;
2204 @ @<Allocate or initialize ...@>=
2205 set_callback_option(run_editor);
2208 void mp_run_editor (MP mp, char *fname, int fline);
2210 @ @c void mp_run_editor (MP mp, char *fname, int fline) {
2211 mp_print_nl(mp, "You want to edit file ");
2212 @.You want to edit file x@>
2213 mp_print(mp, fname);
2214 mp_print(mp, " at line ");
2215 mp_print_int(mp, fline);
2216 mp->interaction=mp_scroll_mode;
2221 There is a secret `\.D' option available when the debugging routines haven't
2225 @<Interpret code |c| and |return| if done@>=
2227 case '0': case '1': case '2': case '3': case '4':
2228 case '5': case '6': case '7': case '8': case '9':
2229 if ( mp->deletions_allowed ) {
2230 @<Delete |c-"0"| tokens and |continue|@>;
2235 mp_debug_help(mp); continue;
2239 if ( mp->file_ptr>0 ){
2240 (mp->run_editor)(mp,
2241 str(mp->input_stack[mp->file_ptr].name_field),
2246 @<Print the help information and |continue|@>;
2249 @<Introduce new material from the terminal and |return|@>;
2251 case 'Q': case 'R': case 'S':
2252 @<Change the interaction level and |return|@>;
2255 mp->interaction=mp_scroll_mode; mp_jump_out(mp);
2260 @<Print the menu of available options@>
2262 @ @<Print the menu...@>=
2264 mp_print(mp, "Type <return> to proceed, S to scroll future error messages,");
2265 @.Type <return> to proceed...@>
2266 mp_print_nl(mp, "R to run without stopping, Q to run quietly,");
2267 mp_print_nl(mp, "I to insert something, ");
2268 if ( mp->file_ptr>0 )
2269 mp_print(mp, "E to edit your file,");
2270 if ( mp->deletions_allowed )
2271 mp_print_nl(mp, "1 or ... or 9 to ignore the next 1 to 9 tokens of input,");
2272 mp_print_nl(mp, "H for help, X to quit.");
2275 @ Here the author of \MP\ apologizes for making use of the numerical
2276 relation between |"Q"|, |"R"|, |"S"|, and the desired interaction settings
2277 |mp_batch_mode|, |mp_nonstop_mode|, |mp_scroll_mode|.
2278 @^Knuth, Donald Ervin@>
2280 @<Change the interaction...@>=
2282 mp->error_count=0; mp->interaction=mp_batch_mode+c-'Q';
2283 mp_print(mp, "OK, entering ");
2285 case 'Q': mp_print(mp, "batchmode"); decr(mp->selector); break;
2286 case 'R': mp_print(mp, "nonstopmode"); break;
2287 case 'S': mp_print(mp, "scrollmode"); break;
2288 } /* there are no other cases */
2289 mp_print(mp, "..."); mp_print_ln(mp); update_terminal; return;
2292 @ When the following code is executed, |buffer[(first+1)..(last-1)]| may
2293 contain the material inserted by the user; otherwise another prompt will
2294 be given. In order to understand this part of the program fully, you need
2295 to be familiar with \MP's input stacks.
2297 @<Introduce new material...@>=
2299 mp_begin_file_reading(mp); /* enter a new syntactic level for terminal input */
2300 if ( mp->last>mp->first+1 ) {
2301 loc=mp->first+1; mp->buffer[mp->first]=' ';
2303 prompt_input("insert>"); loc=mp->first;
2306 mp->first=mp->last+1; mp->cur_input.limit_field=mp->last; return;
2309 @ We allow deletion of up to 99 tokens at a time.
2311 @<Delete |c-"0"| tokens...@>=
2313 s1=mp->cur_cmd; s2=mp->cur_mod; s3=mp->cur_sym; mp->OK_to_interrupt=false;
2314 if ( (mp->last>mp->first+1) && (mp->buffer[mp->first+1]>='0')&&(mp->buffer[mp->first+1]<='9') )
2315 c=c*10+mp->buffer[mp->first+1]-'0'*11;
2319 mp_get_next(mp); /* one-level recursive call of |error| is possible */
2320 @<Decrease the string reference count, if the current token is a string@>;
2323 mp->cur_cmd=s1; mp->cur_mod=s2; mp->cur_sym=s3; mp->OK_to_interrupt=true;
2324 help2("I have just deleted some text, as you asked.")
2325 ("You can now delete more, or insert, or whatever.");
2326 mp_show_context(mp);
2330 @ @<Print the help info...@>=
2332 if ( mp->use_err_help ) {
2333 @<Print the string |err_help|, possibly on several lines@>;
2334 mp->use_err_help=false;
2336 if ( mp->help_ptr==0 ) {
2337 help2("Sorry, I don't know how to help in this situation.")
2338 ("Maybe you should try asking a human?");
2341 decr(mp->help_ptr); mp_print(mp, mp->help_line[mp->help_ptr]); mp_print_ln(mp);
2342 } while (mp->help_ptr!=0);
2344 help4("Sorry, I already gave what help I could...")
2345 ("Maybe you should try asking a human?")
2346 ("An error might have occurred before I noticed any problems.")
2347 ("``If all else fails, read the instructions.''");
2351 @ @<Print the string |err_help|, possibly on several lines@>=
2352 j=mp->str_start[mp->err_help];
2353 while ( j<str_stop(mp->err_help) ) {
2354 if ( mp->str_pool[j]!='%' ) mp_print_str(mp, mp->str_pool[j]);
2355 else if ( j+1==str_stop(mp->err_help) ) mp_print_ln(mp);
2356 else if ( mp->str_pool[j+1]!='%' ) mp_print_ln(mp);
2357 else { incr(j); mp_print_char(mp, '%'); };
2361 @ @<Put help message on the transcript file@>=
2362 if ( mp->interaction>mp_batch_mode ) decr(mp->selector); /* avoid terminal output */
2363 if ( mp->use_err_help ) {
2364 mp_print_nl(mp, "");
2365 @<Print the string |err_help|, possibly on several lines@>;
2367 while ( mp->help_ptr>0 ){
2368 decr(mp->help_ptr); mp_print_nl(mp, mp->help_line[mp->help_ptr]);
2372 if ( mp->interaction>mp_batch_mode ) incr(mp->selector); /* re-enable terminal output */
2375 @ In anomalous cases, the print selector might be in an unknown state;
2376 the following subroutine is called to fix things just enough to keep
2377 running a bit longer.
2380 void mp_normalize_selector (MP mp) {
2381 if ( mp->log_opened ) mp->selector=term_and_log;
2382 else mp->selector=term_only;
2383 if ( mp->job_name==NULL ) mp_open_log_file(mp);
2384 if ( mp->interaction==mp_batch_mode ) decr(mp->selector);
2387 @ The following procedure prints \MP's last words before dying.
2389 @d succumb { if ( mp->interaction==mp_error_stop_mode )
2390 mp->interaction=mp_scroll_mode; /* no more interaction */
2391 if ( mp->log_opened ) mp_error(mp);
2392 /*| if ( mp->interaction>mp_batch_mode ) mp_debug_help(mp); |*/
2393 mp->history=mp_fatal_error_stop; mp_jump_out(mp); /* irrecoverable error */
2397 void mp_fatal_error (MP mp, const char *s) { /* prints |s|, and that's it */
2398 mp_normalize_selector(mp);
2399 print_err("Emergency stop"); help1(s); succumb;
2403 @ @<Exported function ...@>=
2404 void mp_fatal_error (MP mp, const char *s);
2407 @ Here is the most dreaded error message.
2410 void mp_overflow (MP mp, const char *s, integer n) { /* stop due to finiteness */
2411 mp_normalize_selector(mp);
2412 print_err("MetaPost capacity exceeded, sorry [");
2413 @.MetaPost capacity exceeded ...@>
2414 mp_print(mp, s); mp_print_char(mp, '='); mp_print_int(mp, n); mp_print_char(mp, ']');
2415 help2("If you really absolutely need more capacity,")
2416 ("you can ask a wizard to enlarge me.");
2420 @ @<Internal library declarations@>=
2421 void mp_overflow (MP mp, const char *s, integer n);
2423 @ The program might sometime run completely amok, at which point there is
2424 no choice but to stop. If no previous error has been detected, that's bad
2425 news; a message is printed that is really intended for the \MP\
2426 maintenance person instead of the user (unless the user has been
2427 particularly diabolical). The index entries for `this can't happen' may
2428 help to pinpoint the problem.
2431 @<Internal library ...@>=
2432 void mp_confusion (MP mp, const char *s);
2434 @ @<Error hand...@>=
2435 void mp_confusion (MP mp, const char *s) {
2436 /* consistency check violated; |s| tells where */
2437 mp_normalize_selector(mp);
2438 if ( mp->history<mp_error_message_issued ) {
2439 print_err("This can't happen ("); mp_print(mp, s); mp_print_char(mp, ')');
2440 @.This can't happen@>
2441 help1("I'm broken. Please show this to someone who can fix can fix");
2443 print_err("I can\'t go on meeting you like this");
2444 @.I can't go on...@>
2445 help2("One of your faux pas seems to have wounded me deeply...")
2446 ("in fact, I'm barely conscious. Please fix it and try again.");
2451 @ Users occasionally want to interrupt \MP\ while it's running.
2452 If the runtime system allows this, one can implement
2453 a routine that sets the global variable |interrupt| to some nonzero value
2454 when such an interrupt is signaled. Otherwise there is probably at least
2455 a way to make |interrupt| nonzero using the C debugger.
2456 @^system dependencies@>
2459 @d check_interrupt { if ( mp->interrupt!=0 )
2460 mp_pause_for_instructions(mp); }
2463 integer interrupt; /* should \MP\ pause for instructions? */
2464 boolean OK_to_interrupt; /* should interrupts be observed? */
2465 integer run_state; /* are we processing input ?*/
2467 @ @<Allocate or ...@>=
2468 mp->interrupt=0; mp->OK_to_interrupt=true; mp->run_state=0;
2470 @ When an interrupt has been detected, the program goes into its
2471 highest interaction level and lets the user have the full flexibility of
2472 the |error| routine. \MP\ checks for interrupts only at times when it is
2476 void mp_pause_for_instructions (MP mp) {
2477 if ( mp->OK_to_interrupt ) {
2478 mp->interaction=mp_error_stop_mode;
2479 if ( (mp->selector==log_only)||(mp->selector==no_print) )
2481 print_err("Interruption");
2484 ("Try to insert some instructions for me (e.g.,`I show x'),")
2485 ("unless you just want to quit by typing `X'.");
2486 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
2491 @ Many of \MP's error messages state that a missing token has been
2492 inserted behind the scenes. We can save string space and program space
2493 by putting this common code into a subroutine.
2496 void mp_missing_err (MP mp, const char *s) {
2497 print_err("Missing `"); mp_print(mp, s); mp_print(mp, "' has been inserted");
2498 @.Missing...inserted@>
2501 @* \[7] Arithmetic with scaled numbers.
2502 The principal computations performed by \MP\ are done entirely in terms of
2503 integers less than $2^{31}$ in magnitude; thus, the arithmetic specified in this
2504 program can be carried out in exactly the same way on a wide variety of
2505 computers, including some small ones.
2508 But C does not rigidly define the |/| operation in the case of negative
2509 dividends; for example, the result of |(-2*n-1) / 2| is |-(n+1)| on some
2510 computers and |-n| on others (is this true ?). There are two principal
2511 types of arithmetic: ``translation-preserving,'' in which the identity
2512 |(a+q*b)/b=(a/b)+q| is valid; and ``negation-preserving,'' in which
2513 |(-a)/b=-(a/b)|. This leads to two \MP s, which can produce
2514 different results, although the differences should be negligible when the
2515 language is being used properly. The \TeX\ processor has been defined
2516 carefully so that both varieties of arithmetic will produce identical
2517 output, but it would be too inefficient to constrain \MP\ in a similar way.
2519 @d el_gordo 017777777777 /* $2^{31}-1$, the largest value that \MP\ likes */
2521 @ One of \MP's most common operations is the calculation of
2522 $\lfloor{a+b\over2}\rfloor$,
2523 the midpoint of two given integers |a| and~|b|. The most decent way to do
2524 this is to write `|(a+b)/2|'; but on many machines it is more efficient
2525 to calculate `|(a+b)>>1|'.
2527 Therefore the midpoint operation will always be denoted by `|half(a+b)|'
2528 in this program. If \MP\ is being implemented with languages that permit
2529 binary shifting, the |half| macro should be changed to make this operation
2530 as efficient as possible. Since some systems have shift operators that can
2531 only be trusted to work on positive numbers, there is also a macro |halfp|
2532 that is used only when the quantity being halved is known to be positive
2535 @d half(A) ((A) / 2)
2536 @d halfp(A) ((A) >> 1)
2538 @ A single computation might use several subroutine calls, and it is
2539 desirable to avoid producing multiple error messages in case of arithmetic
2540 overflow. So the routines below set the global variable |arith_error| to |true|
2541 instead of reporting errors directly to the user.
2542 @^overflow in arithmetic@>
2545 boolean arith_error; /* has arithmetic overflow occurred recently? */
2547 @ @<Allocate or ...@>=
2548 mp->arith_error=false;
2550 @ At crucial points the program will say |check_arith|, to test if
2551 an arithmetic error has been detected.
2553 @d check_arith { if ( mp->arith_error ) mp_clear_arith(mp); }
2556 void mp_clear_arith (MP mp) {
2557 print_err("Arithmetic overflow");
2558 @.Arithmetic overflow@>
2559 help4("Uh, oh. A little while ago one of the quantities that I was")
2560 ("computing got too large, so I'm afraid your answers will be")
2561 ("somewhat askew. You'll probably have to adopt different")
2562 ("tactics next time. But I shall try to carry on anyway.");
2564 mp->arith_error=false;
2567 @ Addition is not always checked to make sure that it doesn't overflow,
2568 but in places where overflow isn't too unlikely the |slow_add| routine
2571 @c integer mp_slow_add (MP mp,integer x, integer y) {
2573 if ( y<=el_gordo-x ) {
2576 mp->arith_error=true;
2579 } else if ( -y<=el_gordo+x ) {
2582 mp->arith_error=true;
2587 @ Fixed-point arithmetic is done on {\sl scaled integers\/} that are multiples
2588 of $2^{-16}$. In other words, a binary point is assumed to be sixteen bit
2589 positions from the right end of a binary computer word.
2591 @d quarter_unit 040000 /* $2^{14}$, represents 0.250000 */
2592 @d half_unit 0100000 /* $2^{15}$, represents 0.50000 */
2593 @d three_quarter_unit 0140000 /* $3\cdot2^{14}$, represents 0.75000 */
2594 @d unity 0200000 /* $2^{16}$, represents 1.00000 */
2595 @d two 0400000 /* $2^{17}$, represents 2.00000 */
2596 @d three 0600000 /* $2^{17}+2^{16}$, represents 3.00000 */
2599 typedef integer scaled; /* this type is used for scaled integers */
2600 typedef unsigned char small_number; /* this type is self-explanatory */
2602 @ The following function is used to create a scaled integer from a given decimal
2603 fraction $(.d_0d_1\ldots d_{k-1})$, where |0<=k<=17|. The digit $d_i$ is
2604 given in |dig[i]|, and the calculation produces a correctly rounded result.
2607 scaled mp_round_decimals (MP mp,small_number k) {
2608 /* converts a decimal fraction */
2609 integer a = 0; /* the accumulator */
2611 a=(a+mp->dig[k]*two) / 10;
2616 @ Conversely, here is a procedure analogous to |print_int|. If the output
2617 of this procedure is subsequently read by \MP\ and converted by the
2618 |round_decimals| routine above, it turns out that the original value will
2619 be reproduced exactly. A decimal point is printed only if the value is
2620 not an integer. If there is more than one way to print the result with
2621 the optimum number of digits following the decimal point, the closest
2622 possible value is given.
2624 The invariant relation in the \&{repeat} loop is that a sequence of
2625 decimal digits yet to be printed will yield the original number if and only if
2626 they form a fraction~$f$ in the range $s-\delta\L10\cdot2^{16}f<s$.
2627 We can stop if and only if $f=0$ satisfies this condition; the loop will
2628 terminate before $s$ can possibly become zero.
2630 @<Basic printing...@>=
2631 void mp_print_scaled (MP mp,scaled s) { /* prints scaled real, rounded to five digits */
2632 scaled delta; /* amount of allowable inaccuracy */
2634 mp_print_char(mp, '-');
2635 negate(s); /* print the sign, if negative */
2637 mp_print_int(mp, s / unity); /* print the integer part */
2641 mp_print_char(mp, '.');
2644 s=s+0100000-(delta / 2); /* round the final digit */
2645 mp_print_char(mp, '0'+(s / unity));
2652 @ We often want to print two scaled quantities in parentheses,
2653 separated by a comma.
2655 @<Basic printing...@>=
2656 void mp_print_two (MP mp,scaled x, scaled y) { /* prints `|(x,y)|' */
2657 mp_print_char(mp, '(');
2658 mp_print_scaled(mp, x);
2659 mp_print_char(mp, ',');
2660 mp_print_scaled(mp, y);
2661 mp_print_char(mp, ')');
2664 @ The |scaled| quantities in \MP\ programs are generally supposed to be
2665 less than $2^{12}$ in absolute value, so \MP\ does much of its internal
2666 arithmetic with 28~significant bits of precision. A |fraction| denotes
2667 a scaled integer whose binary point is assumed to be 28 bit positions
2670 @d fraction_half 01000000000 /* $2^{27}$, represents 0.50000000 */
2671 @d fraction_one 02000000000 /* $2^{28}$, represents 1.00000000 */
2672 @d fraction_two 04000000000 /* $2^{29}$, represents 2.00000000 */
2673 @d fraction_three 06000000000 /* $3\cdot2^{28}$, represents 3.00000000 */
2674 @d fraction_four 010000000000 /* $2^{30}$, represents 4.00000000 */
2677 typedef integer fraction; /* this type is used for scaled fractions */
2679 @ In fact, the two sorts of scaling discussed above aren't quite
2680 sufficient; \MP\ has yet another, used internally to keep track of angles
2681 in units of $2^{-20}$ degrees.
2683 @d forty_five_deg 0264000000 /* $45\cdot2^{20}$, represents $45^\circ$ */
2684 @d ninety_deg 0550000000 /* $90\cdot2^{20}$, represents $90^\circ$ */
2685 @d one_eighty_deg 01320000000 /* $180\cdot2^{20}$, represents $180^\circ$ */
2686 @d three_sixty_deg 02640000000 /* $360\cdot2^{20}$, represents $360^\circ$ */
2689 typedef integer angle; /* this type is used for scaled angles */
2691 @ The |make_fraction| routine produces the |fraction| equivalent of
2692 |p/q|, given integers |p| and~|q|; it computes the integer
2693 $f=\lfloor2^{28}p/q+{1\over2}\rfloor$, when $p$ and $q$ are
2694 positive. If |p| and |q| are both of the same scaled type |t|,
2695 the ``type relation'' |make_fraction(t,t)=fraction| is valid;
2696 and it's also possible to use the subroutine ``backwards,'' using
2697 the relation |make_fraction(t,fraction)=t| between scaled types.
2699 If the result would have magnitude $2^{31}$ or more, |make_fraction|
2700 sets |arith_error:=true|. Most of \MP's internal computations have
2701 been designed to avoid this sort of error.
2703 If this subroutine were programmed in assembly language on a typical
2704 machine, we could simply compute |(@t$2^{28}$@>*p)div q|, since a
2705 double-precision product can often be input to a fixed-point division
2706 instruction. But when we are restricted to int-eger arithmetic it
2707 is necessary either to resort to multiple-precision maneuvering
2708 or to use a simple but slow iteration. The multiple-precision technique
2709 would be about three times faster than the code adopted here, but it
2710 would be comparatively long and tricky, involving about sixteen
2711 additional multiplications and divisions.
2713 This operation is part of \MP's ``inner loop''; indeed, it will
2714 consume nearly 10\pct! of the running time (exclusive of input and output)
2715 if the code below is left unchanged. A machine-dependent recoding
2716 will therefore make \MP\ run faster. The present implementation
2717 is highly portable, but slow; it avoids multiplication and division
2718 except in the initial stage. System wizards should be careful to
2719 replace it with a routine that is guaranteed to produce identical
2720 results in all cases.
2721 @^system dependencies@>
2723 As noted below, a few more routines should also be replaced by machine-dependent
2724 code, for efficiency. But when a procedure is not part of the ``inner loop,''
2725 such changes aren't advisable; simplicity and robustness are
2726 preferable to trickery, unless the cost is too high.
2730 fraction mp_make_fraction (MP mp,integer p, integer q);
2731 integer mp_take_scaled (MP mp,integer q, scaled f) ;
2733 @ If FIXPT is not defined, we need these preprocessor values
2735 @d ELGORDO 0x7fffffff
2736 @d TWEXP31 2147483648.0
2737 @d TWEXP28 268435456.0
2739 @d TWEXP_16 (1.0/65536.0)
2740 @d TWEXP_28 (1.0/268435456.0)
2744 fraction mp_make_fraction (MP mp,integer p, integer q) {
2746 integer f; /* the fraction bits, with a leading 1 bit */
2747 integer n; /* the integer part of $\vert p/q\vert$ */
2748 integer be_careful; /* disables certain compiler optimizations */
2749 boolean negative = false; /* should the result be negated? */
2751 negate(p); negative=true;
2755 if ( q==0 ) mp_confusion(mp, '/');
2757 @:this can't happen /}{\quad \./@>
2758 negate(q); negative = ! negative;
2762 mp->arith_error=true;
2763 return ( negative ? -el_gordo : el_gordo);
2765 n=(n-1)*fraction_one;
2766 @<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>;
2767 return (negative ? (-(f+n)) : (f+n));
2773 if (q==0) mp_confusion(mp,'/');
2775 d = TWEXP28 * (double)p /(double)q;
2778 if (d>=TWEXP31) {mp->arith_error=true; return ELGORDO;}
2780 if (d==i && ( ((q>0 ? -q : q)&077777)
2781 * (((i&037777)<<1)-1) & 04000)!=0) --i;
2784 if (d<= -TWEXP31) {mp->arith_error=true; return -ELGORDO;}
2786 if (d==i && ( ((q>0 ? q : -q)&077777)
2787 * (((i&037777)<<1)+1) & 04000)!=0) ++i;
2793 @ The |repeat| loop here preserves the following invariant relations
2794 between |f|, |p|, and~|q|:
2795 (i)~|0<=p<q|; (ii)~$fq+p=2^k(q+p_0)$, where $k$ is an integer and
2796 $p_0$ is the original value of~$p$.
2798 Notice that the computation specifies
2799 |(p-q)+p| instead of |(p+p)-q|, because the latter could overflow.
2800 Let us hope that optimizing compilers do not miss this point; a
2801 special variable |be_careful| is used to emphasize the necessary
2802 order of computation. Optimizing compilers should keep |be_careful|
2803 in a register, not store it in memory.
2806 @<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>=
2810 be_careful=p-q; p=be_careful+p;
2816 } while (f<fraction_one);
2818 if ( be_careful+p>=0 ) incr(f);
2821 @ The dual of |make_fraction| is |take_fraction|, which multiplies a
2822 given integer~|q| by a fraction~|f|. When the operands are positive, it
2823 computes $p=\lfloor qf/2^{28}+{1\over2}\rfloor$, a symmetric function
2826 This routine is even more ``inner loopy'' than |make_fraction|;
2827 the present implementation consumes almost 20\pct! of \MP's computation
2828 time during typical jobs, so a machine-language substitute is advisable.
2829 @^inner loop@> @^system dependencies@>
2832 integer mp_take_fraction (MP mp,integer q, fraction f) ;
2836 integer mp_take_fraction (MP mp,integer q, fraction f) {
2837 integer p; /* the fraction so far */
2838 boolean negative; /* should the result be negated? */
2839 integer n; /* additional multiple of $q$ */
2840 integer be_careful; /* disables certain compiler optimizations */
2841 @<Reduce to the case that |f>=0| and |q>=0|@>;
2842 if ( f<fraction_one ) {
2845 n=f / fraction_one; f=f % fraction_one;
2846 if ( q<=el_gordo / n ) {
2849 mp->arith_error=true; n=el_gordo;
2853 @<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>;
2854 be_careful=n-el_gordo;
2855 if ( be_careful+p>0 ){
2856 mp->arith_error=true; n=el_gordo-p;
2863 integer mp_take_fraction (MP mp,integer p, fraction q) {
2866 d = (double)p * (double)q * TWEXP_28;
2870 if (d!=TWEXP31 || (((p&077777)*(q&077777))&040000)==0)
2871 mp->arith_error = true;
2875 if (d==i && (((p&077777)*(q&077777))&040000)!=0) --i;
2879 if (d!= -TWEXP31 || ((-(p&077777)*(q&077777))&040000)==0)
2880 mp->arith_error = true;
2884 if (d==i && ((-(p&077777)*(q&077777))&040000)!=0) ++i;
2890 @ @<Reduce to the case that |f>=0| and |q>=0|@>=
2894 negate( f); negative=true;
2897 negate(q); negative=! negative;
2900 @ The invariant relations in this case are (i)~$\lfloor(qf+p)/2^k\rfloor
2901 =\lfloor qf_0/2^{28}+{1\over2}\rfloor$, where $k$ is an integer and
2902 $f_0$ is the original value of~$f$; (ii)~$2^k\L f<2^{k+1}$.
2905 @<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>=
2906 p=fraction_half; /* that's $2^{27}$; the invariants hold now with $k=28$ */
2907 if ( q<fraction_four ) {
2909 if ( odd(f) ) p=halfp(p+q); else p=halfp(p);
2914 if ( odd(f) ) p=p+halfp(q-p); else p=halfp(p);
2920 @ When we want to multiply something by a |scaled| quantity, we use a scheme
2921 analogous to |take_fraction| but with a different scaling.
2922 Given positive operands, |take_scaled|
2923 computes the quantity $p=\lfloor qf/2^{16}+{1\over2}\rfloor$.
2925 Once again it is a good idea to use a machine-language replacement if
2926 possible; otherwise |take_scaled| will use more than 2\pct! of the running time
2927 when the Computer Modern fonts are being generated.
2932 integer mp_take_scaled (MP mp,integer q, scaled f) {
2933 integer p; /* the fraction so far */
2934 boolean negative; /* should the result be negated? */
2935 integer n; /* additional multiple of $q$ */
2936 integer be_careful; /* disables certain compiler optimizations */
2937 @<Reduce to the case that |f>=0| and |q>=0|@>;
2941 n=f / unity; f=f % unity;
2942 if ( q<=el_gordo / n ) {
2945 mp->arith_error=true; n=el_gordo;
2949 @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>;
2950 be_careful=n-el_gordo;
2951 if ( be_careful+p>0 ) {
2952 mp->arith_error=true; n=el_gordo-p;
2954 return ( negative ?(-(n+p)) :(n+p));
2956 integer mp_take_scaled (MP mp,integer p, scaled q) {
2959 d = (double)p * (double)q * TWEXP_16;
2963 if (d!=TWEXP31 || (((p&077777)*(q&077777))&040000)==0)
2964 mp->arith_error = true;
2968 if (d==i && (((p&077777)*(q&077777))&040000)!=0) --i;
2972 if (d!= -TWEXP31 || ((-(p&077777)*(q&077777))&040000)==0)
2973 mp->arith_error = true;
2977 if (d==i && ((-(p&077777)*(q&077777))&040000)!=0) ++i;
2983 @ @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>=
2984 p=half_unit; /* that's $2^{15}$; the invariants hold now with $k=16$ */
2986 if ( q<fraction_four ) {
2988 p = (odd(f) ? halfp(p+q) : halfp(p));
2993 p = (odd(f) ? p+halfp(q-p) : halfp(p));
2998 @ For completeness, there's also |make_scaled|, which computes a
2999 quotient as a |scaled| number instead of as a |fraction|.
3000 In other words, the result is $\lfloor2^{16}p/q+{1\over2}\rfloor$, if the
3001 operands are positive. \ (This procedure is not used especially often,
3002 so it is not part of \MP's inner loop.)
3004 @<Internal library ...@>=
3005 scaled mp_make_scaled (MP mp,integer p, integer q) ;
3008 scaled mp_make_scaled (MP mp,integer p, integer q) {
3010 integer f; /* the fraction bits, with a leading 1 bit */
3011 integer n; /* the integer part of $\vert p/q\vert$ */
3012 boolean negative; /* should the result be negated? */
3013 integer be_careful; /* disables certain compiler optimizations */
3014 if ( p>=0 ) negative=false;
3015 else { negate(p); negative=true; };
3018 if ( q==0 ) mp_confusion(mp, "/");
3019 @:this can't happen /}{\quad \./@>
3021 negate(q); negative=! negative;
3025 mp->arith_error=true;
3026 return (negative ? (-el_gordo) : el_gordo);
3029 @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>;
3030 return ( negative ? (-(f+n)) :(f+n));
3036 if (q==0) mp_confusion(mp,"/");
3038 d = TWEXP16 * (double)p /(double)q;
3041 if (d>=TWEXP31) {mp->arith_error=true; return ELGORDO;}
3043 if (d==i && ( ((q>0 ? -q : q)&077777)
3044 * (((i&037777)<<1)-1) & 04000)!=0) --i;
3047 if (d<= -TWEXP31) {mp->arith_error=true; return -ELGORDO;}
3049 if (d==i && ( ((q>0 ? q : -q)&077777)
3050 * (((i&037777)<<1)+1) & 04000)!=0) ++i;
3056 @ @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>=
3059 be_careful=p-q; p=be_careful+p;
3060 if ( p>=0 ) f=f+f+1;
3061 else { f+=f; p=p+q; };
3064 if ( be_careful+p>=0 ) incr(f)
3066 @ Here is a typical example of how the routines above can be used.
3067 It computes the function
3068 $${1\over3\tau}f(\theta,\phi)=
3069 {\tau^{-1}\bigl(2+\sqrt2\,(\sin\theta-{1\over16}\sin\phi)
3070 (\sin\phi-{1\over16}\sin\theta)(\cos\theta-\cos\phi)\bigr)\over
3071 3\,\bigl(1+{1\over2}(\sqrt5-1)\cos\theta+{1\over2}(3-\sqrt5\,)\cos\phi\bigr)},$$
3072 where $\tau$ is a |scaled| ``tension'' parameter. This is \MP's magic
3073 fudge factor for placing the first control point of a curve that starts
3074 at an angle $\theta$ and ends at an angle $\phi$ from the straight path.
3075 (Actually, if the stated quantity exceeds 4, \MP\ reduces it to~4.)
3077 The trigonometric quantity to be multiplied by $\sqrt2$ is less than $\sqrt2$.
3078 (It's a sum of eight terms whose absolute values can be bounded using
3079 relations such as $\sin\theta\cos\theta\L{1\over2}$.) Thus the numerator
3080 is positive; and since the tension $\tau$ is constrained to be at least
3081 $3\over4$, the numerator is less than $16\over3$. The denominator is
3082 nonnegative and at most~6. Hence the fixed-point calculations below
3083 are guaranteed to stay within the bounds of a 32-bit computer word.
3085 The angles $\theta$ and $\phi$ are given implicitly in terms of |fraction|
3086 arguments |st|, |ct|, |sf|, and |cf|, representing $\sin\theta$, $\cos\theta$,
3087 $\sin\phi$, and $\cos\phi$, respectively.
3090 fraction mp_velocity (MP mp,fraction st, fraction ct, fraction sf,
3091 fraction cf, scaled t) {
3092 integer acc,num,denom; /* registers for intermediate calculations */
3093 acc=mp_take_fraction(mp, st-(sf / 16), sf-(st / 16));
3094 acc=mp_take_fraction(mp, acc,ct-cf);
3095 num=fraction_two+mp_take_fraction(mp, acc,379625062);
3096 /* $2^{28}\sqrt2\approx379625062.497$ */
3097 denom=fraction_three+mp_take_fraction(mp, ct,497706707)+mp_take_fraction(mp, cf,307599661);
3098 /* $3\cdot2^{27}\cdot(\sqrt5-1)\approx497706706.78$ and
3099 $3\cdot2^{27}\cdot(3-\sqrt5\,)\approx307599661.22$ */
3100 if ( t!=unity ) num=mp_make_scaled(mp, num,t);
3101 /* |make_scaled(fraction,scaled)=fraction| */
3102 if ( num / 4>=denom )
3103 return fraction_four;
3105 return mp_make_fraction(mp, num, denom);
3108 @ The following somewhat different subroutine tests rigorously if $ab$ is
3109 greater than, equal to, or less than~$cd$,
3110 given integers $(a,b,c,d)$. In most cases a quick decision is reached.
3111 The result is $+1$, 0, or~$-1$ in the three respective cases.
3113 @d mp_ab_vs_cd(M,A,B,C,D) mp_do_ab_vs_cd(A,B,C,D)
3116 integer mp_do_ab_vs_cd (integer a,integer b, integer c, integer d) {
3117 integer q,r; /* temporary registers */
3118 @<Reduce to the case that |a,c>=0|, |b,d>0|@>;
3120 q = a / d; r = c / b;
3122 return ( q>r ? 1 : -1);
3123 q = a % d; r = c % b;
3126 if ( q==0 ) return -1;
3128 } /* now |a>d>0| and |c>b>0| */
3131 @ @<Reduce to the case that |a...@>=
3132 if ( a<0 ) { negate(a); negate(b); };
3133 if ( c<0 ) { negate(c); negate(d); };
3136 if ( (a==0||b==0)&&(c==0||d==0) ) return 0;
3140 return ( a==0 ? 0 : -1);
3141 q=a; a=c; c=q; q=-b; b=-d; d=q;
3142 } else if ( b<=0 ) {
3143 if ( b<0 ) if ( a>0 ) return -1;
3144 return (c==0 ? 0 : -1);
3147 @ We conclude this set of elementary routines with some simple rounding
3148 and truncation operations.
3150 @<Internal library declarations@>=
3151 #define mp_floor_scaled(M,i) ((i)&(-65536))
3152 #define mp_round_unscaled(M,i) (((i>>15)+1)>>1)
3153 #define mp_round_fraction(M,i) (((i>>11)+1)>>1)
3156 @* \[8] Algebraic and transcendental functions.
3157 \MP\ computes all of the necessary special functions from scratch, without
3158 relying on |real| arithmetic or system subroutines for sines, cosines, etc.
3160 @ To get the square root of a |scaled| number |x|, we want to calculate
3161 $s=\lfloor 2^8\!\sqrt x +{1\over2}\rfloor$. If $x>0$, this is the unique
3162 integer such that $2^{16}x-s\L s^2<2^{16}x+s$. The following subroutine
3163 determines $s$ by an iterative method that maintains the invariant
3164 relations $x=2^{46-2k}x_0\bmod 2^{30}$, $0<y=\lfloor 2^{16-2k}x_0\rfloor
3165 -s^2+s\L q=2s$, where $x_0$ is the initial value of $x$. The value of~$y$
3166 might, however, be zero at the start of the first iteration.
3169 scaled mp_square_rt (MP mp,scaled x) ;
3172 scaled mp_square_rt (MP mp,scaled x) {
3173 small_number k; /* iteration control counter */
3174 integer y,q; /* registers for intermediate calculations */
3176 @<Handle square root of zero or negative argument@>;
3179 while ( x<fraction_two ) { /* i.e., |while x<@t$2^{29}$@>|\unskip */
3182 if ( x<fraction_four ) y=0;
3183 else { x=x-fraction_four; y=1; };
3185 @<Decrease |k| by 1, maintaining the invariant
3186 relations between |x|, |y|, and~|q|@>;
3192 @ @<Handle square root of zero...@>=
3195 print_err("Square root of ");
3196 @.Square root...replaced by 0@>
3197 mp_print_scaled(mp, x); mp_print(mp, " has been replaced by 0");
3198 help2("Since I don't take square roots of negative numbers,")
3199 ("I'm zeroing this one. Proceed, with fingers crossed.");
3205 @ @<Decrease |k| by 1, maintaining...@>=
3207 if ( x>=fraction_four ) { /* note that |fraction_four=@t$2^{30}$@>| */
3208 x=x-fraction_four; incr(y);
3210 x+=x; y=y+y-q; q+=q;
3211 if ( x>=fraction_four ) { x=x-fraction_four; incr(y); };
3212 if ( y>q ){ y=y-q; q=q+2; }
3213 else if ( y<=0 ) { q=q-2; y=y+q; };
3216 @ Pythagorean addition $\psqrt{a^2+b^2}$ is implemented by an elegant
3217 iterative scheme due to Cleve Moler and Donald Morrison [{\sl IBM Journal
3218 @^Moler, Cleve Barry@>
3219 @^Morrison, Donald Ross@>
3220 of Research and Development\/ \bf27} (1983), 577--581]. It modifies |a| and~|b|
3221 in such a way that their Pythagorean sum remains invariant, while the
3222 smaller argument decreases.
3224 @<Internal library ...@>=
3225 integer mp_pyth_add (MP mp,integer a, integer b);
3229 integer mp_pyth_add (MP mp,integer a, integer b) {
3230 fraction r; /* register used to transform |a| and |b| */
3231 boolean big; /* is the result dangerously near $2^{31}$? */
3233 if ( a<b ) { r=b; b=a; a=r; }; /* now |0<=b<=a| */
3235 if ( a<fraction_two ) {
3238 a=a / 4; b=b / 4; big=true;
3239 }; /* we reduced the precision to avoid arithmetic overflow */
3240 @<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>;
3242 if ( a<fraction_two ) {
3245 mp->arith_error=true; a=el_gordo;
3252 @ The key idea here is to reflect the vector $(a,b)$ about the
3253 line through $(a,b/2)$.
3255 @<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>=
3257 r=mp_make_fraction(mp, b,a);
3258 r=mp_take_fraction(mp, r,r); /* now $r\approx b^2/a^2$ */
3260 r=mp_make_fraction(mp, r,fraction_four+r);
3261 a=a+mp_take_fraction(mp, a+a,r); b=mp_take_fraction(mp, b,r);
3265 @ Here is a similar algorithm for $\psqrt{a^2-b^2}$.
3266 It converges slowly when $b$ is near $a$, but otherwise it works fine.
3269 integer mp_pyth_sub (MP mp,integer a, integer b) {
3270 fraction r; /* register used to transform |a| and |b| */
3271 boolean big; /* is the input dangerously near $2^{31}$? */
3274 @<Handle erroneous |pyth_sub| and set |a:=0|@>;
3276 if ( a<fraction_four ) {
3279 a=halfp(a); b=halfp(b); big=true;
3281 @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>;
3282 if ( big ) double(a);
3287 @ @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>=
3289 r=mp_make_fraction(mp, b,a);
3290 r=mp_take_fraction(mp, r,r); /* now $r\approx b^2/a^2$ */
3292 r=mp_make_fraction(mp, r,fraction_four-r);
3293 a=a-mp_take_fraction(mp, a+a,r); b=mp_take_fraction(mp, b,r);
3296 @ @<Handle erroneous |pyth_sub| and set |a:=0|@>=
3299 print_err("Pythagorean subtraction "); mp_print_scaled(mp, a);
3300 mp_print(mp, "+-+"); mp_print_scaled(mp, b);
3301 mp_print(mp, " has been replaced by 0");
3303 help2("Since I don't take square roots of negative numbers,")
3304 ("I'm zeroing this one. Proceed, with fingers crossed.");
3310 @ The subroutines for logarithm and exponential involve two tables.
3311 The first is simple: |two_to_the[k]| equals $2^k$. The second involves
3312 a bit more calculation, which the author claims to have done correctly:
3313 |spec_log[k]| is $2^{27}$ times $\ln\bigl(1/(1-2^{-k})\bigr)=
3314 2^{-k}+{1\over2}2^{-2k}+{1\over3}2^{-3k}+\cdots\,$, rounded to the
3317 @d two_to_the(A) (1<<(A))
3320 static const integer spec_log[29] = { 0, /* special logarithms */
3321 93032640, 38612034, 17922280, 8662214, 4261238, 2113709,
3322 1052693, 525315, 262400, 131136, 65552, 32772, 16385,
3323 8192, 4096, 2048, 1024, 512, 256, 128, 64, 32, 16, 8, 4, 2, 1, 1 };
3325 @ @<Local variables for initialization@>=
3326 integer k; /* all-purpose loop index */
3329 @ Here is the routine that calculates $2^8$ times the natural logarithm
3330 of a |scaled| quantity; it is an integer approximation to $2^{24}\ln(x/2^{16})$,
3331 when |x| is a given positive integer.
3333 The method is based on exercise 1.2.2--25 in {\sl The Art of Computer
3334 Programming\/}: During the main iteration we have $1\L 2^{-30}x<1/(1-2^{1-k})$,
3335 and the logarithm of $2^{30}x$ remains to be added to an accumulator
3336 register called~$y$. Three auxiliary bits of accuracy are retained in~$y$
3337 during the calculation, and sixteen auxiliary bits to extend |y| are
3338 kept in~|z| during the initial argument reduction. (We add
3339 $100\cdot2^{16}=6553600$ to~|z| and subtract 100 from~|y| so that |z| will
3340 not become negative; also, the actual amount subtracted from~|y| is~96,
3341 not~100, because we want to add~4 for rounding before the final division by~8.)
3344 scaled mp_m_log (MP mp,scaled x) {
3345 integer y,z; /* auxiliary registers */
3346 integer k; /* iteration counter */
3348 @<Handle non-positive logarithm@>;
3350 y=1302456956+4-100; /* $14\times2^{27}\ln2\approx1302456956.421063$ */
3351 z=27595+6553600; /* and $2^{16}\times .421063\approx 27595$ */
3352 while ( x<fraction_four ) {
3353 double(x); y-=93032639; z-=48782;
3354 } /* $2^{27}\ln2\approx 93032639.74436163$ and $2^{16}\times.74436163\approx 48782$ */
3355 y=y+(z / unity); k=2;
3356 while ( x>fraction_four+4 ) {
3357 @<Increase |k| until |x| can be multiplied by a
3358 factor of $2^{-k}$, and adjust $y$ accordingly@>;
3364 @ @<Increase |k| until |x| can...@>=
3366 z=((x-1) / two_to_the(k))+1; /* $z=\lceil x/2^k\rceil$ */
3367 while ( x<fraction_four+z ) { z=halfp(z+1); incr(k); };
3368 y+=spec_log[k]; x-=z;
3371 @ @<Handle non-positive logarithm@>=
3373 print_err("Logarithm of ");
3374 @.Logarithm...replaced by 0@>
3375 mp_print_scaled(mp, x); mp_print(mp, " has been replaced by 0");
3376 help2("Since I don't take logs of non-positive numbers,")
3377 ("I'm zeroing this one. Proceed, with fingers crossed.");
3382 @ Conversely, the exponential routine calculates $\exp(x/2^8)$,
3383 when |x| is |scaled|. The result is an integer approximation to
3384 $2^{16}\exp(x/2^{24})$, when |x| is regarded as an integer.
3387 scaled mp_m_exp (MP mp,scaled x) {
3388 small_number k; /* loop control index */
3389 integer y,z; /* auxiliary registers */
3390 if ( x>174436200 ) {
3391 /* $2^{24}\ln((2^{31}-1)/2^{16})\approx 174436199.51$ */
3392 mp->arith_error=true;
3394 } else if ( x<-197694359 ) {
3395 /* $2^{24}\ln(2^{-1}/2^{16})\approx-197694359.45$ */
3399 z=-8*x; y=04000000; /* $y=2^{20}$ */
3401 if ( x<=127919879 ) {
3403 /* $2^{27}\ln((2^{31}-1)/2^{20})\approx 1023359037.125$ */
3405 z=8*(174436200-x); /* |z| is always nonnegative */
3409 @<Multiply |y| by $\exp(-z/2^{27})$@>;
3411 return ((y+8) / 16);
3417 @ The idea here is that subtracting |spec_log[k]| from |z| corresponds
3418 to multiplying |y| by $1-2^{-k}$.
3420 A subtle point (which had to be checked) was that if $x=127919879$, the
3421 value of~|y| will decrease so that |y+8| doesn't overflow. In fact,
3422 $z$ will be 5 in this case, and |y| will decrease by~64 when |k=25|
3423 and by~16 when |k=27|.
3425 @<Multiply |y| by...@>=
3428 while ( z>=spec_log[k] ) {
3430 y=y-1-((y-two_to_the(k-1)) / two_to_the(k));
3435 @ The trigonometric subroutines use an auxiliary table such that
3436 |spec_atan[k]| contains an approximation to the |angle| whose tangent
3437 is~$1/2^k$. $\arctan2^{-k}$ times $2^{20}\cdot180/\pi$
3440 static const angle spec_atan[27] = { 0, 27855475, 14718068, 7471121, 3750058,
3441 1876857, 938658, 469357, 234682, 117342, 58671, 29335, 14668, 7334, 3667,
3442 1833, 917, 458, 229, 115, 57, 29, 14, 7, 4, 2, 1 };
3444 @ Given integers |x| and |y|, not both zero, the |n_arg| function
3445 returns the |angle| whose tangent points in the direction $(x,y)$.
3446 This subroutine first determines the correct octant, then solves the
3447 problem for |0<=y<=x|, then converts the result appropriately to
3448 return an answer in the range |-one_eighty_deg<=@t$\theta$@><=one_eighty_deg|.
3449 (The answer is |+one_eighty_deg| if |y=0| and |x<0|, but an answer of
3450 |-one_eighty_deg| is possible if, for example, |y=-1| and $x=-2^{30}$.)
3452 The octants are represented in a ``Gray code,'' since that turns out
3453 to be computationally simplest.
3459 @d second_octant (first_octant+switch_x_and_y)
3460 @d third_octant (first_octant+switch_x_and_y+negate_x)
3461 @d fourth_octant (first_octant+negate_x)
3462 @d fifth_octant (first_octant+negate_x+negate_y)
3463 @d sixth_octant (first_octant+switch_x_and_y+negate_x+negate_y)
3464 @d seventh_octant (first_octant+switch_x_and_y+negate_y)
3465 @d eighth_octant (first_octant+negate_y)
3468 angle mp_n_arg (MP mp,integer x, integer y) {
3469 angle z; /* auxiliary register */
3470 integer t; /* temporary storage */
3471 small_number k; /* loop counter */
3472 int octant; /* octant code */
3474 octant=first_octant;
3476 negate(x); octant=first_octant+negate_x;
3479 negate(y); octant=octant+negate_y;
3482 t=y; y=x; x=t; octant=octant+switch_x_and_y;
3485 @<Handle undefined arg@>;
3487 @<Set variable |z| to the arg of $(x,y)$@>;
3488 @<Return an appropriate answer based on |z| and |octant|@>;
3492 @ @<Handle undefined arg@>=
3494 print_err("angle(0,0) is taken as zero");
3495 @.angle(0,0)...zero@>
3496 help2("The `angle' between two identical points is undefined.")
3497 ("I'm zeroing this one. Proceed, with fingers crossed.");
3502 @ @<Return an appropriate answer...@>=
3504 case first_octant: return z;
3505 case second_octant: return (ninety_deg-z);
3506 case third_octant: return (ninety_deg+z);
3507 case fourth_octant: return (one_eighty_deg-z);
3508 case fifth_octant: return (z-one_eighty_deg);
3509 case sixth_octant: return (-z-ninety_deg);
3510 case seventh_octant: return (z-ninety_deg);
3511 case eighth_octant: return (-z);
3512 }; /* there are no other cases */
3515 @ At this point we have |x>=y>=0|, and |x>0|. The numbers are scaled up
3516 or down until $2^{28}\L x<2^{29}$, so that accurate fixed-point calculations
3519 @<Set variable |z| to the arg...@>=
3520 while ( x>=fraction_two ) {
3521 x=halfp(x); y=halfp(y);
3525 while ( x<fraction_one ) {
3528 @<Increase |z| to the arg of $(x,y)$@>;
3531 @ During the calculations of this section, variables |x| and~|y|
3532 represent actual coordinates $(x,2^{-k}y)$. We will maintain the
3533 condition |x>=y|, so that the tangent will be at most $2^{-k}$.
3534 If $x<2y$, the tangent is greater than $2^{-k-1}$. The transformation
3535 $(a,b)\mapsto(a+b\tan\phi,b-a\tan\phi)$ replaces $(a,b)$ by
3536 coordinates whose angle has decreased by~$\phi$; in the special case
3537 $a=x$, $b=2^{-k}y$, and $\tan\phi=2^{-k-1}$, this operation reduces
3538 to the particularly simple iteration shown here. [Cf.~John E. Meggitt,
3539 @^Meggitt, John E.@>
3540 {\sl IBM Journal of Research and Development\/ \bf6} (1962), 210--226.]
3542 The initial value of |x| will be multiplied by at most
3543 $(1+{1\over2})(1+{1\over8})(1+{1\over32})\cdots\approx 1.7584$; hence
3544 there is no chance of integer overflow.
3546 @<Increase |z|...@>=
3551 z=z+spec_atan[k]; t=x; x=x+(y / two_to_the(k+k)); y=y-t;
3556 if ( y>x ) { z=z+spec_atan[k]; y=y-x; };
3559 @ Conversely, the |n_sin_cos| routine takes an |angle| and produces the sine
3560 and cosine of that angle. The results of this routine are
3561 stored in global integer variables |n_sin| and |n_cos|.
3564 fraction n_sin;fraction n_cos; /* results computed by |n_sin_cos| */
3566 @ Given an integer |z| that is $2^{20}$ times an angle $\theta$ in degrees,
3567 the purpose of |n_sin_cos(z)| is to set
3568 |x=@t$r\cos\theta$@>| and |y=@t$r\sin\theta$@>| (approximately),
3569 for some rather large number~|r|. The maximum of |x| and |y|
3570 will be between $2^{28}$ and $2^{30}$, so that there will be hardly
3571 any loss of accuracy. Then |x| and~|y| are divided by~|r|.
3574 void mp_n_sin_cos (MP mp,angle z) { /* computes a multiple of the sine
3576 small_number k; /* loop control variable */
3577 int q; /* specifies the quadrant */
3578 fraction r; /* magnitude of |(x,y)| */
3579 integer x,y,t; /* temporary registers */
3580 while ( z<0 ) z=z+three_sixty_deg;
3581 z=z % three_sixty_deg; /* now |0<=z<three_sixty_deg| */
3582 q=z / forty_five_deg; z=z % forty_five_deg;
3583 x=fraction_one; y=x;
3584 if ( ! odd(q) ) z=forty_five_deg-z;
3585 @<Subtract angle |z| from |(x,y)|@>;
3586 @<Convert |(x,y)| to the octant determined by~|q|@>;
3587 r=mp_pyth_add(mp, x,y);
3588 mp->n_cos=mp_make_fraction(mp, x,r);
3589 mp->n_sin=mp_make_fraction(mp, y,r);
3592 @ In this case the octants are numbered sequentially.
3594 @<Convert |(x,...@>=
3597 case 1: t=x; x=y; y=t; break;
3598 case 2: t=x; x=-y; y=t; break;
3599 case 3: negate(x); break;
3600 case 4: negate(x); negate(y); break;
3601 case 5: t=x; x=-y; y=-t; break;
3602 case 6: t=x; x=y; y=-t; break;
3603 case 7: negate(y); break;
3604 } /* there are no other cases */
3606 @ The main iteration of |n_sin_cos| is similar to that of |n_arg| but
3607 applied in reverse. The values of |spec_atan[k]| decrease slowly enough
3608 that this loop is guaranteed to terminate before the (nonexistent) value
3609 |spec_atan[27]| would be required.
3611 @<Subtract angle |z|...@>=
3614 if ( z>=spec_atan[k] ) {
3615 z=z-spec_atan[k]; t=x;
3616 x=t+y / two_to_the(k);
3617 y=y-t / two_to_the(k);
3621 if ( y<0 ) y=0 /* this precaution may never be needed */
3623 @ And now let's complete our collection of numeric utility routines
3624 by considering random number generation.
3625 \MP\ generates pseudo-random numbers with the additive scheme recommended
3626 in Section 3.6 of {\sl The Art of Computer Programming}; however, the
3627 results are random fractions between 0 and |fraction_one-1|, inclusive.
3629 There's an auxiliary array |randoms| that contains 55 pseudo-random
3630 fractions. Using the recurrence $x_n=(x_{n-55}-x_{n-31})\bmod 2^{28}$,
3631 we generate batches of 55 new $x_n$'s at a time by calling |new_randoms|.
3632 The global variable |j_random| tells which element has most recently
3634 The global variable |random_seed| was introduced in version 0.9,
3635 for the sole reason of stressing the fact that the initial value of the
3636 random seed is system-dependant. The initialization code below will initialize
3637 this variable to |(internal[mp_time] div unity)+internal[mp_day]|, but this
3638 is not good enough on modern fast machines that are capable of running
3639 multiple MetaPost processes within the same second.
3640 @^system dependencies@>
3643 fraction randoms[55]; /* the last 55 random values generated */
3644 int j_random; /* the number of unused |randoms| */
3646 @ @<Option variables@>=
3647 int random_seed; /* the default random seed */
3649 @ @<Allocate or initialize ...@>=
3650 mp->random_seed = (scaled)opt->random_seed;
3652 @ To consume a random fraction, the program below will say `|next_random|'
3653 and then it will fetch |randoms[j_random]|.
3655 @d next_random { if ( mp->j_random==0 ) mp_new_randoms(mp);
3656 else decr(mp->j_random); }
3659 void mp_new_randoms (MP mp) {
3660 int k; /* index into |randoms| */
3661 fraction x; /* accumulator */
3662 for (k=0;k<=23;k++) {
3663 x=mp->randoms[k]-mp->randoms[k+31];
3664 if ( x<0 ) x=x+fraction_one;
3667 for (k=24;k<= 54;k++){
3668 x=mp->randoms[k]-mp->randoms[k-24];
3669 if ( x<0 ) x=x+fraction_one;
3676 void mp_init_randoms (MP mp,scaled seed);
3678 @ To initialize the |randoms| table, we call the following routine.
3681 void mp_init_randoms (MP mp,scaled seed) {
3682 fraction j,jj,k; /* more or less random integers */
3683 int i; /* index into |randoms| */
3685 while ( j>=fraction_one ) j=halfp(j);
3687 for (i=0;i<=54;i++ ){
3689 if ( k<0 ) k=k+fraction_one;
3690 mp->randoms[(i*21)% 55]=j;
3694 mp_new_randoms(mp); /* ``warm up'' the array */
3697 @ To produce a uniform random number in the range |0<=u<x| or |0>=u>x|
3698 or |0=u=x|, given a |scaled| value~|x|, we proceed as shown here.
3700 Note that the call of |take_fraction| will produce the values 0 and~|x|
3701 with about half the probability that it will produce any other particular
3702 values between 0 and~|x|, because it rounds its answers.
3705 scaled mp_unif_rand (MP mp,scaled x) {
3706 scaled y; /* trial value */
3707 next_random; y=mp_take_fraction(mp, abs(x),mp->randoms[mp->j_random]);
3708 if ( y==abs(x) ) return 0;
3709 else if ( x>0 ) return y;
3713 @ Finally, a normal deviate with mean zero and unit standard deviation
3714 can readily be obtained with the ratio method (Algorithm 3.4.1R in
3715 {\sl The Art of Computer Programming\/}).
3718 scaled mp_norm_rand (MP mp) {
3719 integer x,u,l; /* what the book would call $2^{16}X$, $2^{28}U$, and $-2^{24}\ln U$ */
3723 x=mp_take_fraction(mp, 112429,mp->randoms[mp->j_random]-fraction_half);
3724 /* $2^{16}\sqrt{8/e}\approx 112428.82793$ */
3725 next_random; u=mp->randoms[mp->j_random];
3726 } while (abs(x)>=u);
3727 x=mp_make_fraction(mp, x,u);
3728 l=139548960-mp_m_log(mp, u); /* $2^{24}\cdot12\ln2\approx139548959.6165$ */
3729 } while (mp_ab_vs_cd(mp, 1024,l,x,x)<0);
3733 @* \[9] Packed data.
3734 In order to make efficient use of storage space, \MP\ bases its major data
3735 structures on a |memory_word|, which contains either a (signed) integer,
3736 possibly scaled, or a small number of fields that are one half or one
3737 quarter of the size used for storing integers.
3739 If |x| is a variable of type |memory_word|, it contains up to four
3740 fields that can be referred to as follows:
3741 $$\vbox{\halign{\hfil#&#\hfil&#\hfil\cr
3742 |x|&.|int|&(an |integer|)\cr
3743 |x|&.|sc|\qquad&(a |scaled| integer)\cr
3744 |x.hh.lh|, |x.hh|&.|rh|&(two halfword fields)\cr
3745 |x.hh.b0|, |x.hh.b1|, |x.hh|&.|rh|&(two quarterword fields, one halfword
3747 |x.qqqq.b0|, |x.qqqq.b1|, |x.qqqq|&.|b2|, |x.qqqq.b3|\hskip-100pt
3748 &\qquad\qquad\qquad(four quarterword fields)\cr}}$$
3749 This is somewhat cumbersome to write, and not very readable either, but
3750 macros will be used to make the notation shorter and more transparent.
3751 The code below gives a formal definition of |memory_word| and
3752 its subsidiary types, using packed variant records. \MP\ makes no
3753 assumptions about the relative positions of the fields within a word.
3755 @d max_quarterword 0x3FFF /* largest allowable value in a |quarterword| */
3756 @d max_halfword 0xFFFFFFF /* largest allowable value in a |halfword| */
3758 @ Here are the inequalities that the quarterword and halfword values
3759 must satisfy (or rather, the inequalities that they mustn't satisfy):
3761 @<Check the ``constant''...@>=
3762 if (mp->ini_version) {
3763 if ( mp->mem_max!=mp->mem_top ) mp->bad=8;
3765 if ( mp->mem_max<mp->mem_top ) mp->bad=8;
3767 if ( max_quarterword<255 ) mp->bad=9;
3768 if ( max_halfword<65535 ) mp->bad=10;
3769 if ( max_quarterword>max_halfword ) mp->bad=11;
3770 if ( mp->mem_max>=max_halfword ) mp->bad=12;
3771 if ( mp->max_strings>max_halfword ) mp->bad=13;
3773 @ The macros |qi| and |qo| are used for input to and output
3774 from quarterwords. These are legacy macros.
3775 @^system dependencies@>
3777 @d qo(A) (A) /* to read eight bits from a quarterword */
3778 @d qi(A) (A) /* to store eight bits in a quarterword */
3780 @ The reader should study the following definitions closely:
3781 @^system dependencies@>
3783 @d sc cint /* |scaled| data is equivalent to |integer| */
3786 typedef short quarterword; /* 1/4 of a word */
3787 typedef int halfword; /* 1/2 of a word */
3792 struct { /* Make B0,B1 overlap the most significant bytes of LH. */
3799 quarterword B2, B3, B0, B1;
3814 @ When debugging, we may want to print a |memory_word| without knowing
3815 what type it is; so we print it in all modes.
3819 void mp_print_word (MP mp,memory_word w) {
3820 /* prints |w| in all ways */
3821 mp_print_int(mp, w.cint); mp_print_char(mp, ' ');
3822 mp_print_scaled(mp, w.sc); mp_print_char(mp, ' ');
3823 mp_print_scaled(mp, w.sc / 010000); mp_print_ln(mp);
3824 mp_print_int(mp, w.hh.lh); mp_print_char(mp, '=');
3825 mp_print_int(mp, w.hh.b0); mp_print_char(mp, ':');
3826 mp_print_int(mp, w.hh.b1); mp_print_char(mp, ';');
3827 mp_print_int(mp, w.hh.rh); mp_print_char(mp, ' ');
3828 mp_print_int(mp, w.qqqq.b0); mp_print_char(mp, ':');
3829 mp_print_int(mp, w.qqqq.b1); mp_print_char(mp, ':');
3830 mp_print_int(mp, w.qqqq.b2); mp_print_char(mp, ':');
3831 mp_print_int(mp, w.qqqq.b3);
3835 @* \[10] Dynamic memory allocation.
3837 The \MP\ system does nearly all of its own memory allocation, so that it
3838 can readily be transported into environments that do not have automatic
3839 facilities for strings, garbage collection, etc., and so that it can be in
3840 control of what error messages the user receives. The dynamic storage
3841 requirements of \MP\ are handled by providing a large array |mem| in
3842 which consecutive blocks of words are used as nodes by the \MP\ routines.
3844 Pointer variables are indices into this array, or into another array
3845 called |eqtb| that will be explained later. A pointer variable might
3846 also be a special flag that lies outside the bounds of |mem|, so we
3847 allow pointers to assume any |halfword| value. The minimum memory
3848 index represents a null pointer.
3850 @d null 0 /* the null pointer */
3851 @d mp_void (null+1) /* a null pointer different from |null| */
3855 typedef halfword pointer; /* a flag or a location in |mem| or |eqtb| */
3857 @ The |mem| array is divided into two regions that are allocated separately,
3858 but the dividing line between these two regions is not fixed; they grow
3859 together until finding their ``natural'' size in a particular job.
3860 Locations less than or equal to |lo_mem_max| are used for storing
3861 variable-length records consisting of two or more words each. This region
3862 is maintained using an algorithm similar to the one described in exercise
3863 2.5--19 of {\sl The Art of Computer Programming}. However, no size field
3864 appears in the allocated nodes; the program is responsible for knowing the
3865 relevant size when a node is freed. Locations greater than or equal to
3866 |hi_mem_min| are used for storing one-word records; a conventional
3867 \.{AVAIL} stack is used for allocation in this region.
3869 Locations of |mem| between |0| and |mem_top| may be dumped as part
3870 of preloaded mem files, by the \.{INIMP} preprocessor.
3872 Production versions of \MP\ may extend the memory at the top end in order to
3873 provide more space; these locations, between |mem_top| and |mem_max|,
3874 are always used for single-word nodes.
3876 The key pointers that govern |mem| allocation have a prescribed order:
3877 $$\hbox{|null=0<lo_mem_max<hi_mem_min<mem_top<=mem_end<=mem_max|.}$$
3880 memory_word *mem; /* the big dynamic storage area */
3881 pointer lo_mem_max; /* the largest location of variable-size memory in use */
3882 pointer hi_mem_min; /* the smallest location of one-word memory in use */
3886 @d xfree(A) do { mp_xfree(A); A=NULL; } while (0)
3887 @d xrealloc(P,A,B) mp_xrealloc(mp,P,A,B)
3888 @d xmalloc(A,B) mp_xmalloc(mp,A,B)
3889 @d xstrdup(A) mp_xstrdup(mp,A)
3890 @d XREALLOC(a,b,c) a = xrealloc(a,(b+1),sizeof(c));
3892 @<Declare helpers@>=
3893 void mp_xfree (void *x);
3894 void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size) ;
3895 void *mp_xmalloc (MP mp, size_t nmem, size_t size) ;
3896 char *mp_xstrdup(MP mp, const char *s);
3897 void mp_do_snprintf(char *str, int size, const char *fmt, ...);
3899 @ The |max_size_test| guards against overflow, on the assumption that
3900 |size_t| is at least 31bits wide.
3902 @d max_size_test 0x7FFFFFFF
3905 void mp_xfree (void *x) {
3906 if (x!=NULL) free(x);
3908 void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size) {
3910 if ((max_size_test/size)<nmem) {
3911 do_fprintf(mp->err_out,"Memory size overflow!\n");
3912 mp->history =mp_fatal_error_stop; mp_jump_out(mp);
3914 w = realloc (p,(nmem*size));
3916 do_fprintf(mp->err_out,"Out of memory!\n");
3917 mp->history =mp_system_error_stop; mp_jump_out(mp);
3921 void *mp_xmalloc (MP mp, 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 = malloc (nmem*size);
3929 do_fprintf(mp->err_out,"Out of memory!\n");
3930 mp->history =mp_system_error_stop; mp_jump_out(mp);
3934 char *mp_xstrdup(MP mp, const char *s) {
3940 do_fprintf(mp->err_out,"Out of memory!\n");
3941 mp->history =mp_system_error_stop; mp_jump_out(mp);
3946 @ @<Internal library declarations@>=
3947 #ifdef HAVE_SNPRINTF
3948 #define mp_snprintf (void)snprintf
3950 #define mp_snprintf mp_do_snprintf
3953 @ This internal version is rather stupid, but good enough for its purpose.
3956 void mp_do_snprintf (char *str, int size, const char *format, ...) {
3961 work = (char *)workbuf;
3962 va_start(ap, format);
3964 for (fmt=format;*fmt!='\0';fmt++) {
3970 char *s = va_arg(ap, char *);
3973 if (size-->0) res++;
3980 sprintf(work,"%i",va_arg(ap, int));
3983 if (size-->0) res++;
3989 sprintf(work,"%g",va_arg(ap, double));
3992 if (size-->0) res++;
3998 if (size-->0) res++;
4006 if (size-->0) res++;
4014 @<Allocate or initialize ...@>=
4015 mp->mem = xmalloc ((mp->mem_max+1),sizeof (memory_word));
4016 memset(mp->mem,0,(mp->mem_max+1)*sizeof (memory_word));
4018 @ @<Dealloc variables@>=
4021 @ Users who wish to study the memory requirements of particular applications can
4022 can use optional special features that keep track of current and
4023 maximum memory usage. When code between the delimiters |stat| $\ldots$
4024 |tats| is not ``commented out,'' \MP\ will run a bit slower but it will
4025 report these statistics when |mp_tracing_stats| is positive.
4028 integer var_used; integer dyn_used; /* how much memory is in use */
4030 @ Let's consider the one-word memory region first, since it's the
4031 simplest. The pointer variable |mem_end| holds the highest-numbered location
4032 of |mem| that has ever been used. The free locations of |mem| that
4033 occur between |hi_mem_min| and |mem_end|, inclusive, are of type
4034 |two_halves|, and we write |info(p)| and |link(p)| for the |lh|
4035 and |rh| fields of |mem[p]| when it is of this type. The single-word
4036 free locations form a linked list
4037 $$|avail|,\;\hbox{|link(avail)|},\;\hbox{|link(link(avail))|},\;\ldots$$
4038 terminated by |null|.
4040 @d link(A) mp->mem[(A)].hh.rh /* the |link| field of a memory word */
4041 @d info(A) mp->mem[(A)].hh.lh /* the |info| field of a memory word */
4044 pointer avail; /* head of the list of available one-word nodes */
4045 pointer mem_end; /* the last one-word node used in |mem| */
4047 @ If one-word memory is exhausted, it might mean that the user has forgotten
4048 a token like `\&{enddef}' or `\&{endfor}'. We will define some procedures
4049 later that try to help pinpoint the trouble.
4052 @<Declare the procedure called |show_token_list|@>
4053 @<Declare the procedure called |runaway|@>
4055 @ The function |get_avail| returns a pointer to a new one-word node whose
4056 |link| field is null. However, \MP\ will halt if there is no more room left.
4060 pointer mp_get_avail (MP mp) { /* single-word node allocation */
4061 pointer p; /* the new node being got */
4062 p=mp->avail; /* get top location in the |avail| stack */
4064 mp->avail=link(mp->avail); /* and pop it off */
4065 } else if ( mp->mem_end<mp->mem_max ) { /* or go into virgin territory */
4066 incr(mp->mem_end); p=mp->mem_end;
4068 decr(mp->hi_mem_min); p=mp->hi_mem_min;
4069 if ( mp->hi_mem_min<=mp->lo_mem_max ) {
4070 mp_runaway(mp); /* if memory is exhausted, display possible runaway text */
4071 mp_overflow(mp, "main memory size",mp->mem_max);
4072 /* quit; all one-word nodes are busy */
4073 @:MetaPost capacity exceeded main memory size}{\quad main memory size@>
4076 link(p)=null; /* provide an oft-desired initialization of the new node */
4077 incr(mp->dyn_used);/* maintain statistics */
4081 @ Conversely, a one-word node is recycled by calling |free_avail|.
4083 @d free_avail(A) /* single-word node liberation */
4084 { link((A))=mp->avail; mp->avail=(A); decr(mp->dyn_used); }
4086 @ There's also a |fast_get_avail| routine, which saves the procedure-call
4087 overhead at the expense of extra programming. This macro is used in
4088 the places that would otherwise account for the most calls of |get_avail|.
4091 @d fast_get_avail(A) {
4092 (A)=mp->avail; /* avoid |get_avail| if possible, to save time */
4093 if ( (A)==null ) { (A)=mp_get_avail(mp); }
4094 else { mp->avail=link((A)); link((A))=null; incr(mp->dyn_used); }
4097 @ The available-space list that keeps track of the variable-size portion
4098 of |mem| is a nonempty, doubly-linked circular list of empty nodes,
4099 pointed to by the roving pointer |rover|.
4101 Each empty node has size 2 or more; the first word contains the special
4102 value |max_halfword| in its |link| field and the size in its |info| field;
4103 the second word contains the two pointers for double linking.
4105 Each nonempty node also has size 2 or more. Its first word is of type
4106 |two_halves|\kern-1pt, and its |link| field is never equal to |max_halfword|.
4107 Otherwise there is complete flexibility with respect to the contents
4108 of its other fields and its other words.
4110 (We require |mem_max<max_halfword| because terrible things can happen
4111 when |max_halfword| appears in the |link| field of a nonempty node.)
4113 @d empty_flag max_halfword /* the |link| of an empty variable-size node */
4114 @d is_empty(A) (link((A))==empty_flag) /* tests for empty node */
4115 @d node_size info /* the size field in empty variable-size nodes */
4116 @d llink(A) info((A)+1) /* left link in doubly-linked list of empty nodes */
4117 @d rlink(A) link((A)+1) /* right link in doubly-linked list of empty nodes */
4120 pointer rover; /* points to some node in the list of empties */
4122 @ A call to |get_node| with argument |s| returns a pointer to a new node
4123 of size~|s|, which must be 2~or more. The |link| field of the first word
4124 of this new node is set to null. An overflow stop occurs if no suitable
4127 If |get_node| is called with $s=2^{30}$, it simply merges adjacent free
4128 areas and returns the value |max_halfword|.
4130 @<Internal library declarations@>=
4131 pointer mp_get_node (MP mp,integer s) ;
4134 pointer mp_get_node (MP mp,integer s) { /* variable-size node allocation */
4135 pointer p; /* the node currently under inspection */
4136 pointer q; /* the node physically after node |p| */
4137 integer r; /* the newly allocated node, or a candidate for this honor */
4138 integer t,tt; /* temporary registers */
4141 p=mp->rover; /* start at some free node in the ring */
4143 @<Try to allocate within node |p| and its physical successors,
4144 and |goto found| if allocation was possible@>;
4145 if (rlink(p)==null || (rlink(p)==p && p!=mp->rover)) {
4146 print_err("Free list garbled");
4147 help3("I found an entry in the list of free nodes that links")
4148 ("badly. I will try to ignore the broken link, but something")
4149 ("is seriously amiss. It is wise to warn the maintainers.")
4153 p=rlink(p); /* move to the next node in the ring */
4154 } while (p!=mp->rover); /* repeat until the whole list has been traversed */
4155 if ( s==010000000000 ) {
4156 return max_halfword;
4158 if ( mp->lo_mem_max+2<mp->hi_mem_min ) {
4159 if ( mp->lo_mem_max+2<=max_halfword ) {
4160 @<Grow more variable-size memory and |goto restart|@>;
4163 mp_overflow(mp, "main memory size",mp->mem_max);
4164 /* sorry, nothing satisfactory is left */
4165 @:MetaPost capacity exceeded main memory size}{\quad main memory size@>
4167 link(r)=null; /* this node is now nonempty */
4168 mp->var_used+=s; /* maintain usage statistics */
4172 @ The lower part of |mem| grows by 1000 words at a time, unless
4173 we are very close to going under. When it grows, we simply link
4174 a new node into the available-space list. This method of controlled
4175 growth helps to keep the |mem| usage consecutive when \MP\ is
4176 implemented on ``virtual memory'' systems.
4179 @<Grow more variable-size memory and |goto restart|@>=
4181 if ( mp->hi_mem_min-mp->lo_mem_max>=1998 ) {
4182 t=mp->lo_mem_max+1000;
4184 t=mp->lo_mem_max+1+(mp->hi_mem_min-mp->lo_mem_max) / 2;
4185 /* |lo_mem_max+2<=t<hi_mem_min| */
4187 if ( t>max_halfword ) t=max_halfword;
4188 p=llink(mp->rover); q=mp->lo_mem_max; rlink(p)=q; llink(mp->rover)=q;
4189 rlink(q)=mp->rover; llink(q)=p; link(q)=empty_flag;
4190 node_size(q)=t-mp->lo_mem_max;
4191 mp->lo_mem_max=t; link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null;
4196 @ @<Try to allocate...@>=
4197 q=p+node_size(p); /* find the physical successor */
4198 while ( is_empty(q) ) { /* merge node |p| with node |q| */
4199 t=rlink(q); tt=llink(q);
4201 if ( q==mp->rover ) mp->rover=t;
4202 llink(t)=tt; rlink(tt)=t;
4207 @<Allocate from the top of node |p| and |goto found|@>;
4210 if ( rlink(p)!=p ) {
4211 @<Allocate entire node |p| and |goto found|@>;
4214 node_size(p)=q-p /* reset the size in case it grew */
4216 @ @<Allocate from the top...@>=
4218 node_size(p)=r-p; /* store the remaining size */
4219 mp->rover=p; /* start searching here next time */
4223 @ Here we delete node |p| from the ring, and let |rover| rove around.
4225 @<Allocate entire...@>=
4227 mp->rover=rlink(p); t=llink(p);
4228 llink(mp->rover)=t; rlink(t)=mp->rover;
4232 @ Conversely, when some variable-size node |p| of size |s| is no longer needed,
4233 the operation |free_node(p,s)| will make its words available, by inserting
4234 |p| as a new empty node just before where |rover| now points.
4236 @<Internal library declarations@>=
4237 void mp_free_node (MP mp, pointer p, halfword s) ;
4240 void mp_free_node (MP mp, pointer p, halfword s) { /* variable-size node
4242 pointer q; /* |llink(rover)| */
4243 node_size(p)=s; link(p)=empty_flag;
4245 q=llink(mp->rover); llink(p)=q; rlink(p)=mp->rover; /* set both links */
4246 llink(mp->rover)=p; rlink(q)=p; /* insert |p| into the ring */
4247 mp->var_used-=s; /* maintain statistics */
4250 @ Just before \.{INIMP} writes out the memory, it sorts the doubly linked
4251 available space list. The list is probably very short at such times, so a
4252 simple insertion sort is used. The smallest available location will be
4253 pointed to by |rover|, the next-smallest by |rlink(rover)|, etc.
4256 void mp_sort_avail (MP mp) { /* sorts the available variable-size nodes
4258 pointer p,q,r; /* indices into |mem| */
4259 pointer old_rover; /* initial |rover| setting */
4260 p=mp_get_node(mp, 010000000000); /* merge adjacent free areas */
4261 p=rlink(mp->rover); rlink(mp->rover)=max_halfword; old_rover=mp->rover;
4262 while ( p!=old_rover ) {
4263 @<Sort |p| into the list starting at |rover|
4264 and advance |p| to |rlink(p)|@>;
4267 while ( rlink(p)!=max_halfword ) {
4268 llink(rlink(p))=p; p=rlink(p);
4270 rlink(p)=mp->rover; llink(mp->rover)=p;
4273 @ The following |while| loop is guaranteed to
4274 terminate, since the list that starts at
4275 |rover| ends with |max_halfword| during the sorting procedure.
4278 if ( p<mp->rover ) {
4279 q=p; p=rlink(q); rlink(q)=mp->rover; mp->rover=q;
4282 while ( rlink(q)<p ) q=rlink(q);
4283 r=rlink(p); rlink(p)=rlink(q); rlink(q)=p; p=r;
4286 @* \[11] Memory layout.
4287 Some areas of |mem| are dedicated to fixed usage, since static allocation is
4288 more efficient than dynamic allocation when we can get away with it. For
4289 example, locations |0| to |1| are always used to store a
4290 two-word dummy token whose second word is zero.
4291 The following macro definitions accomplish the static allocation by giving
4292 symbolic names to the fixed positions. Static variable-size nodes appear
4293 in locations |0| through |lo_mem_stat_max|, and static single-word nodes
4294 appear in locations |hi_mem_stat_min| through |mem_top|, inclusive.
4296 @d null_dash (2) /* the first two words are reserved for a null value */
4297 @d dep_head (null_dash+3) /* we will define |dash_node_size=3| */
4298 @d zero_val (dep_head+2) /* two words for a permanently zero value */
4299 @d temp_val (zero_val+2) /* two words for a temporary value node */
4300 @d end_attr temp_val /* we use |end_attr+2| only */
4301 @d inf_val (end_attr+2) /* and |inf_val+1| only */
4302 @d test_pen (inf_val+2)
4303 /* nine words for a pen used when testing the turning number */
4304 @d bad_vardef (test_pen+9) /* two words for \&{vardef} error recovery */
4305 @d lo_mem_stat_max (bad_vardef+1) /* largest statically
4306 allocated word in the variable-size |mem| */
4308 @d sentinel mp->mem_top /* end of sorted lists */
4309 @d temp_head (mp->mem_top-1) /* head of a temporary list of some kind */
4310 @d hold_head (mp->mem_top-2) /* head of a temporary list of another kind */
4311 @d spec_head (mp->mem_top-3) /* head of a list of unprocessed \&{special} items */
4312 @d hi_mem_stat_min (mp->mem_top-3) /* smallest statically allocated word in
4313 the one-word |mem| */
4315 @ The following code gets the dynamic part of |mem| off to a good start,
4316 when \MP\ is initializing itself the slow way.
4318 @<Initialize table entries (done by \.{INIMP} only)@>=
4319 mp->rover=lo_mem_stat_max+1; /* initialize the dynamic memory */
4320 link(mp->rover)=empty_flag;
4321 node_size(mp->rover)=1000; /* which is a 1000-word available node */
4322 llink(mp->rover)=mp->rover; rlink(mp->rover)=mp->rover;
4323 mp->lo_mem_max=mp->rover+1000;
4324 link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null;
4325 for (k=hi_mem_stat_min;k<=(int)mp->mem_top;k++) {
4326 mp->mem[k]=mp->mem[mp->lo_mem_max]; /* clear list heads */
4328 mp->avail=null; mp->mem_end=mp->mem_top;
4329 mp->hi_mem_min=hi_mem_stat_min; /* initialize the one-word memory */
4330 mp->var_used=lo_mem_stat_max+1;
4331 mp->dyn_used=mp->mem_top+1-(hi_mem_stat_min); /* initialize statistics */
4332 @<Initialize a pen at |test_pen| so that it fits in nine words@>;
4334 @ The procedure |flush_list(p)| frees an entire linked list of one-word
4335 nodes that starts at a given position, until coming to |sentinel| or a
4336 pointer that is not in the one-word region. Another procedure,
4337 |flush_node_list|, frees an entire linked list of one-word and two-word
4338 nodes, until coming to a |null| pointer.
4342 void mp_flush_list (MP mp,pointer p) { /* makes list of single-word nodes available */
4343 pointer q,r; /* list traversers */
4344 if ( p>=mp->hi_mem_min ) if ( p!=sentinel ) {
4349 if ( r<mp->hi_mem_min ) break;
4350 } while (r!=sentinel);
4351 /* now |q| is the last node on the list */
4352 link(q)=mp->avail; mp->avail=p;
4356 void mp_flush_node_list (MP mp,pointer p) {
4357 pointer q; /* the node being recycled */
4360 if ( q<mp->hi_mem_min )
4361 mp_free_node(mp, q,2);
4367 @ If \MP\ is extended improperly, the |mem| array might get screwed up.
4368 For example, some pointers might be wrong, or some ``dead'' nodes might not
4369 have been freed when the last reference to them disappeared. Procedures
4370 |check_mem| and |search_mem| are available to help diagnose such
4371 problems. These procedures make use of two arrays called |free| and
4372 |was_free| that are present only if \MP's debugging routines have
4373 been included. (You may want to decrease the size of |mem| while you
4377 Because |boolean|s are typedef-d as ints, it is better to use
4378 unsigned chars here.
4381 unsigned char *free; /* free cells */
4382 unsigned char *was_free; /* previously free cells */
4383 pointer was_mem_end; pointer was_lo_max; pointer was_hi_min;
4384 /* previous |mem_end|, |lo_mem_max|,and |hi_mem_min| */
4385 boolean panicking; /* do we want to check memory constantly? */
4387 @ @<Allocate or initialize ...@>=
4388 mp->free = xmalloc ((mp->mem_max+1),sizeof (unsigned char));
4389 mp->was_free = xmalloc ((mp->mem_max+1), sizeof (unsigned char));
4391 @ @<Dealloc variables@>=
4393 xfree(mp->was_free);
4395 @ @<Allocate or ...@>=
4396 mp->was_mem_end=0; /* indicate that everything was previously free */
4397 mp->was_lo_max=0; mp->was_hi_min=mp->mem_max;
4398 mp->panicking=false;
4400 @ @<Declare |mp_reallocate| functions@>=
4401 void mp_reallocate_memory(MP mp, int l) ;
4404 void mp_reallocate_memory(MP mp, int l) {
4405 XREALLOC(mp->free, l, unsigned char);
4406 XREALLOC(mp->was_free, l, unsigned char);
4408 int newarea = l-mp->mem_max;
4409 XREALLOC(mp->mem, l, memory_word);
4410 memset (mp->mem+(mp->mem_max+1),0,sizeof(memory_word)*(newarea));
4412 XREALLOC(mp->mem, l, memory_word);
4413 memset(mp->mem,0,sizeof(memory_word)*(l+1));
4416 if (mp->ini_version)
4422 @ Procedure |check_mem| makes sure that the available space lists of
4423 |mem| are well formed, and it optionally prints out all locations
4424 that are reserved now but were free the last time this procedure was called.
4427 void mp_check_mem (MP mp,boolean print_locs ) {
4428 pointer p,q,r; /* current locations of interest in |mem| */
4429 boolean clobbered; /* is something amiss? */
4430 for (p=0;p<=mp->lo_mem_max;p++) {
4431 mp->free[p]=false; /* you can probably do this faster */
4433 for (p=mp->hi_mem_min;p<= mp->mem_end;p++) {
4434 mp->free[p]=false; /* ditto */
4436 @<Check single-word |avail| list@>;
4437 @<Check variable-size |avail| list@>;
4438 @<Check flags of unavailable nodes@>;
4439 @<Check the list of linear dependencies@>;
4441 @<Print newly busy locations@>;
4443 memcpy(mp->was_free,mp->free, sizeof(char)*(mp->mem_end+1));
4444 mp->was_mem_end=mp->mem_end;
4445 mp->was_lo_max=mp->lo_mem_max;
4446 mp->was_hi_min=mp->hi_mem_min;
4449 @ @<Check single-word...@>=
4450 p=mp->avail; q=null; clobbered=false;
4452 if ( (p>mp->mem_end)||(p<mp->hi_mem_min) ) clobbered=true;
4453 else if ( mp->free[p] ) clobbered=true;
4455 mp_print_nl(mp, "AVAIL list clobbered at ");
4456 @.AVAIL list clobbered...@>
4457 mp_print_int(mp, q); break;
4459 mp->free[p]=true; q=p; p=link(q);
4462 @ @<Check variable-size...@>=
4463 p=mp->rover; q=null; clobbered=false;
4465 if ( (p>=mp->lo_mem_max)||(p<0) ) clobbered=true;
4466 else if ( (rlink(p)>=mp->lo_mem_max)||(rlink(p)<0) ) clobbered=true;
4467 else if ( !(is_empty(p))||(node_size(p)<2)||
4468 (p+node_size(p)>mp->lo_mem_max)|| (llink(rlink(p))!=p) ) clobbered=true;
4470 mp_print_nl(mp, "Double-AVAIL list clobbered at ");
4471 @.Double-AVAIL list clobbered...@>
4472 mp_print_int(mp, q); break;
4474 for (q=p;q<=p+node_size(p)-1;q++) { /* mark all locations free */
4475 if ( mp->free[q] ) {
4476 mp_print_nl(mp, "Doubly free location at ");
4477 @.Doubly free location...@>
4478 mp_print_int(mp, q); break;
4483 } while (p!=mp->rover)
4486 @ @<Check flags...@>=
4488 while ( p<=mp->lo_mem_max ) { /* node |p| should not be empty */
4489 if ( is_empty(p) ) {
4490 mp_print_nl(mp, "Bad flag at "); mp_print_int(mp, p);
4493 while ( (p<=mp->lo_mem_max) && ! mp->free[p] ) incr(p);
4494 while ( (p<=mp->lo_mem_max) && mp->free[p] ) incr(p);
4497 @ @<Print newly busy...@>=
4499 @<Do intialization required before printing new busy locations@>;
4500 mp_print_nl(mp, "New busy locs:");
4502 for (p=0;p<= mp->lo_mem_max;p++ ) {
4503 if ( ! mp->free[p] && ((p>mp->was_lo_max) || mp->was_free[p]) ) {
4504 @<Indicate that |p| is a new busy location@>;
4507 for (p=mp->hi_mem_min;p<=mp->mem_end;p++ ) {
4508 if ( ! mp->free[p] &&
4509 ((p<mp->was_hi_min) || (p>mp->was_mem_end) || mp->was_free[p]) ) {
4510 @<Indicate that |p| is a new busy location@>;
4513 @<Finish printing new busy locations@>;
4516 @ There might be many new busy locations so we are careful to print contiguous
4517 blocks compactly. During this operation |q| is the last new busy location and
4518 |r| is the start of the block containing |q|.
4520 @<Indicate that |p| is a new busy location@>=
4524 mp_print(mp, ".."); mp_print_int(mp, q);
4526 mp_print_char(mp, ' '); mp_print_int(mp, p);
4532 @ @<Do intialization required before printing new busy locations@>=
4533 q=mp->mem_max; r=mp->mem_max
4535 @ @<Finish printing new busy locations@>=
4537 mp_print(mp, ".."); mp_print_int(mp, q);
4540 @ The |search_mem| procedure attempts to answer the question ``Who points
4541 to node~|p|?'' In doing so, it fetches |link| and |info| fields of |mem|
4542 that might not be of type |two_halves|. Strictly speaking, this is
4543 undefined, and it can lead to ``false drops'' (words that seem to
4544 point to |p| purely by coincidence). But for debugging purposes, we want
4545 to rule out the places that do {\sl not\/} point to |p|, so a few false
4546 drops are tolerable.
4549 void mp_search_mem (MP mp, pointer p) { /* look for pointers to |p| */
4550 integer q; /* current position being searched */
4551 for (q=0;q<=mp->lo_mem_max;q++) {
4553 mp_print_nl(mp, "LINK("); mp_print_int(mp, q); mp_print_char(mp, ')');
4556 mp_print_nl(mp, "INFO("); mp_print_int(mp, q); mp_print_char(mp, ')');
4559 for (q=mp->hi_mem_min;q<=mp->mem_end;q++) {
4561 mp_print_nl(mp, "LINK("); mp_print_int(mp, q); mp_print_char(mp, ')');
4564 mp_print_nl(mp, "INFO("); mp_print_int(mp, q); mp_print_char(mp, ')');
4567 @<Search |eqtb| for equivalents equal to |p|@>;
4570 @* \[12] The command codes.
4571 Before we can go much further, we need to define symbolic names for the internal
4572 code numbers that represent the various commands obeyed by \MP. These codes
4573 are somewhat arbitrary, but not completely so. For example,
4574 some codes have been made adjacent so that |case| statements in the
4575 program need not consider cases that are widely spaced, or so that |case|
4576 statements can be replaced by |if| statements. A command can begin an
4577 expression if and only if its code lies between |min_primary_command| and
4578 |max_primary_command|, inclusive. The first token of a statement that doesn't
4579 begin with an expression has a command code between |min_command| and
4580 |max_statement_command|, inclusive. Anything less than |min_command| is
4581 eliminated during macro expansions, and anything no more than |max_pre_command|
4582 is eliminated when expanding \TeX\ material. Ranges such as
4583 |min_secondary_command..max_secondary_command| are used when parsing
4584 expressions, but the relative ordering within such a range is generally not
4587 The ordering of the highest-numbered commands
4588 (|comma<semicolon<end_group<stop|) is crucial for the parsing and
4589 error-recovery methods of this program as is the ordering |if_test<fi_or_else|
4590 for the smallest two commands. The ordering is also important in the ranges
4591 |numeric_token..plus_or_minus| and |left_brace..ampersand|.
4593 At any rate, here is the list, for future reference.
4595 @d start_tex 1 /* begin \TeX\ material (\&{btex}, \&{verbatimtex}) */
4596 @d etex_marker 2 /* end \TeX\ material (\&{etex}) */
4597 @d mpx_break 3 /* stop reading an \.{MPX} file (\&{mpxbreak}) */
4598 @d max_pre_command mpx_break
4599 @d if_test 4 /* conditional text (\&{if}) */
4600 @d fi_or_else 5 /* delimiters for conditionals (\&{elseif}, \&{else}, \&{fi}) */
4601 @d input 6 /* input a source file (\&{input}, \&{endinput}) */
4602 @d iteration 7 /* iterate (\&{for}, \&{forsuffixes}, \&{forever}, \&{endfor}) */
4603 @d repeat_loop 8 /* special command substituted for \&{endfor} */
4604 @d exit_test 9 /* premature exit from a loop (\&{exitif}) */
4605 @d relax 10 /* do nothing (\.{\char`\\}) */
4606 @d scan_tokens 11 /* put a string into the input buffer */
4607 @d expand_after 12 /* look ahead one token */
4608 @d defined_macro 13 /* a macro defined by the user */
4609 @d min_command (defined_macro+1)
4610 @d save_command 14 /* save a list of tokens (\&{save}) */
4611 @d interim_command 15 /* save an internal quantity (\&{interim}) */
4612 @d let_command 16 /* redefine a symbolic token (\&{let}) */
4613 @d new_internal 17 /* define a new internal quantity (\&{newinternal}) */
4614 @d macro_def 18 /* define a macro (\&{def}, \&{vardef}, etc.) */
4615 @d ship_out_command 19 /* output a character (\&{shipout}) */
4616 @d add_to_command 20 /* add to edges (\&{addto}) */
4617 @d bounds_command 21 /* add bounding path to edges (\&{setbounds}, \&{clip}) */
4618 @d tfm_command 22 /* command for font metric info (\&{ligtable}, etc.) */
4619 @d protection_command 23 /* set protection flag (\&{outer}, \&{inner}) */
4620 @d show_command 24 /* diagnostic output (\&{show}, \&{showvariable}, etc.) */
4621 @d mode_command 25 /* set interaction level (\&{batchmode}, etc.) */
4622 @d mp_random_seed 26 /* initialize random number generator (\&{randomseed}) */
4623 @d message_command 27 /* communicate to user (\&{message}, \&{errmessage}) */
4624 @d every_job_command 28 /* designate a starting token (\&{everyjob}) */
4625 @d delimiters 29 /* define a pair of delimiters (\&{delimiters}) */
4626 @d special_command 30 /* output special info (\&{special})
4627 or font map info (\&{fontmapfile}, \&{fontmapline}) */
4628 @d write_command 31 /* write text to a file (\&{write}) */
4629 @d type_name 32 /* declare a type (\&{numeric}, \&{pair}, etc.) */
4630 @d max_statement_command type_name
4631 @d min_primary_command type_name
4632 @d left_delimiter 33 /* the left delimiter of a matching pair */
4633 @d begin_group 34 /* beginning of a group (\&{begingroup}) */
4634 @d nullary 35 /* an operator without arguments (e.g., \&{normaldeviate}) */
4635 @d unary 36 /* an operator with one argument (e.g., \&{sqrt}) */
4636 @d str_op 37 /* convert a suffix to a string (\&{str}) */
4637 @d cycle 38 /* close a cyclic path (\&{cycle}) */
4638 @d primary_binary 39 /* binary operation taking `\&{of}' (e.g., \&{point}) */
4639 @d capsule_token 40 /* a value that has been put into a token list */
4640 @d string_token 41 /* a string constant (e.g., |"hello"|) */
4641 @d internal_quantity 42 /* internal numeric parameter (e.g., \&{pausing}) */
4642 @d min_suffix_token internal_quantity
4643 @d tag_token 43 /* a symbolic token without a primitive meaning */
4644 @d numeric_token 44 /* a numeric constant (e.g., \.{3.14159}) */
4645 @d max_suffix_token numeric_token
4646 @d plus_or_minus 45 /* either `\.+' or `\.-' */
4647 @d max_primary_command plus_or_minus /* should also be |numeric_token+1| */
4648 @d min_tertiary_command plus_or_minus
4649 @d tertiary_secondary_macro 46 /* a macro defined by \&{secondarydef} */
4650 @d tertiary_binary 47 /* an operator at the tertiary level (e.g., `\.{++}') */
4651 @d max_tertiary_command tertiary_binary
4652 @d left_brace 48 /* the operator `\.{\char`\{}' */
4653 @d min_expression_command left_brace
4654 @d path_join 49 /* the operator `\.{..}' */
4655 @d ampersand 50 /* the operator `\.\&' */
4656 @d expression_tertiary_macro 51 /* a macro defined by \&{tertiarydef} */
4657 @d expression_binary 52 /* an operator at the expression level (e.g., `\.<') */
4658 @d equals 53 /* the operator `\.=' */
4659 @d max_expression_command equals
4660 @d and_command 54 /* the operator `\&{and}' */
4661 @d min_secondary_command and_command
4662 @d secondary_primary_macro 55 /* a macro defined by \&{primarydef} */
4663 @d slash 56 /* the operator `\./' */
4664 @d secondary_binary 57 /* an operator at the binary level (e.g., \&{shifted}) */
4665 @d max_secondary_command secondary_binary
4666 @d param_type 58 /* type of parameter (\&{primary}, \&{expr}, \&{suffix}, etc.) */
4667 @d controls 59 /* specify control points explicitly (\&{controls}) */
4668 @d tension 60 /* specify tension between knots (\&{tension}) */
4669 @d at_least 61 /* bounded tension value (\&{atleast}) */
4670 @d curl_command 62 /* specify curl at an end knot (\&{curl}) */
4671 @d macro_special 63 /* special macro operators (\&{quote}, \.{\#\AT!}, etc.) */
4672 @d right_delimiter 64 /* the right delimiter of a matching pair */
4673 @d left_bracket 65 /* the operator `\.[' */
4674 @d right_bracket 66 /* the operator `\.]' */
4675 @d right_brace 67 /* the operator `\.{\char`\}}' */
4676 @d with_option 68 /* option for filling (\&{withpen}, \&{withweight}, etc.) */
4678 /* variant of \&{addto} (\&{contour}, \&{doublepath}, \&{also}) */
4679 @d of_token 70 /* the operator `\&{of}' */
4680 @d to_token 71 /* the operator `\&{to}' */
4681 @d step_token 72 /* the operator `\&{step}' */
4682 @d until_token 73 /* the operator `\&{until}' */
4683 @d within_token 74 /* the operator `\&{within}' */
4684 @d lig_kern_token 75
4685 /* the operators `\&{kern}' and `\.{=:}' and `\.{=:\char'174}', etc. */
4686 @d assignment 76 /* the operator `\.{:=}' */
4687 @d skip_to 77 /* the operation `\&{skipto}' */
4688 @d bchar_label 78 /* the operator `\.{\char'174\char'174:}' */
4689 @d double_colon 79 /* the operator `\.{::}' */
4690 @d colon 80 /* the operator `\.:' */
4692 @d comma 81 /* the operator `\.,', must be |colon+1| */
4693 @d end_of_statement (mp->cur_cmd>comma)
4694 @d semicolon 82 /* the operator `\.;', must be |comma+1| */
4695 @d end_group 83 /* end a group (\&{endgroup}), must be |semicolon+1| */
4696 @d stop 84 /* end a job (\&{end}, \&{dump}), must be |end_group+1| */
4697 @d max_command_code stop
4698 @d outer_tag (max_command_code+1) /* protection code added to command code */
4701 typedef int command_code;
4703 @ Variables and capsules in \MP\ have a variety of ``types,''
4704 distinguished by the code numbers defined here. These numbers are also
4705 not completely arbitrary. Things that get expanded must have types
4706 |>mp_independent|; a type remaining after expansion is numeric if and only if
4707 its code number is at least |numeric_type|; objects containing numeric
4708 parts must have types between |transform_type| and |pair_type|;
4709 all other types must be smaller than |transform_type|; and among the types
4710 that are not unknown or vacuous, the smallest two must be |boolean_type|
4711 and |string_type| in that order.
4713 @d undefined 0 /* no type has been declared */
4714 @d unknown_tag 1 /* this constant is added to certain type codes below */
4715 @d unknown_types mp_unknown_boolean: case mp_unknown_string:
4716 case mp_unknown_pen: case mp_unknown_picture: case mp_unknown_path
4719 enum mp_variable_type {
4720 mp_vacuous=1, /* no expression was present */
4721 mp_boolean_type, /* \&{boolean} with a known value */
4723 mp_string_type, /* \&{string} with a known value */
4725 mp_pen_type, /* \&{pen} with a known value */
4727 mp_path_type, /* \&{path} with a known value */
4729 mp_picture_type, /* \&{picture} with a known value */
4731 mp_transform_type, /* \&{transform} variable or capsule */
4732 mp_color_type, /* \&{color} variable or capsule */
4733 mp_cmykcolor_type, /* \&{cmykcolor} variable or capsule */
4734 mp_pair_type, /* \&{pair} variable or capsule */
4735 mp_numeric_type, /* variable that has been declared \&{numeric} but not used */
4736 mp_known, /* \&{numeric} with a known value */
4737 mp_dependent, /* a linear combination with |fraction| coefficients */
4738 mp_proto_dependent, /* a linear combination with |scaled| coefficients */
4739 mp_independent, /* \&{numeric} with unknown value */
4740 mp_token_list, /* variable name or suffix argument or text argument */
4741 mp_structured, /* variable with subscripts and attributes */
4742 mp_unsuffixed_macro, /* variable defined with \&{vardef} but no \.{\AT!\#} */
4743 mp_suffixed_macro /* variable defined with \&{vardef} and \.{\AT!\#} */
4747 void mp_print_type (MP mp,small_number t) ;
4749 @ @<Basic printing procedures@>=
4750 void mp_print_type (MP mp,small_number t) {
4752 case mp_vacuous:mp_print(mp, "mp_vacuous"); break;
4753 case mp_boolean_type:mp_print(mp, "boolean"); break;
4754 case mp_unknown_boolean:mp_print(mp, "unknown boolean"); break;
4755 case mp_string_type:mp_print(mp, "string"); break;
4756 case mp_unknown_string:mp_print(mp, "unknown string"); break;
4757 case mp_pen_type:mp_print(mp, "pen"); break;
4758 case mp_unknown_pen:mp_print(mp, "unknown pen"); break;
4759 case mp_path_type:mp_print(mp, "path"); break;
4760 case mp_unknown_path:mp_print(mp, "unknown path"); break;
4761 case mp_picture_type:mp_print(mp, "picture"); break;
4762 case mp_unknown_picture:mp_print(mp, "unknown picture"); break;
4763 case mp_transform_type:mp_print(mp, "transform"); break;
4764 case mp_color_type:mp_print(mp, "color"); break;
4765 case mp_cmykcolor_type:mp_print(mp, "cmykcolor"); break;
4766 case mp_pair_type:mp_print(mp, "pair"); break;
4767 case mp_known:mp_print(mp, "known numeric"); break;
4768 case mp_dependent:mp_print(mp, "dependent"); break;
4769 case mp_proto_dependent:mp_print(mp, "proto-dependent"); break;
4770 case mp_numeric_type:mp_print(mp, "numeric"); break;
4771 case mp_independent:mp_print(mp, "independent"); break;
4772 case mp_token_list:mp_print(mp, "token list"); break;
4773 case mp_structured:mp_print(mp, "mp_structured"); break;
4774 case mp_unsuffixed_macro:mp_print(mp, "unsuffixed macro"); break;
4775 case mp_suffixed_macro:mp_print(mp, "suffixed macro"); break;
4776 default: mp_print(mp, "undefined"); break;
4780 @ Values inside \MP\ are stored in two-word nodes that have a |name_type|
4781 as well as a |type|. The possibilities for |name_type| are defined
4782 here; they will be explained in more detail later.
4786 mp_root=0, /* |name_type| at the top level of a variable */
4787 mp_saved_root, /* same, when the variable has been saved */
4788 mp_structured_root, /* |name_type| where a |mp_structured| branch occurs */
4789 mp_subscr, /* |name_type| in a subscript node */
4790 mp_attr, /* |name_type| in an attribute node */
4791 mp_x_part_sector, /* |name_type| in the \&{xpart} of a node */
4792 mp_y_part_sector, /* |name_type| in the \&{ypart} of a node */
4793 mp_xx_part_sector, /* |name_type| in the \&{xxpart} of a node */
4794 mp_xy_part_sector, /* |name_type| in the \&{xypart} of a node */
4795 mp_yx_part_sector, /* |name_type| in the \&{yxpart} of a node */
4796 mp_yy_part_sector, /* |name_type| in the \&{yypart} of a node */
4797 mp_red_part_sector, /* |name_type| in the \&{redpart} of a node */
4798 mp_green_part_sector, /* |name_type| in the \&{greenpart} of a node */
4799 mp_blue_part_sector, /* |name_type| in the \&{bluepart} of a node */
4800 mp_cyan_part_sector, /* |name_type| in the \&{redpart} of a node */
4801 mp_magenta_part_sector, /* |name_type| in the \&{greenpart} of a node */
4802 mp_yellow_part_sector, /* |name_type| in the \&{bluepart} of a node */
4803 mp_black_part_sector, /* |name_type| in the \&{greenpart} of a node */
4804 mp_grey_part_sector, /* |name_type| in the \&{bluepart} of a node */
4805 mp_capsule, /* |name_type| in stashed-away subexpressions */
4806 mp_token /* |name_type| in a numeric token or string token */
4809 @ Primitive operations that produce values have a secondary identification
4810 code in addition to their command code; it's something like genera and species.
4811 For example, `\.*' has the command code |primary_binary|, and its
4812 secondary identification is |times|. The secondary codes start at 30 so that
4813 they don't overlap with the type codes; some type codes (e.g., |mp_string_type|)
4814 are used as operators as well as type identifications. The relative values
4815 are not critical, except for |true_code..false_code|, |or_op..and_op|,
4816 and |filled_op..bounded_op|. The restrictions are that
4817 |and_op-false_code=or_op-true_code|, that the ordering of
4818 |x_part...blue_part| must match that of |x_part_sector..mp_blue_part_sector|,
4819 and the ordering of |filled_op..bounded_op| must match that of the code
4820 values they test for.
4822 @d true_code 30 /* operation code for \.{true} */
4823 @d false_code 31 /* operation code for \.{false} */
4824 @d null_picture_code 32 /* operation code for \.{nullpicture} */
4825 @d null_pen_code 33 /* operation code for \.{nullpen} */
4826 @d job_name_op 34 /* operation code for \.{jobname} */
4827 @d read_string_op 35 /* operation code for \.{readstring} */
4828 @d pen_circle 36 /* operation code for \.{pencircle} */
4829 @d normal_deviate 37 /* operation code for \.{normaldeviate} */
4830 @d read_from_op 38 /* operation code for \.{readfrom} */
4831 @d close_from_op 39 /* operation code for \.{closefrom} */
4832 @d odd_op 40 /* operation code for \.{odd} */
4833 @d known_op 41 /* operation code for \.{known} */
4834 @d unknown_op 42 /* operation code for \.{unknown} */
4835 @d not_op 43 /* operation code for \.{not} */
4836 @d decimal 44 /* operation code for \.{decimal} */
4837 @d reverse 45 /* operation code for \.{reverse} */
4838 @d make_path_op 46 /* operation code for \.{makepath} */
4839 @d make_pen_op 47 /* operation code for \.{makepen} */
4840 @d oct_op 48 /* operation code for \.{oct} */
4841 @d hex_op 49 /* operation code for \.{hex} */
4842 @d ASCII_op 50 /* operation code for \.{ASCII} */
4843 @d char_op 51 /* operation code for \.{char} */
4844 @d length_op 52 /* operation code for \.{length} */
4845 @d turning_op 53 /* operation code for \.{turningnumber} */
4846 @d color_model_part 54 /* operation code for \.{colormodel} */
4847 @d x_part 55 /* operation code for \.{xpart} */
4848 @d y_part 56 /* operation code for \.{ypart} */
4849 @d xx_part 57 /* operation code for \.{xxpart} */
4850 @d xy_part 58 /* operation code for \.{xypart} */
4851 @d yx_part 59 /* operation code for \.{yxpart} */
4852 @d yy_part 60 /* operation code for \.{yypart} */
4853 @d red_part 61 /* operation code for \.{redpart} */
4854 @d green_part 62 /* operation code for \.{greenpart} */
4855 @d blue_part 63 /* operation code for \.{bluepart} */
4856 @d cyan_part 64 /* operation code for \.{cyanpart} */
4857 @d magenta_part 65 /* operation code for \.{magentapart} */
4858 @d yellow_part 66 /* operation code for \.{yellowpart} */
4859 @d black_part 67 /* operation code for \.{blackpart} */
4860 @d grey_part 68 /* operation code for \.{greypart} */
4861 @d font_part 69 /* operation code for \.{fontpart} */
4862 @d text_part 70 /* operation code for \.{textpart} */
4863 @d path_part 71 /* operation code for \.{pathpart} */
4864 @d pen_part 72 /* operation code for \.{penpart} */
4865 @d dash_part 73 /* operation code for \.{dashpart} */
4866 @d sqrt_op 74 /* operation code for \.{sqrt} */
4867 @d m_exp_op 75 /* operation code for \.{mexp} */
4868 @d m_log_op 76 /* operation code for \.{mlog} */
4869 @d sin_d_op 77 /* operation code for \.{sind} */
4870 @d cos_d_op 78 /* operation code for \.{cosd} */
4871 @d floor_op 79 /* operation code for \.{floor} */
4872 @d uniform_deviate 80 /* operation code for \.{uniformdeviate} */
4873 @d char_exists_op 81 /* operation code for \.{charexists} */
4874 @d font_size 82 /* operation code for \.{fontsize} */
4875 @d ll_corner_op 83 /* operation code for \.{llcorner} */
4876 @d lr_corner_op 84 /* operation code for \.{lrcorner} */
4877 @d ul_corner_op 85 /* operation code for \.{ulcorner} */
4878 @d ur_corner_op 86 /* operation code for \.{urcorner} */
4879 @d arc_length 87 /* operation code for \.{arclength} */
4880 @d angle_op 88 /* operation code for \.{angle} */
4881 @d cycle_op 89 /* operation code for \.{cycle} */
4882 @d filled_op 90 /* operation code for \.{filled} */
4883 @d stroked_op 91 /* operation code for \.{stroked} */
4884 @d textual_op 92 /* operation code for \.{textual} */
4885 @d clipped_op 93 /* operation code for \.{clipped} */
4886 @d bounded_op 94 /* operation code for \.{bounded} */
4887 @d plus 95 /* operation code for \.+ */
4888 @d minus 96 /* operation code for \.- */
4889 @d times 97 /* operation code for \.* */
4890 @d over 98 /* operation code for \./ */
4891 @d pythag_add 99 /* operation code for \.{++} */
4892 @d pythag_sub 100 /* operation code for \.{+-+} */
4893 @d or_op 101 /* operation code for \.{or} */
4894 @d and_op 102 /* operation code for \.{and} */
4895 @d less_than 103 /* operation code for \.< */
4896 @d less_or_equal 104 /* operation code for \.{<=} */
4897 @d greater_than 105 /* operation code for \.> */
4898 @d greater_or_equal 106 /* operation code for \.{>=} */
4899 @d equal_to 107 /* operation code for \.= */
4900 @d unequal_to 108 /* operation code for \.{<>} */
4901 @d concatenate 109 /* operation code for \.\& */
4902 @d rotated_by 110 /* operation code for \.{rotated} */
4903 @d slanted_by 111 /* operation code for \.{slanted} */
4904 @d scaled_by 112 /* operation code for \.{scaled} */
4905 @d shifted_by 113 /* operation code for \.{shifted} */
4906 @d transformed_by 114 /* operation code for \.{transformed} */
4907 @d x_scaled 115 /* operation code for \.{xscaled} */
4908 @d y_scaled 116 /* operation code for \.{yscaled} */
4909 @d z_scaled 117 /* operation code for \.{zscaled} */
4910 @d in_font 118 /* operation code for \.{infont} */
4911 @d intersect 119 /* operation code for \.{intersectiontimes} */
4912 @d double_dot 120 /* operation code for improper \.{..} */
4913 @d substring_of 121 /* operation code for \.{substring} */
4914 @d min_of substring_of
4915 @d subpath_of 122 /* operation code for \.{subpath} */
4916 @d direction_time_of 123 /* operation code for \.{directiontime} */
4917 @d point_of 124 /* operation code for \.{point} */
4918 @d precontrol_of 125 /* operation code for \.{precontrol} */
4919 @d postcontrol_of 126 /* operation code for \.{postcontrol} */
4920 @d pen_offset_of 127 /* operation code for \.{penoffset} */
4921 @d arc_time_of 128 /* operation code for \.{arctime} */
4922 @d mp_version 129 /* operation code for \.{mpversion} */
4923 @d envelope_of 130 /* operation code for \.{envelope} */
4925 @c void mp_print_op (MP mp,quarterword c) {
4926 if (c<=mp_numeric_type ) {
4927 mp_print_type(mp, c);
4930 case true_code:mp_print(mp, "true"); break;
4931 case false_code:mp_print(mp, "false"); break;
4932 case null_picture_code:mp_print(mp, "nullpicture"); break;
4933 case null_pen_code:mp_print(mp, "nullpen"); break;
4934 case job_name_op:mp_print(mp, "jobname"); break;
4935 case read_string_op:mp_print(mp, "readstring"); break;
4936 case pen_circle:mp_print(mp, "pencircle"); break;
4937 case normal_deviate:mp_print(mp, "normaldeviate"); break;
4938 case read_from_op:mp_print(mp, "readfrom"); break;
4939 case close_from_op:mp_print(mp, "closefrom"); break;
4940 case odd_op:mp_print(mp, "odd"); break;
4941 case known_op:mp_print(mp, "known"); break;
4942 case unknown_op:mp_print(mp, "unknown"); break;
4943 case not_op:mp_print(mp, "not"); break;
4944 case decimal:mp_print(mp, "decimal"); break;
4945 case reverse:mp_print(mp, "reverse"); break;
4946 case make_path_op:mp_print(mp, "makepath"); break;
4947 case make_pen_op:mp_print(mp, "makepen"); break;
4948 case oct_op:mp_print(mp, "oct"); break;
4949 case hex_op:mp_print(mp, "hex"); break;
4950 case ASCII_op:mp_print(mp, "ASCII"); break;
4951 case char_op:mp_print(mp, "char"); break;
4952 case length_op:mp_print(mp, "length"); break;
4953 case turning_op:mp_print(mp, "turningnumber"); break;
4954 case x_part:mp_print(mp, "xpart"); break;
4955 case y_part:mp_print(mp, "ypart"); break;
4956 case xx_part:mp_print(mp, "xxpart"); break;
4957 case xy_part:mp_print(mp, "xypart"); break;
4958 case yx_part:mp_print(mp, "yxpart"); break;
4959 case yy_part:mp_print(mp, "yypart"); break;
4960 case red_part:mp_print(mp, "redpart"); break;
4961 case green_part:mp_print(mp, "greenpart"); break;
4962 case blue_part:mp_print(mp, "bluepart"); break;
4963 case cyan_part:mp_print(mp, "cyanpart"); break;
4964 case magenta_part:mp_print(mp, "magentapart"); break;
4965 case yellow_part:mp_print(mp, "yellowpart"); break;
4966 case black_part:mp_print(mp, "blackpart"); break;
4967 case grey_part:mp_print(mp, "greypart"); break;
4968 case color_model_part:mp_print(mp, "colormodel"); break;
4969 case font_part:mp_print(mp, "fontpart"); break;
4970 case text_part:mp_print(mp, "textpart"); break;
4971 case path_part:mp_print(mp, "pathpart"); break;
4972 case pen_part:mp_print(mp, "penpart"); break;
4973 case dash_part:mp_print(mp, "dashpart"); break;
4974 case sqrt_op:mp_print(mp, "sqrt"); break;
4975 case m_exp_op:mp_print(mp, "mexp"); break;
4976 case m_log_op:mp_print(mp, "mlog"); break;
4977 case sin_d_op:mp_print(mp, "sind"); break;
4978 case cos_d_op:mp_print(mp, "cosd"); break;
4979 case floor_op:mp_print(mp, "floor"); break;
4980 case uniform_deviate:mp_print(mp, "uniformdeviate"); break;
4981 case char_exists_op:mp_print(mp, "charexists"); break;
4982 case font_size:mp_print(mp, "fontsize"); break;
4983 case ll_corner_op:mp_print(mp, "llcorner"); break;
4984 case lr_corner_op:mp_print(mp, "lrcorner"); break;
4985 case ul_corner_op:mp_print(mp, "ulcorner"); break;
4986 case ur_corner_op:mp_print(mp, "urcorner"); break;
4987 case arc_length:mp_print(mp, "arclength"); break;
4988 case angle_op:mp_print(mp, "angle"); break;
4989 case cycle_op:mp_print(mp, "cycle"); break;
4990 case filled_op:mp_print(mp, "filled"); break;
4991 case stroked_op:mp_print(mp, "stroked"); break;
4992 case textual_op:mp_print(mp, "textual"); break;
4993 case clipped_op:mp_print(mp, "clipped"); break;
4994 case bounded_op:mp_print(mp, "bounded"); break;
4995 case plus:mp_print_char(mp, '+'); break;
4996 case minus:mp_print_char(mp, '-'); break;
4997 case times:mp_print_char(mp, '*'); break;
4998 case over:mp_print_char(mp, '/'); break;
4999 case pythag_add:mp_print(mp, "++"); break;
5000 case pythag_sub:mp_print(mp, "+-+"); break;
5001 case or_op:mp_print(mp, "or"); break;
5002 case and_op:mp_print(mp, "and"); break;
5003 case less_than:mp_print_char(mp, '<'); break;
5004 case less_or_equal:mp_print(mp, "<="); break;
5005 case greater_than:mp_print_char(mp, '>'); break;
5006 case greater_or_equal:mp_print(mp, ">="); break;
5007 case equal_to:mp_print_char(mp, '='); break;
5008 case unequal_to:mp_print(mp, "<>"); break;
5009 case concatenate:mp_print(mp, "&"); break;
5010 case rotated_by:mp_print(mp, "rotated"); break;
5011 case slanted_by:mp_print(mp, "slanted"); break;
5012 case scaled_by:mp_print(mp, "scaled"); break;
5013 case shifted_by:mp_print(mp, "shifted"); break;
5014 case transformed_by:mp_print(mp, "transformed"); break;
5015 case x_scaled:mp_print(mp, "xscaled"); break;
5016 case y_scaled:mp_print(mp, "yscaled"); break;
5017 case z_scaled:mp_print(mp, "zscaled"); break;
5018 case in_font:mp_print(mp, "infont"); break;
5019 case intersect:mp_print(mp, "intersectiontimes"); break;
5020 case substring_of:mp_print(mp, "substring"); break;
5021 case subpath_of:mp_print(mp, "subpath"); break;
5022 case direction_time_of:mp_print(mp, "directiontime"); break;
5023 case point_of:mp_print(mp, "point"); break;
5024 case precontrol_of:mp_print(mp, "precontrol"); break;
5025 case postcontrol_of:mp_print(mp, "postcontrol"); break;
5026 case pen_offset_of:mp_print(mp, "penoffset"); break;
5027 case arc_time_of:mp_print(mp, "arctime"); break;
5028 case mp_version:mp_print(mp, "mpversion"); break;
5029 case envelope_of:mp_print(mp, "envelope"); break;
5030 default: mp_print(mp, ".."); break;
5035 @ \MP\ also has a bunch of internal parameters that a user might want to
5036 fuss with. Every such parameter has an identifying code number, defined here.
5039 enum mp_given_internal {
5040 mp_tracing_titles=1, /* show titles online when they appear */
5041 mp_tracing_equations, /* show each variable when it becomes known */
5042 mp_tracing_capsules, /* show capsules too */
5043 mp_tracing_choices, /* show the control points chosen for paths */
5044 mp_tracing_specs, /* show path subdivision prior to filling with polygonal a pen */
5045 mp_tracing_commands, /* show commands and operations before they are performed */
5046 mp_tracing_restores, /* show when a variable or internal is restored */
5047 mp_tracing_macros, /* show macros before they are expanded */
5048 mp_tracing_output, /* show digitized edges as they are output */
5049 mp_tracing_stats, /* show memory usage at end of job */
5050 mp_tracing_lost_chars, /* show characters that aren't \&{infont} */
5051 mp_tracing_online, /* show long diagnostics on terminal and in the log file */
5052 mp_year, /* the current year (e.g., 1984) */
5053 mp_month, /* the current month (e.g., 3 $\equiv$ March) */
5054 mp_day, /* the current day of the month */
5055 mp_time, /* the number of minutes past midnight when this job started */
5056 mp_char_code, /* the number of the next character to be output */
5057 mp_char_ext, /* the extension code of the next character to be output */
5058 mp_char_wd, /* the width of the next character to be output */
5059 mp_char_ht, /* the height of the next character to be output */
5060 mp_char_dp, /* the depth of the next character to be output */
5061 mp_char_ic, /* the italic correction of the next character to be output */
5062 mp_design_size, /* the unit of measure used for |mp_char_wd..mp_char_ic|, in points */
5063 mp_pausing, /* positive to display lines on the terminal before they are read */
5064 mp_showstopping, /* positive to stop after each \&{show} command */
5065 mp_fontmaking, /* positive if font metric output is to be produced */
5066 mp_linejoin, /* as in \ps: 0 for mitered, 1 for round, 2 for beveled */
5067 mp_linecap, /* as in \ps: 0 for butt, 1 for round, 2 for square */
5068 mp_miterlimit, /* controls miter length as in \ps */
5069 mp_warning_check, /* controls error message when variable value is large */
5070 mp_boundary_char, /* the right boundary character for ligatures */
5071 mp_prologues, /* positive to output conforming PostScript using built-in fonts */
5072 mp_true_corners, /* positive to make \&{llcorner} etc. ignore \&{setbounds} */
5073 mp_default_color_model, /* the default color model for unspecified items */
5074 mp_restore_clip_color,
5075 mp_procset, /* wether or not create PostScript command shortcuts */
5076 mp_gtroffmode /* whether the user specified |-troff| on the command line */
5081 @d max_given_internal mp_gtroffmode
5084 scaled *internal; /* the values of internal quantities */
5085 char **int_name; /* their names */
5086 int int_ptr; /* the maximum internal quantity defined so far */
5087 int max_internal; /* current maximum number of internal quantities */
5089 @ @<Option variables@>=
5092 @ @<Allocate or initialize ...@>=
5093 mp->max_internal=2*max_given_internal;
5094 mp->internal = xmalloc ((mp->max_internal+1), sizeof(scaled));
5095 mp->int_name = xmalloc ((mp->max_internal+1), sizeof(char *));
5096 mp->troff_mode=(opt->troff_mode>0 ? true : false);
5098 @ @<Exported function ...@>=
5099 int mp_troff_mode(MP mp);
5102 int mp_troff_mode(MP mp) { return mp->troff_mode; }
5104 @ @<Set initial ...@>=
5105 for (k=0;k<= mp->max_internal; k++ ) {
5107 mp->int_name[k]=NULL;
5109 mp->int_ptr=max_given_internal;
5111 @ The symbolic names for internal quantities are put into \MP's hash table
5112 by using a routine called |primitive|, which will be defined later. Let us
5113 enter them now, so that we don't have to list all those names again
5116 @<Put each of \MP's primitives into the hash table@>=
5117 mp_primitive(mp, "tracingtitles",internal_quantity,mp_tracing_titles);
5118 @:tracingtitles_}{\&{tracingtitles} primitive@>
5119 mp_primitive(mp, "tracingequations",internal_quantity,mp_tracing_equations);
5120 @:mp_tracing_equations_}{\&{tracingequations} primitive@>
5121 mp_primitive(mp, "tracingcapsules",internal_quantity,mp_tracing_capsules);
5122 @:mp_tracing_capsules_}{\&{tracingcapsules} primitive@>
5123 mp_primitive(mp, "tracingchoices",internal_quantity,mp_tracing_choices);
5124 @:mp_tracing_choices_}{\&{tracingchoices} primitive@>
5125 mp_primitive(mp, "tracingspecs",internal_quantity,mp_tracing_specs);
5126 @:mp_tracing_specs_}{\&{tracingspecs} primitive@>
5127 mp_primitive(mp, "tracingcommands",internal_quantity,mp_tracing_commands);
5128 @:mp_tracing_commands_}{\&{tracingcommands} primitive@>
5129 mp_primitive(mp, "tracingrestores",internal_quantity,mp_tracing_restores);
5130 @:mp_tracing_restores_}{\&{tracingrestores} primitive@>
5131 mp_primitive(mp, "tracingmacros",internal_quantity,mp_tracing_macros);
5132 @:mp_tracing_macros_}{\&{tracingmacros} primitive@>
5133 mp_primitive(mp, "tracingoutput",internal_quantity,mp_tracing_output);
5134 @:mp_tracing_output_}{\&{tracingoutput} primitive@>
5135 mp_primitive(mp, "tracingstats",internal_quantity,mp_tracing_stats);
5136 @:mp_tracing_stats_}{\&{tracingstats} primitive@>
5137 mp_primitive(mp, "tracinglostchars",internal_quantity,mp_tracing_lost_chars);
5138 @:mp_tracing_lost_chars_}{\&{tracinglostchars} primitive@>
5139 mp_primitive(mp, "tracingonline",internal_quantity,mp_tracing_online);
5140 @:mp_tracing_online_}{\&{tracingonline} primitive@>
5141 mp_primitive(mp, "year",internal_quantity,mp_year);
5142 @:mp_year_}{\&{year} primitive@>
5143 mp_primitive(mp, "month",internal_quantity,mp_month);
5144 @:mp_month_}{\&{month} primitive@>
5145 mp_primitive(mp, "day",internal_quantity,mp_day);
5146 @:mp_day_}{\&{day} primitive@>
5147 mp_primitive(mp, "time",internal_quantity,mp_time);
5148 @:time_}{\&{time} primitive@>
5149 mp_primitive(mp, "charcode",internal_quantity,mp_char_code);
5150 @:mp_char_code_}{\&{charcode} primitive@>
5151 mp_primitive(mp, "charext",internal_quantity,mp_char_ext);
5152 @:mp_char_ext_}{\&{charext} primitive@>
5153 mp_primitive(mp, "charwd",internal_quantity,mp_char_wd);
5154 @:mp_char_wd_}{\&{charwd} primitive@>
5155 mp_primitive(mp, "charht",internal_quantity,mp_char_ht);
5156 @:mp_char_ht_}{\&{charht} primitive@>
5157 mp_primitive(mp, "chardp",internal_quantity,mp_char_dp);
5158 @:mp_char_dp_}{\&{chardp} primitive@>
5159 mp_primitive(mp, "charic",internal_quantity,mp_char_ic);
5160 @:mp_char_ic_}{\&{charic} primitive@>
5161 mp_primitive(mp, "designsize",internal_quantity,mp_design_size);
5162 @:mp_design_size_}{\&{designsize} primitive@>
5163 mp_primitive(mp, "pausing",internal_quantity,mp_pausing);
5164 @:mp_pausing_}{\&{pausing} primitive@>
5165 mp_primitive(mp, "showstopping",internal_quantity,mp_showstopping);
5166 @:mp_showstopping_}{\&{showstopping} primitive@>
5167 mp_primitive(mp, "fontmaking",internal_quantity,mp_fontmaking);
5168 @:mp_fontmaking_}{\&{fontmaking} primitive@>
5169 mp_primitive(mp, "linejoin",internal_quantity,mp_linejoin);
5170 @:mp_linejoin_}{\&{linejoin} primitive@>
5171 mp_primitive(mp, "linecap",internal_quantity,mp_linecap);
5172 @:mp_linecap_}{\&{linecap} primitive@>
5173 mp_primitive(mp, "miterlimit",internal_quantity,mp_miterlimit);
5174 @:mp_miterlimit_}{\&{miterlimit} primitive@>
5175 mp_primitive(mp, "warningcheck",internal_quantity,mp_warning_check);
5176 @:mp_warning_check_}{\&{warningcheck} primitive@>
5177 mp_primitive(mp, "boundarychar",internal_quantity,mp_boundary_char);
5178 @:mp_boundary_char_}{\&{boundarychar} primitive@>
5179 mp_primitive(mp, "prologues",internal_quantity,mp_prologues);
5180 @:mp_prologues_}{\&{prologues} primitive@>
5181 mp_primitive(mp, "truecorners",internal_quantity,mp_true_corners);
5182 @:mp_true_corners_}{\&{truecorners} primitive@>
5183 mp_primitive(mp, "mpprocset",internal_quantity,mp_procset);
5184 @:mp_procset_}{\&{mpprocset} primitive@>
5185 mp_primitive(mp, "troffmode",internal_quantity,mp_gtroffmode);
5186 @:troffmode_}{\&{troffmode} primitive@>
5187 mp_primitive(mp, "defaultcolormodel",internal_quantity,mp_default_color_model);
5188 @:mp_default_color_model_}{\&{defaultcolormodel} primitive@>
5189 mp_primitive(mp, "restoreclipcolor",internal_quantity,mp_restore_clip_color);
5190 @:mp_restore_clip_color_}{\&{restoreclipcolor} primitive@>
5192 @ Colors can be specified in four color models. In the special
5193 case of |no_model|, MetaPost does not output any color operator to
5194 the postscript output.
5196 Note: these values are passed directly on to |with_option|. This only
5197 works because the other possible values passed to |with_option| are
5198 8 and 10 respectively (from |with_pen| and |with_picture|).
5200 There is a first state, that is only used for |gs_colormodel|. It flags
5201 the fact that there has not been any kind of color specification by
5202 the user so far in the game.
5205 enum mp_color_model {
5210 mp_uninitialized_model=9
5214 @ @<Initialize table entries (done by \.{INIMP} only)@>=
5215 mp->internal[mp_default_color_model]=(mp_rgb_model*unity);
5216 mp->internal[mp_restore_clip_color]=unity;
5218 @ Well, we do have to list the names one more time, for use in symbolic
5221 @<Initialize table...@>=
5222 mp->int_name[mp_tracing_titles]=xstrdup("tracingtitles");
5223 mp->int_name[mp_tracing_equations]=xstrdup("tracingequations");
5224 mp->int_name[mp_tracing_capsules]=xstrdup("tracingcapsules");
5225 mp->int_name[mp_tracing_choices]=xstrdup("tracingchoices");
5226 mp->int_name[mp_tracing_specs]=xstrdup("tracingspecs");
5227 mp->int_name[mp_tracing_commands]=xstrdup("tracingcommands");
5228 mp->int_name[mp_tracing_restores]=xstrdup("tracingrestores");
5229 mp->int_name[mp_tracing_macros]=xstrdup("tracingmacros");
5230 mp->int_name[mp_tracing_output]=xstrdup("tracingoutput");
5231 mp->int_name[mp_tracing_stats]=xstrdup("tracingstats");
5232 mp->int_name[mp_tracing_lost_chars]=xstrdup("tracinglostchars");
5233 mp->int_name[mp_tracing_online]=xstrdup("tracingonline");
5234 mp->int_name[mp_year]=xstrdup("year");
5235 mp->int_name[mp_month]=xstrdup("month");
5236 mp->int_name[mp_day]=xstrdup("day");
5237 mp->int_name[mp_time]=xstrdup("time");
5238 mp->int_name[mp_char_code]=xstrdup("charcode");
5239 mp->int_name[mp_char_ext]=xstrdup("charext");
5240 mp->int_name[mp_char_wd]=xstrdup("charwd");
5241 mp->int_name[mp_char_ht]=xstrdup("charht");
5242 mp->int_name[mp_char_dp]=xstrdup("chardp");
5243 mp->int_name[mp_char_ic]=xstrdup("charic");
5244 mp->int_name[mp_design_size]=xstrdup("designsize");
5245 mp->int_name[mp_pausing]=xstrdup("pausing");
5246 mp->int_name[mp_showstopping]=xstrdup("showstopping");
5247 mp->int_name[mp_fontmaking]=xstrdup("fontmaking");
5248 mp->int_name[mp_linejoin]=xstrdup("linejoin");
5249 mp->int_name[mp_linecap]=xstrdup("linecap");
5250 mp->int_name[mp_miterlimit]=xstrdup("miterlimit");
5251 mp->int_name[mp_warning_check]=xstrdup("warningcheck");
5252 mp->int_name[mp_boundary_char]=xstrdup("boundarychar");
5253 mp->int_name[mp_prologues]=xstrdup("prologues");
5254 mp->int_name[mp_true_corners]=xstrdup("truecorners");
5255 mp->int_name[mp_default_color_model]=xstrdup("defaultcolormodel");
5256 mp->int_name[mp_procset]=xstrdup("mpprocset");
5257 mp->int_name[mp_gtroffmode]=xstrdup("troffmode");
5258 mp->int_name[mp_restore_clip_color]=xstrdup("restoreclipcolor");
5260 @ The following procedure, which is called just before \MP\ initializes its
5261 input and output, establishes the initial values of the date and time.
5262 @^system dependencies@>
5264 Note that the values are |scaled| integers. Hence \MP\ can no longer
5265 be used after the year 32767.
5268 void mp_fix_date_and_time (MP mp) {
5269 time_t aclock = time ((time_t *) 0);
5270 struct tm *tmptr = localtime (&aclock);
5271 mp->internal[mp_time]=
5272 (tmptr->tm_hour*60+tmptr->tm_min)*unity; /* minutes since midnight */
5273 mp->internal[mp_day]=(tmptr->tm_mday)*unity; /* fourth day of the month */
5274 mp->internal[mp_month]=(tmptr->tm_mon+1)*unity; /* seventh month of the year */
5275 mp->internal[mp_year]=(tmptr->tm_year+1900)*unity; /* Anno Domini */
5279 void mp_fix_date_and_time (MP mp) ;
5281 @ \MP\ is occasionally supposed to print diagnostic information that
5282 goes only into the transcript file, unless |mp_tracing_online| is positive.
5283 Now that we have defined |mp_tracing_online| we can define
5284 two routines that adjust the destination of print commands:
5287 void mp_begin_diagnostic (MP mp) ;
5288 void mp_end_diagnostic (MP mp,boolean blank_line);
5289 void mp_print_diagnostic (MP mp, const char *s, const char *t, boolean nuline) ;
5291 @ @<Basic printing...@>=
5292 @<Declare a function called |true_line|@>
5293 void mp_begin_diagnostic (MP mp) { /* prepare to do some tracing */
5294 mp->old_setting=mp->selector;
5295 if ((mp->internal[mp_tracing_online]<=0)&&(mp->selector==term_and_log)){
5297 if ( mp->history==mp_spotless ) mp->history=mp_warning_issued;
5301 void mp_end_diagnostic (MP mp,boolean blank_line) {
5302 /* restore proper conditions after tracing */
5303 mp_print_nl(mp, "");
5304 if ( blank_line ) mp_print_ln(mp);
5305 mp->selector=mp->old_setting;
5311 unsigned int old_setting;
5313 @ We will occasionally use |begin_diagnostic| in connection with line-number
5314 printing, as follows. (The parameter |s| is typically |"Path"| or
5315 |"Cycle spec"|, etc.)
5317 @<Basic printing...@>=
5318 void mp_print_diagnostic (MP mp, const char *s, const char *t, boolean nuline) {
5319 mp_begin_diagnostic(mp);
5320 if ( nuline ) mp_print_nl(mp, s); else mp_print(mp, s);
5321 mp_print(mp, " at line ");
5322 mp_print_int(mp, mp_true_line(mp));
5323 mp_print(mp, t); mp_print_char(mp, ':');
5326 @ The 256 |ASCII_code| characters are grouped into classes by means of
5327 the |char_class| table. Individual class numbers have no semantic
5328 or syntactic significance, except in a few instances defined here.
5329 There's also |max_class|, which can be used as a basis for additional
5330 class numbers in nonstandard extensions of \MP.
5332 @d digit_class 0 /* the class number of \.{0123456789} */
5333 @d period_class 1 /* the class number of `\..' */
5334 @d space_class 2 /* the class number of spaces and nonstandard characters */
5335 @d percent_class 3 /* the class number of `\.\%' */
5336 @d string_class 4 /* the class number of `\."' */
5337 @d right_paren_class 8 /* the class number of `\.)' */
5338 @d isolated_classes 5: case 6: case 7: case 8 /* characters that make length-one tokens only */
5339 @d letter_class 9 /* letters and the underline character */
5340 @d left_bracket_class 17 /* `\.[' */
5341 @d right_bracket_class 18 /* `\.]' */
5342 @d invalid_class 20 /* bad character in the input */
5343 @d max_class 20 /* the largest class number */
5346 int char_class[256]; /* the class numbers */
5348 @ If changes are made to accommodate non-ASCII character sets, they should
5349 follow the guidelines in Appendix~C of {\sl The {\logos METAFONT\/}book}.
5350 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
5351 @^system dependencies@>
5353 @<Set initial ...@>=
5354 for (k='0';k<='9';k++)
5355 mp->char_class[k]=digit_class;
5356 mp->char_class['.']=period_class;
5357 mp->char_class[' ']=space_class;
5358 mp->char_class['%']=percent_class;
5359 mp->char_class['"']=string_class;
5360 mp->char_class[',']=5;
5361 mp->char_class[';']=6;
5362 mp->char_class['(']=7;
5363 mp->char_class[')']=right_paren_class;
5364 for (k='A';k<= 'Z';k++ )
5365 mp->char_class[k]=letter_class;
5366 for (k='a';k<='z';k++)
5367 mp->char_class[k]=letter_class;
5368 mp->char_class['_']=letter_class;
5369 mp->char_class['<']=10;
5370 mp->char_class['=']=10;
5371 mp->char_class['>']=10;
5372 mp->char_class[':']=10;
5373 mp->char_class['|']=10;
5374 mp->char_class['`']=11;
5375 mp->char_class['\'']=11;
5376 mp->char_class['+']=12;
5377 mp->char_class['-']=12;
5378 mp->char_class['/']=13;
5379 mp->char_class['*']=13;
5380 mp->char_class['\\']=13;
5381 mp->char_class['!']=14;
5382 mp->char_class['?']=14;
5383 mp->char_class['#']=15;
5384 mp->char_class['&']=15;
5385 mp->char_class['@@']=15;
5386 mp->char_class['$']=15;
5387 mp->char_class['^']=16;
5388 mp->char_class['~']=16;
5389 mp->char_class['[']=left_bracket_class;
5390 mp->char_class[']']=right_bracket_class;
5391 mp->char_class['{']=19;
5392 mp->char_class['}']=19;
5394 mp->char_class[k]=invalid_class;
5395 mp->char_class['\t']=space_class;
5396 mp->char_class['\f']=space_class;
5397 for (k=127;k<=255;k++)
5398 mp->char_class[k]=invalid_class;
5400 @* \[13] The hash table.
5401 Symbolic tokens are stored and retrieved by means of a fairly standard hash
5402 table algorithm called the method of ``coalescing lists'' (cf.\ Algorithm 6.4C
5403 in {\sl The Art of Computer Programming\/}). Once a symbolic token enters the
5404 table, it is never removed.
5406 The actual sequence of characters forming a symbolic token is
5407 stored in the |str_pool| array together with all the other strings. An
5408 auxiliary array |hash| consists of items with two halfword fields per
5409 word. The first of these, called |next(p)|, points to the next identifier
5410 belonging to the same coalesced list as the identifier corresponding to~|p|;
5411 and the other, called |text(p)|, points to the |str_start| entry for
5412 |p|'s identifier. If position~|p| of the hash table is empty, we have
5413 |text(p)=0|; if position |p| is either empty or the end of a coalesced
5414 hash list, we have |next(p)=0|.
5416 An auxiliary pointer variable called |hash_used| is maintained in such a
5417 way that all locations |p>=hash_used| are nonempty. The global variable
5418 |st_count| tells how many symbolic tokens have been defined, if statistics
5421 The first 256 locations of |hash| are reserved for symbols of length one.
5423 There's a parallel array called |eqtb| that contains the current equivalent
5424 values of each symbolic token. The entries of this array consist of
5425 two halfwords called |eq_type| (a command code) and |equiv| (a secondary
5426 piece of information that qualifies the |eq_type|).
5428 @d next(A) mp->hash[(A)].lh /* link for coalesced lists */
5429 @d text(A) mp->hash[(A)].rh /* string number for symbolic token name */
5430 @d eq_type(A) mp->eqtb[(A)].lh /* the current ``meaning'' of a symbolic token */
5431 @d equiv(A) mp->eqtb[(A)].rh /* parametric part of a token's meaning */
5432 @d hash_base 257 /* hashing actually starts here */
5433 @d hash_is_full (mp->hash_used==hash_base) /* are all positions occupied? */
5436 pointer hash_used; /* allocation pointer for |hash| */
5437 integer st_count; /* total number of known identifiers */
5439 @ Certain entries in the hash table are ``frozen'' and not redefinable,
5440 since they are used in error recovery.
5442 @d hash_top (hash_base+mp->hash_size) /* the first location of the frozen area */
5443 @d frozen_inaccessible hash_top /* |hash| location to protect the frozen area */
5444 @d frozen_repeat_loop (hash_top+1) /* |hash| location of a loop-repeat token */
5445 @d frozen_right_delimiter (hash_top+2) /* |hash| location of a permanent `\.)' */
5446 @d frozen_left_bracket (hash_top+3) /* |hash| location of a permanent `\.[' */
5447 @d frozen_slash (hash_top+4) /* |hash| location of a permanent `\./' */
5448 @d frozen_colon (hash_top+5) /* |hash| location of a permanent `\.:' */
5449 @d frozen_semicolon (hash_top+6) /* |hash| location of a permanent `\.;' */
5450 @d frozen_end_for (hash_top+7) /* |hash| location of a permanent \&{endfor} */
5451 @d frozen_end_def (hash_top+8) /* |hash| location of a permanent \&{enddef} */
5452 @d frozen_fi (hash_top+9) /* |hash| location of a permanent \&{fi} */
5453 @d frozen_end_group (hash_top+10) /* |hash| location of a permanent `\.{endgroup}' */
5454 @d frozen_etex (hash_top+11) /* |hash| location of a permanent \&{etex} */
5455 @d frozen_mpx_break (hash_top+12) /* |hash| location of a permanent \&{mpxbreak} */
5456 @d frozen_bad_vardef (hash_top+13) /* |hash| location of `\.{a bad variable}' */
5457 @d frozen_undefined (hash_top+14) /* |hash| location that never gets defined */
5458 @d hash_end (hash_top+14) /* the actual size of the |hash| and |eqtb| arrays */
5461 two_halves *hash; /* the hash table */
5462 two_halves *eqtb; /* the equivalents */
5464 @ @<Allocate or initialize ...@>=
5465 mp->hash = xmalloc((hash_end+1),sizeof(two_halves));
5466 mp->eqtb = xmalloc((hash_end+1),sizeof(two_halves));
5468 @ @<Dealloc variables@>=
5473 next(1)=0; text(1)=0; eq_type(1)=tag_token; equiv(1)=null;
5474 for (k=2;k<=hash_end;k++) {
5475 mp->hash[k]=mp->hash[1]; mp->eqtb[k]=mp->eqtb[1];
5478 @ @<Initialize table entries...@>=
5479 mp->hash_used=frozen_inaccessible; /* nothing is used */
5481 text(frozen_bad_vardef)=intern("a bad variable");
5482 text(frozen_etex)=intern("etex");
5483 text(frozen_mpx_break)=intern("mpxbreak");
5484 text(frozen_fi)=intern("fi");
5485 text(frozen_end_group)=intern("endgroup");
5486 text(frozen_end_def)=intern("enddef");
5487 text(frozen_end_for)=intern("endfor");
5488 text(frozen_semicolon)=intern(";");
5489 text(frozen_colon)=intern(":");
5490 text(frozen_slash)=intern("/");
5491 text(frozen_left_bracket)=intern("[");
5492 text(frozen_right_delimiter)=intern(")");
5493 text(frozen_inaccessible)=intern(" INACCESSIBLE");
5494 eq_type(frozen_right_delimiter)=right_delimiter;
5496 @ @<Check the ``constant'' values...@>=
5497 if ( hash_end+mp->max_internal>max_halfword ) mp->bad=17;
5499 @ Here is the subroutine that searches the hash table for an identifier
5500 that matches a given string of length~|l| appearing in |buffer[j..
5501 (j+l-1)]|. If the identifier is not found, it is inserted; hence it
5502 will always be found, and the corresponding hash table address
5506 pointer mp_id_lookup (MP mp,integer j, integer l) { /* search the hash table */
5507 integer h; /* hash code */
5508 pointer p; /* index in |hash| array */
5509 pointer k; /* index in |buffer| array */
5511 @<Treat special case of length 1 and |break|@>;
5513 @<Compute the hash code |h|@>;
5514 p=h+hash_base; /* we start searching here; note that |0<=h<hash_prime| */
5516 if (text(p)>0 && length(text(p))==l && mp_str_eq_buf(mp, text(p),j))
5519 @<Insert a new symbolic token after |p|, then
5520 make |p| point to it and |break|@>;
5527 @ @<Treat special case of length 1...@>=
5528 p=mp->buffer[j]+1; text(p)=p-1; return p;
5531 @ @<Insert a new symbolic...@>=
5536 mp_overflow(mp, "hash size",mp->hash_size);
5537 @:MetaPost capacity exceeded hash size}{\quad hash size@>
5538 decr(mp->hash_used);
5539 } while (text(mp->hash_used)!=0); /* search for an empty location in |hash| */
5540 next(p)=mp->hash_used;
5544 for (k=j;k<=j+l-1;k++) {
5545 append_char(mp->buffer[k]);
5547 text(p)=mp_make_string(mp);
5548 mp->str_ref[text(p)]=max_str_ref;
5554 @ The value of |hash_prime| should be roughly 85\pct! of |hash_size|, and it
5555 should be a prime number. The theory of hashing tells us to expect fewer
5556 than two table probes, on the average, when the search is successful.
5557 [See J.~S. Vitter, {\sl Journal of the ACM\/ \bf30} (1983), 231--258.]
5558 @^Vitter, Jeffrey Scott@>
5560 @<Compute the hash code |h|@>=
5562 for (k=j+1;k<=j+l-1;k++){
5563 h=h+h+mp->buffer[k];
5564 while ( h>=mp->hash_prime ) h=h-mp->hash_prime;
5567 @ @<Search |eqtb| for equivalents equal to |p|@>=
5568 for (q=1;q<=hash_end;q++) {
5569 if ( equiv(q)==p ) {
5570 mp_print_nl(mp, "EQUIV(");
5571 mp_print_int(mp, q);
5572 mp_print_char(mp, ')');
5576 @ We need to put \MP's ``primitive'' symbolic tokens into the hash
5577 table, together with their command code (which will be the |eq_type|)
5578 and an operand (which will be the |equiv|). The |primitive| procedure
5579 does this, in a way that no \MP\ user can. The global value |cur_sym|
5580 contains the new |eqtb| pointer after |primitive| has acted.
5583 void mp_primitive (MP mp, const char *ss, halfword c, halfword o) {
5584 pool_pointer k; /* index into |str_pool| */
5585 small_number j; /* index into |buffer| */
5586 small_number l; /* length of the string */
5589 k=mp->str_start[s]; l=str_stop(s)-k;
5590 /* we will move |s| into the (empty) |buffer| */
5591 for (j=0;j<=l-1;j++) {
5592 mp->buffer[j]=mp->str_pool[k+j];
5594 mp->cur_sym=mp_id_lookup(mp, 0,l);
5595 if ( s>=256 ) { /* we don't want to have the string twice */
5596 mp_flush_string(mp, text(mp->cur_sym)); text(mp->cur_sym)=s;
5598 eq_type(mp->cur_sym)=c;
5599 equiv(mp->cur_sym)=o;
5603 @ Many of \MP's primitives need no |equiv|, since they are identifiable
5604 by their |eq_type| alone. These primitives are loaded into the hash table
5607 @<Put each of \MP's primitives into the hash table@>=
5608 mp_primitive(mp, "..",path_join,0);
5609 @:.._}{\.{..} primitive@>
5610 mp_primitive(mp, "[",left_bracket,0); mp->eqtb[frozen_left_bracket]=mp->eqtb[mp->cur_sym];
5611 @:[ }{\.{[} primitive@>
5612 mp_primitive(mp, "]",right_bracket,0);
5613 @:] }{\.{]} primitive@>
5614 mp_primitive(mp, "}",right_brace,0);
5615 @:]]}{\.{\char`\}} primitive@>
5616 mp_primitive(mp, "{",left_brace,0);
5617 @:][}{\.{\char`\{} primitive@>
5618 mp_primitive(mp, ":",colon,0); mp->eqtb[frozen_colon]=mp->eqtb[mp->cur_sym];
5619 @:: }{\.{:} primitive@>
5620 mp_primitive(mp, "::",double_colon,0);
5621 @::: }{\.{::} primitive@>
5622 mp_primitive(mp, "||:",bchar_label,0);
5623 @:::: }{\.{\char'174\char'174:} primitive@>
5624 mp_primitive(mp, ":=",assignment,0);
5625 @::=_}{\.{:=} primitive@>
5626 mp_primitive(mp, ",",comma,0);
5627 @:, }{\., primitive@>
5628 mp_primitive(mp, ";",semicolon,0); mp->eqtb[frozen_semicolon]=mp->eqtb[mp->cur_sym];
5629 @:; }{\.; primitive@>
5630 mp_primitive(mp, "\\",relax,0);
5631 @:]]\\}{\.{\char`\\} primitive@>
5633 mp_primitive(mp, "addto",add_to_command,0);
5634 @:add_to_}{\&{addto} primitive@>
5635 mp_primitive(mp, "atleast",at_least,0);
5636 @:at_least_}{\&{atleast} primitive@>
5637 mp_primitive(mp, "begingroup",begin_group,0); mp->bg_loc=mp->cur_sym;
5638 @:begin_group_}{\&{begingroup} primitive@>
5639 mp_primitive(mp, "controls",controls,0);
5640 @:controls_}{\&{controls} primitive@>
5641 mp_primitive(mp, "curl",curl_command,0);
5642 @:curl_}{\&{curl} primitive@>
5643 mp_primitive(mp, "delimiters",delimiters,0);
5644 @:delimiters_}{\&{delimiters} primitive@>
5645 mp_primitive(mp, "endgroup",end_group,0);
5646 mp->eqtb[frozen_end_group]=mp->eqtb[mp->cur_sym]; mp->eg_loc=mp->cur_sym;
5647 @:endgroup_}{\&{endgroup} primitive@>
5648 mp_primitive(mp, "everyjob",every_job_command,0);
5649 @:every_job_}{\&{everyjob} primitive@>
5650 mp_primitive(mp, "exitif",exit_test,0);
5651 @:exit_if_}{\&{exitif} primitive@>
5652 mp_primitive(mp, "expandafter",expand_after,0);
5653 @:expand_after_}{\&{expandafter} primitive@>
5654 mp_primitive(mp, "interim",interim_command,0);
5655 @:interim_}{\&{interim} primitive@>
5656 mp_primitive(mp, "let",let_command,0);
5657 @:let_}{\&{let} primitive@>
5658 mp_primitive(mp, "newinternal",new_internal,0);
5659 @:new_internal_}{\&{newinternal} primitive@>
5660 mp_primitive(mp, "of",of_token,0);
5661 @:of_}{\&{of} primitive@>
5662 mp_primitive(mp, "randomseed",mp_random_seed,0);
5663 @:mp_random_seed_}{\&{randomseed} primitive@>
5664 mp_primitive(mp, "save",save_command,0);
5665 @:save_}{\&{save} primitive@>
5666 mp_primitive(mp, "scantokens",scan_tokens,0);
5667 @:scan_tokens_}{\&{scantokens} primitive@>
5668 mp_primitive(mp, "shipout",ship_out_command,0);
5669 @:ship_out_}{\&{shipout} primitive@>
5670 mp_primitive(mp, "skipto",skip_to,0);
5671 @:skip_to_}{\&{skipto} primitive@>
5672 mp_primitive(mp, "special",special_command,0);
5673 @:special}{\&{special} primitive@>
5674 mp_primitive(mp, "fontmapfile",special_command,1);
5675 @:fontmapfile}{\&{fontmapfile} primitive@>
5676 mp_primitive(mp, "fontmapline",special_command,2);
5677 @:fontmapline}{\&{fontmapline} primitive@>
5678 mp_primitive(mp, "step",step_token,0);
5679 @:step_}{\&{step} primitive@>
5680 mp_primitive(mp, "str",str_op,0);
5681 @:str_}{\&{str} primitive@>
5682 mp_primitive(mp, "tension",tension,0);
5683 @:tension_}{\&{tension} primitive@>
5684 mp_primitive(mp, "to",to_token,0);
5685 @:to_}{\&{to} primitive@>
5686 mp_primitive(mp, "until",until_token,0);
5687 @:until_}{\&{until} primitive@>
5688 mp_primitive(mp, "within",within_token,0);
5689 @:within_}{\&{within} primitive@>
5690 mp_primitive(mp, "write",write_command,0);
5691 @:write_}{\&{write} primitive@>
5693 @ Each primitive has a corresponding inverse, so that it is possible to
5694 display the cryptic numeric contents of |eqtb| in symbolic form.
5695 Every call of |primitive| in this program is therefore accompanied by some
5696 straightforward code that forms part of the |print_cmd_mod| routine
5699 @<Cases of |print_cmd_mod| for symbolic printing of primitives@>=
5700 case add_to_command:mp_print(mp, "addto"); break;
5701 case assignment:mp_print(mp, ":="); break;
5702 case at_least:mp_print(mp, "atleast"); break;
5703 case bchar_label:mp_print(mp, "||:"); break;
5704 case begin_group:mp_print(mp, "begingroup"); break;
5705 case colon:mp_print(mp, ":"); break;
5706 case comma:mp_print(mp, ","); break;
5707 case controls:mp_print(mp, "controls"); break;
5708 case curl_command:mp_print(mp, "curl"); break;
5709 case delimiters:mp_print(mp, "delimiters"); break;
5710 case double_colon:mp_print(mp, "::"); break;
5711 case end_group:mp_print(mp, "endgroup"); break;
5712 case every_job_command:mp_print(mp, "everyjob"); break;
5713 case exit_test:mp_print(mp, "exitif"); break;
5714 case expand_after:mp_print(mp, "expandafter"); break;
5715 case interim_command:mp_print(mp, "interim"); break;
5716 case left_brace:mp_print(mp, "{"); break;
5717 case left_bracket:mp_print(mp, "["); break;
5718 case let_command:mp_print(mp, "let"); break;
5719 case new_internal:mp_print(mp, "newinternal"); break;
5720 case of_token:mp_print(mp, "of"); break;
5721 case path_join:mp_print(mp, ".."); break;
5722 case mp_random_seed:mp_print(mp, "randomseed"); break;
5723 case relax:mp_print_char(mp, '\\'); break;
5724 case right_brace:mp_print(mp, "}"); break;
5725 case right_bracket:mp_print(mp, "]"); break;
5726 case save_command:mp_print(mp, "save"); break;
5727 case scan_tokens:mp_print(mp, "scantokens"); break;
5728 case semicolon:mp_print(mp, ";"); break;
5729 case ship_out_command:mp_print(mp, "shipout"); break;
5730 case skip_to:mp_print(mp, "skipto"); break;
5731 case special_command: if ( m==2 ) mp_print(mp, "fontmapline"); else
5732 if ( m==1 ) mp_print(mp, "fontmapfile"); else
5733 mp_print(mp, "special"); break;
5734 case step_token:mp_print(mp, "step"); break;
5735 case str_op:mp_print(mp, "str"); break;
5736 case tension:mp_print(mp, "tension"); break;
5737 case to_token:mp_print(mp, "to"); break;
5738 case until_token:mp_print(mp, "until"); break;
5739 case within_token:mp_print(mp, "within"); break;
5740 case write_command:mp_print(mp, "write"); break;
5742 @ We will deal with the other primitives later, at some point in the program
5743 where their |eq_type| and |equiv| values are more meaningful. For example,
5744 the primitives for macro definitions will be loaded when we consider the
5745 routines that define macros.
5746 It is easy to find where each particular
5747 primitive was treated by looking in the index at the end; for example, the
5748 section where |"def"| entered |eqtb| is listed under `\&{def} primitive'.
5750 @* \[14] Token lists.
5751 A \MP\ token is either symbolic or numeric or a string, or it denotes
5752 a macro parameter or capsule; so there are five corresponding ways to encode it
5754 internally: (1)~A symbolic token whose hash code is~|p|
5755 is represented by the number |p|, in the |info| field of a single-word
5756 node in~|mem|. (2)~A numeric token whose |scaled| value is~|v| is
5757 represented in a two-word node of~|mem|; the |type| field is |known|,
5758 the |name_type| field is |token|, and the |value| field holds~|v|.
5759 The fact that this token appears in a two-word node rather than a
5760 one-word node is, of course, clear from the node address.
5761 (3)~A string token is also represented in a two-word node; the |type|
5762 field is |mp_string_type|, the |name_type| field is |token|, and the
5763 |value| field holds the corresponding |str_number|. (4)~Capsules have
5764 |name_type=capsule|, and their |type| and |value| fields represent
5765 arbitrary values (in ways to be explained later). (5)~Macro parameters
5766 are like symbolic tokens in that they appear in |info| fields of
5767 one-word nodes. The $k$th parameter is represented by |expr_base+k| if it
5768 is of type \&{expr}, or by |suffix_base+k| if it is of type \&{suffix}, or
5769 by |text_base+k| if it is of type \&{text}. (Here |0<=k<param_size|.)
5770 Actual values of these parameters are kept in a separate stack, as we will
5771 see later. The constants |expr_base|, |suffix_base|, and |text_base| are,
5772 of course, chosen so that there will be no confusion between symbolic
5773 tokens and parameters of various types.
5776 the `\\{type}' field of a node has nothing to do with ``type'' in a
5777 printer's sense. It's curious that the same word is used in such different ways.
5779 @d type(A) mp->mem[(A)].hh.b0 /* identifies what kind of value this is */
5780 @d name_type(A) mp->mem[(A)].hh.b1 /* a clue to the name of this value */
5781 @d token_node_size 2 /* the number of words in a large token node */
5782 @d value_loc(A) ((A)+1) /* the word that contains the |value| field */
5783 @d value(A) mp->mem[value_loc((A))].cint /* the value stored in a large token node */
5784 @d expr_base (hash_end+1) /* code for the zeroth \&{expr} parameter */
5785 @d suffix_base (expr_base+mp->param_size) /* code for the zeroth \&{suffix} parameter */
5786 @d text_base (suffix_base+mp->param_size) /* code for the zeroth \&{text} parameter */
5788 @<Check the ``constant''...@>=
5789 if ( text_base+mp->param_size>max_halfword ) mp->bad=18;
5791 @ We have set aside a two word node beginning at |null| so that we can have
5792 |value(null)=0|. We will make use of this coincidence later.
5794 @<Initialize table entries...@>=
5795 link(null)=null; value(null)=0;
5797 @ A numeric token is created by the following trivial routine.
5800 pointer mp_new_num_tok (MP mp,scaled v) {
5801 pointer p; /* the new node */
5802 p=mp_get_node(mp, token_node_size); value(p)=v;
5803 type(p)=mp_known; name_type(p)=mp_token;
5807 @ A token list is a singly linked list of nodes in |mem|, where
5808 each node contains a token and a link. Here's a subroutine that gets rid
5809 of a token list when it is no longer needed.
5811 @c void mp_flush_token_list (MP mp,pointer p) {
5812 pointer q; /* the node being recycled */
5815 if ( q>=mp->hi_mem_min ) {
5819 case mp_vacuous: case mp_boolean_type: case mp_known:
5821 case mp_string_type:
5822 delete_str_ref(value(q));
5824 case unknown_types: case mp_pen_type: case mp_path_type:
5825 case mp_picture_type: case mp_pair_type: case mp_color_type:
5826 case mp_cmykcolor_type: case mp_transform_type: case mp_dependent:
5827 case mp_proto_dependent: case mp_independent:
5828 mp_recycle_value(mp,q);
5830 default: mp_confusion(mp, "token");
5831 @:this can't happen token}{\quad token@>
5833 mp_free_node(mp, q,token_node_size);
5838 @ The procedure |show_token_list|, which prints a symbolic form of
5839 the token list that starts at a given node |p|, illustrates these
5840 conventions. The token list being displayed should not begin with a reference
5841 count. However, the procedure is intended to be fairly robust, so that if the
5842 memory links are awry or if |p| is not really a pointer to a token list,
5843 almost nothing catastrophic can happen.
5845 An additional parameter |q| is also given; this parameter is either null
5846 or it points to a node in the token list where a certain magic computation
5847 takes place that will be explained later. (Basically, |q| is non-null when
5848 we are printing the two-line context information at the time of an error
5849 message; |q| marks the place corresponding to where the second line
5852 The generation will stop, and `\.{\char`\ ETC.}' will be printed, if the length
5853 of printing exceeds a given limit~|l|; the length of printing upon entry is
5854 assumed to be a given amount called |null_tally|. (Note that
5855 |show_token_list| sometimes uses itself recursively to print
5856 variable names within a capsule.)
5859 Unusual entries are printed in the form of all-caps tokens
5860 preceded by a space, e.g., `\.{\char`\ BAD}'.
5862 @<Declare the procedure called |show_token_list|@>=
5863 void mp_show_token_list (MP mp, integer p, integer q, integer l,
5864 integer null_tally) ;
5867 void mp_show_token_list (MP mp, integer p, integer q, integer l,
5868 integer null_tally) {
5869 small_number class,c; /* the |char_class| of previous and new tokens */
5870 integer r,v; /* temporary registers */
5871 class=percent_class;
5872 mp->tally=null_tally;
5873 while ( (p!=null) && (mp->tally<l) ) {
5875 @<Do magic computation@>;
5876 @<Display token |p| and set |c| to its class;
5877 but |return| if there are problems@>;
5881 mp_print(mp, " ETC.");
5886 @ @<Display token |p| and set |c| to its class...@>=
5887 c=letter_class; /* the default */
5888 if ( (p<0)||(p>mp->mem_end) ) {
5889 mp_print(mp, " CLOBBERED"); return;
5892 if ( p<mp->hi_mem_min ) {
5893 @<Display two-word token@>;
5896 if ( r>=expr_base ) {
5897 @<Display a parameter token@>;
5901 @<Display a collective subscript@>
5903 mp_print(mp, " IMPOSSIBLE");
5908 if ( (r<0)||(r>mp->max_str_ptr) ) {
5909 mp_print(mp, " NONEXISTENT");
5912 @<Print string |r| as a symbolic token
5913 and set |c| to its class@>;
5919 @ @<Display two-word token@>=
5920 if ( name_type(p)==mp_token ) {
5921 if ( type(p)==mp_known ) {
5922 @<Display a numeric token@>;
5923 } else if ( type(p)!=mp_string_type ) {
5924 mp_print(mp, " BAD");
5927 mp_print_char(mp, '"'); mp_print_str(mp, value(p)); mp_print_char(mp, '"');
5930 } else if ((name_type(p)!=mp_capsule)||(type(p)<mp_vacuous)||(type(p)>mp_independent) ) {
5931 mp_print(mp, " BAD");
5933 mp_print_capsule(mp,p); c=right_paren_class;
5936 @ @<Display a numeric token@>=
5937 if ( class==digit_class )
5938 mp_print_char(mp, ' ');
5941 if ( class==left_bracket_class )
5942 mp_print_char(mp, ' ');
5943 mp_print_char(mp, '['); mp_print_scaled(mp, v); mp_print_char(mp, ']');
5944 c=right_bracket_class;
5946 mp_print_scaled(mp, v); c=digit_class;
5950 @ Strictly speaking, a genuine token will never have |info(p)=0|.
5951 But we will see later (in the |print_variable_name| routine) that
5952 it is convenient to let |info(p)=0| stand for `\.{[]}'.
5954 @<Display a collective subscript@>=
5956 if ( class==left_bracket_class )
5957 mp_print_char(mp, ' ');
5958 mp_print(mp, "[]"); c=right_bracket_class;
5961 @ @<Display a parameter token@>=
5963 if ( r<suffix_base ) {
5964 mp_print(mp, "(EXPR"); r=r-(expr_base);
5966 } else if ( r<text_base ) {
5967 mp_print(mp, "(SUFFIX"); r=r-(suffix_base);
5970 mp_print(mp, "(TEXT"); r=r-(text_base);
5973 mp_print_int(mp, r); mp_print_char(mp, ')'); c=right_paren_class;
5977 @ @<Print string |r| as a symbolic token...@>=
5979 c=mp->char_class[mp->str_pool[mp->str_start[r]]];
5982 case letter_class:mp_print_char(mp, '.'); break;
5983 case isolated_classes: break;
5984 default: mp_print_char(mp, ' '); break;
5987 mp_print_str(mp, r);
5991 void mp_print_capsule (MP mp, pointer p);
5993 @ @<Declare miscellaneous procedures that were declared |forward|@>=
5994 void mp_print_capsule (MP mp, pointer p) {
5995 mp_print_char(mp, '('); mp_print_exp(mp,p,0); mp_print_char(mp, ')');
5998 @ Macro definitions are kept in \MP's memory in the form of token lists
5999 that have a few extra one-word nodes at the beginning.
6001 The first node contains a reference count that is used to tell when the
6002 list is no longer needed. To emphasize the fact that a reference count is
6003 present, we shall refer to the |info| field of this special node as the
6005 @^reference counts@>
6007 The next node or nodes after the reference count serve to describe the
6008 formal parameters. They consist of zero or more parameter tokens followed
6009 by a code for the type of macro.
6012 /* reference count preceding a macro definition or picture header */
6013 @d add_mac_ref(A) incr(ref_count((A))) /* make a new reference to a macro list */
6014 @d general_macro 0 /* preface to a macro defined with a parameter list */
6015 @d primary_macro 1 /* preface to a macro with a \&{primary} parameter */
6016 @d secondary_macro 2 /* preface to a macro with a \&{secondary} parameter */
6017 @d tertiary_macro 3 /* preface to a macro with a \&{tertiary} parameter */
6018 @d expr_macro 4 /* preface to a macro with an undelimited \&{expr} parameter */
6019 @d of_macro 5 /* preface to a macro with
6020 undelimited `\&{expr} |x| \&{of}~|y|' parameters */
6021 @d suffix_macro 6 /* preface to a macro with an undelimited \&{suffix} parameter */
6022 @d text_macro 7 /* preface to a macro with an undelimited \&{text} parameter */
6025 void mp_delete_mac_ref (MP mp,pointer p) {
6026 /* |p| points to the reference count of a macro list that is
6027 losing one reference */
6028 if ( ref_count(p)==null ) mp_flush_token_list(mp, p);
6029 else decr(ref_count(p));
6032 @ The following subroutine displays a macro, given a pointer to its
6036 @<Declare the procedure called |print_cmd_mod|@>
6037 void mp_show_macro (MP mp, pointer p, integer q, integer l) {
6038 pointer r; /* temporary storage */
6039 p=link(p); /* bypass the reference count */
6040 while ( info(p)>text_macro ){
6041 r=link(p); link(p)=null;
6042 mp_show_token_list(mp, p,null,l,0); link(p)=r; p=r;
6043 if ( l>0 ) l=l-mp->tally; else return;
6044 } /* control printing of `\.{ETC.}' */
6048 case general_macro:mp_print(mp, "->"); break;
6050 case primary_macro: case secondary_macro: case tertiary_macro:
6051 mp_print_char(mp, '<');
6052 mp_print_cmd_mod(mp, param_type,info(p));
6053 mp_print(mp, ">->");
6055 case expr_macro:mp_print(mp, "<expr>->"); break;
6056 case of_macro:mp_print(mp, "<expr>of<primary>->"); break;
6057 case suffix_macro:mp_print(mp, "<suffix>->"); break;
6058 case text_macro:mp_print(mp, "<text>->"); break;
6059 } /* there are no other cases */
6060 mp_show_token_list(mp, link(p),q,l-mp->tally,0);
6063 @* \[15] Data structures for variables.
6064 The variables of \MP\ programs can be simple, like `\.x', or they can
6065 combine the structural properties of arrays and records, like `\.{x20a.b}'.
6066 A \MP\ user assigns a type to a variable like \.{x20a.b} by saying, for
6067 example, `\.{boolean} \.{x[]a.b}'. It's time for us to study how such
6068 things are represented inside of the computer.
6070 Each variable value occupies two consecutive words, either in a two-word
6071 node called a value node, or as a two-word subfield of a larger node. One
6072 of those two words is called the |value| field; it is an integer,
6073 containing either a |scaled| numeric value or the representation of some
6074 other type of quantity. (It might also be subdivided into halfwords, in
6075 which case it is referred to by other names instead of |value|.) The other
6076 word is broken into subfields called |type|, |name_type|, and |link|. The
6077 |type| field is a quarterword that specifies the variable's type, and
6078 |name_type| is a quarterword from which \MP\ can reconstruct the
6079 variable's name (sometimes by using the |link| field as well). Thus, only
6080 1.25 words are actually devoted to the value itself; the other
6081 three-quarters of a word are overhead, but they aren't wasted because they
6082 allow \MP\ to deal with sparse arrays and to provide meaningful diagnostics.
6084 In this section we shall be concerned only with the structural aspects of
6085 variables, not their values. Later parts of the program will change the
6086 |type| and |value| fields, but we shall treat those fields as black boxes
6087 whose contents should not be touched.
6089 However, if the |type| field is |mp_structured|, there is no |value| field,
6090 and the second word is broken into two pointer fields called |attr_head|
6091 and |subscr_head|. Those fields point to additional nodes that
6092 contain structural information, as we shall see.
6094 @d subscr_head_loc(A) (A)+1 /* where |value|, |subscr_head| and |attr_head| are */
6095 @d attr_head(A) info(subscr_head_loc((A))) /* pointer to attribute info */
6096 @d subscr_head(A) link(subscr_head_loc((A))) /* pointer to subscript info */
6097 @d value_node_size 2 /* the number of words in a value node */
6099 @ An attribute node is three words long. Two of these words contain |type|
6100 and |value| fields as described above, and the third word contains
6101 additional information: There is an |attr_loc| field, which contains the
6102 hash address of the token that names this attribute; and there's also a
6103 |parent| field, which points to the value node of |mp_structured| type at the
6104 next higher level (i.e., at the level to which this attribute is
6105 subsidiary). The |name_type| in an attribute node is `|attr|'. The
6106 |link| field points to the next attribute with the same parent; these are
6107 arranged in increasing order, so that |attr_loc(link(p))>attr_loc(p)|. The
6108 final attribute node links to the constant |end_attr|, whose |attr_loc|
6109 field is greater than any legal hash address. The |attr_head| in the
6110 parent points to a node whose |name_type| is |mp_structured_root|; this
6111 node represents the null attribute, i.e., the variable that is relevant
6112 when no attributes are attached to the parent. The |attr_head| node
6113 has the fields of either
6114 a value node, a subscript node, or an attribute node, depending on what
6115 the parent would be if it were not structured; but the subscript and
6116 attribute fields are ignored, so it effectively contains only the data of
6117 a value node. The |link| field in this special node points to an attribute
6118 node whose |attr_loc| field is zero; the latter node represents a collective
6119 subscript `\.{[]}' attached to the parent, and its |link| field points to
6120 the first non-special attribute node (or to |end_attr| if there are none).
6122 A subscript node likewise occupies three words, with |type| and |value| fields
6123 plus extra information; its |name_type| is |subscr|. In this case the
6124 third word is called the |subscript| field, which is a |scaled| integer.
6125 The |link| field points to the subscript node with the next larger
6126 subscript, if any; otherwise the |link| points to the attribute node
6127 for collective subscripts at this level. We have seen that the latter node
6128 contains an upward pointer, so that the parent can be deduced.
6130 The |name_type| in a parent-less value node is |root|, and the |link|
6131 is the hash address of the token that names this value.
6133 In other words, variables have a hierarchical structure that includes
6134 enough threads running around so that the program is able to move easily
6135 between siblings, parents, and children. An example should be helpful:
6136 (The reader is advised to draw a picture while reading the following
6137 description, since that will help to firm up the ideas.)
6138 Suppose that `\.x' and `\.{x.a}' and `\.{x[]b}' and `\.{x5}'
6139 and `\.{x20b}' have been mentioned in a user's program, where
6140 \.{x[]b} has been declared to be of \&{boolean} type. Let |h(x)|, |h(a)|,
6141 and |h(b)| be the hash addresses of \.x, \.a, and~\.b. Then
6142 |eq_type(h(x))=name| and |equiv(h(x))=p|, where |p|~is a two-word value
6143 node with |name_type(p)=root| and |link(p)=h(x)|. We have |type(p)=mp_structured|,
6144 |attr_head(p)=q|, and |subscr_head(p)=r|, where |q| points to a value
6145 node and |r| to a subscript node. (Are you still following this? Use
6146 a pencil to draw a diagram.) The lone variable `\.x' is represented by
6147 |type(q)| and |value(q)|; furthermore
6148 |name_type(q)=mp_structured_root| and |link(q)=q1|, where |q1| points
6149 to an attribute node representing `\.{x[]}'. Thus |name_type(q1)=attr|,
6150 |attr_loc(q1)=collective_subscript=0|, |parent(q1)=p|,
6151 |type(q1)=mp_structured|, |attr_head(q1)=qq|, and |subscr_head(q1)=qq1|;
6152 |qq| is a three-word ``attribute-as-value'' node with |type(qq)=numeric_type|
6153 (assuming that \.{x5} is numeric, because |qq| represents `\.{x[]}'
6154 with no further attributes), |name_type(qq)=structured_root|,
6155 |attr_loc(qq)=0|, |parent(qq)=p|, and
6156 |link(qq)=qq1|. (Now pay attention to the next part.) Node |qq1| is
6157 an attribute node representing `\.{x[][]}', which has never yet
6158 occurred; its |type| field is |undefined|, and its |value| field is
6159 undefined. We have |name_type(qq1)=attr|, |attr_loc(qq1)=collective_subscript|,
6160 |parent(qq1)=q1|, and |link(qq1)=qq2|. Since |qq2| represents
6161 `\.{x[]b}', |type(qq2)=mp_unknown_boolean|; also |attr_loc(qq2)=h(b)|,
6162 |parent(qq2)=q1|, |name_type(qq2)=attr|, |link(qq2)=end_attr|.
6163 (Maybe colored lines will help untangle your picture.)
6164 Node |r| is a subscript node with |type| and |value|
6165 representing `\.{x5}'; |name_type(r)=subscr|, |subscript(r)=5.0|,
6166 and |link(r)=r1| is another subscript node. To complete the picture,
6167 see if you can guess what |link(r1)| is; give up? It's~|q1|.
6168 Furthermore |subscript(r1)=20.0|, |name_type(r1)=subscr|,
6169 |type(r1)=mp_structured|, |attr_head(r1)=qqq|, |subscr_head(r1)=qqq1|,
6170 and we finish things off with three more nodes
6171 |qqq|, |qqq1|, and |qqq2| hung onto~|r1|. (Perhaps you should start again
6172 with a larger sheet of paper.) The value of variable \.{x20b}
6173 appears in node~|qqq2|, as you can well imagine.
6175 If the example in the previous paragraph doesn't make things crystal
6176 clear, a glance at some of the simpler subroutines below will reveal how
6177 things work out in practice.
6179 The only really unusual thing about these conventions is the use of
6180 collective subscript attributes. The idea is to avoid repeating a lot of
6181 type information when many elements of an array are identical macros
6182 (for which distinct values need not be stored) or when they don't have
6183 all of the possible attributes. Branches of the structure below collective
6184 subscript attributes do not carry actual values except for macro identifiers;
6185 branches of the structure below subscript nodes do not carry significant
6186 information in their collective subscript attributes.
6188 @d attr_loc_loc(A) ((A)+2) /* where the |attr_loc| and |parent| fields are */
6189 @d attr_loc(A) info(attr_loc_loc((A))) /* hash address of this attribute */
6190 @d parent(A) link(attr_loc_loc((A))) /* pointer to |mp_structured| variable */
6191 @d subscript_loc(A) ((A)+2) /* where the |subscript| field lives */
6192 @d subscript(A) mp->mem[subscript_loc((A))].sc /* subscript of this variable */
6193 @d attr_node_size 3 /* the number of words in an attribute node */
6194 @d subscr_node_size 3 /* the number of words in a subscript node */
6195 @d collective_subscript 0 /* code for the attribute `\.{[]}' */
6197 @<Initialize table...@>=
6198 attr_loc(end_attr)=hash_end+1; parent(end_attr)=null;
6200 @ Variables of type \&{pair} will have values that point to four-word
6201 nodes containing two numeric values. The first of these values has
6202 |name_type=mp_x_part_sector| and the second has |name_type=mp_y_part_sector|;
6203 the |link| in the first points back to the node whose |value| points
6204 to this four-word node.
6206 Variables of type \&{transform} are similar, but in this case their
6207 |value| points to a 12-word node containing six values, identified by
6208 |x_part_sector|, |y_part_sector|, |mp_xx_part_sector|, |mp_xy_part_sector|,
6209 |mp_yx_part_sector|, and |mp_yy_part_sector|.
6210 Finally, variables of type \&{color} have 3~values in 6~words
6211 identified by |mp_red_part_sector|, |mp_green_part_sector|, and |mp_blue_part_sector|.
6213 When an entire structured variable is saved, the |root| indication
6214 is temporarily replaced by |saved_root|.
6216 Some variables have no name; they just are used for temporary storage
6217 while expressions are being evaluated. We call them {\sl capsules}.
6219 @d x_part_loc(A) (A) /* where the \&{xpart} is found in a pair or transform node */
6220 @d y_part_loc(A) ((A)+2) /* where the \&{ypart} is found in a pair or transform node */
6221 @d xx_part_loc(A) ((A)+4) /* where the \&{xxpart} is found in a transform node */
6222 @d xy_part_loc(A) ((A)+6) /* where the \&{xypart} is found in a transform node */
6223 @d yx_part_loc(A) ((A)+8) /* where the \&{yxpart} is found in a transform node */
6224 @d yy_part_loc(A) ((A)+10) /* where the \&{yypart} is found in a transform node */
6225 @d red_part_loc(A) (A) /* where the \&{redpart} is found in a color node */
6226 @d green_part_loc(A) ((A)+2) /* where the \&{greenpart} is found in a color node */
6227 @d blue_part_loc(A) ((A)+4) /* where the \&{bluepart} is found in a color node */
6228 @d cyan_part_loc(A) (A) /* where the \&{cyanpart} is found in a color node */
6229 @d magenta_part_loc(A) ((A)+2) /* where the \&{magentapart} is found in a color node */
6230 @d yellow_part_loc(A) ((A)+4) /* where the \&{yellowpart} is found in a color node */
6231 @d black_part_loc(A) ((A)+6) /* where the \&{blackpart} is found in a color node */
6232 @d grey_part_loc(A) (A) /* where the \&{greypart} is found in a color node */
6234 @d pair_node_size 4 /* the number of words in a pair node */
6235 @d transform_node_size 12 /* the number of words in a transform node */
6236 @d color_node_size 6 /* the number of words in a color node */
6237 @d cmykcolor_node_size 8 /* the number of words in a color node */
6240 small_number big_node_size[mp_pair_type+1];
6241 small_number sector0[mp_pair_type+1];
6242 small_number sector_offset[mp_black_part_sector+1];
6244 @ The |sector0| array gives for each big node type, |name_type| values
6245 for its first subfield; the |sector_offset| array gives for each
6246 |name_type| value, the offset from the first subfield in words;
6247 and the |big_node_size| array gives the size in words for each type of
6251 mp->big_node_size[mp_transform_type]=transform_node_size;
6252 mp->big_node_size[mp_pair_type]=pair_node_size;
6253 mp->big_node_size[mp_color_type]=color_node_size;
6254 mp->big_node_size[mp_cmykcolor_type]=cmykcolor_node_size;
6255 mp->sector0[mp_transform_type]=mp_x_part_sector;
6256 mp->sector0[mp_pair_type]=mp_x_part_sector;
6257 mp->sector0[mp_color_type]=mp_red_part_sector;
6258 mp->sector0[mp_cmykcolor_type]=mp_cyan_part_sector;
6259 for (k=mp_x_part_sector;k<= mp_yy_part_sector;k++ ) {
6260 mp->sector_offset[k]=2*(k-mp_x_part_sector);
6262 for (k=mp_red_part_sector;k<= mp_blue_part_sector ; k++) {
6263 mp->sector_offset[k]=2*(k-mp_red_part_sector);
6265 for (k=mp_cyan_part_sector;k<= mp_black_part_sector;k++ ) {
6266 mp->sector_offset[k]=2*(k-mp_cyan_part_sector);
6269 @ If |type(p)=mp_pair_type| or |mp_transform_type| and if |value(p)=null|, the
6270 procedure call |init_big_node(p)| will allocate a pair or transform node
6271 for~|p|. The individual parts of such nodes are initially of type
6275 void mp_init_big_node (MP mp,pointer p) {
6276 pointer q; /* the new node */
6277 small_number s; /* its size */
6278 s=mp->big_node_size[type(p)]; q=mp_get_node(mp, s);
6281 @<Make variable |q+s| newly independent@>;
6282 name_type(q+s)=halfp(s)+mp->sector0[type(p)];
6285 link(q)=p; value(p)=q;
6288 @ The |id_transform| function creates a capsule for the
6289 identity transformation.
6292 pointer mp_id_transform (MP mp) {
6293 pointer p,q,r; /* list manipulation registers */
6294 p=mp_get_node(mp, value_node_size); type(p)=mp_transform_type;
6295 name_type(p)=mp_capsule; value(p)=null; mp_init_big_node(mp, p); q=value(p);
6296 r=q+transform_node_size;
6299 type(r)=mp_known; value(r)=0;
6301 value(xx_part_loc(q))=unity;
6302 value(yy_part_loc(q))=unity;
6306 @ Tokens are of type |tag_token| when they first appear, but they point
6307 to |null| until they are first used as the root of a variable.
6308 The following subroutine establishes the root node on such grand occasions.
6311 void mp_new_root (MP mp,pointer x) {
6312 pointer p; /* the new node */
6313 p=mp_get_node(mp, value_node_size); type(p)=undefined; name_type(p)=mp_root;
6314 link(p)=x; equiv(x)=p;
6317 @ These conventions for variable representation are illustrated by the
6318 |print_variable_name| routine, which displays the full name of a
6319 variable given only a pointer to its two-word value packet.
6322 void mp_print_variable_name (MP mp, pointer p);
6325 void mp_print_variable_name (MP mp, pointer p) {
6326 pointer q; /* a token list that will name the variable's suffix */
6327 pointer r; /* temporary for token list creation */
6328 while ( name_type(p)>=mp_x_part_sector ) {
6329 @<Preface the output with a part specifier; |return| in the
6330 case of a capsule@>;
6333 while ( name_type(p)>mp_saved_root ) {
6334 @<Ascend one level, pushing a token onto list |q|
6335 and replacing |p| by its parent@>;
6337 r=mp_get_avail(mp); info(r)=link(p); link(r)=q;
6338 if ( name_type(p)==mp_saved_root ) mp_print(mp, "(SAVED)");
6340 mp_show_token_list(mp, r,null,el_gordo,mp->tally);
6341 mp_flush_token_list(mp, r);
6344 @ @<Ascend one level, pushing a token onto list |q|...@>=
6346 if ( name_type(p)==mp_subscr ) {
6347 r=mp_new_num_tok(mp, subscript(p));
6350 } while (name_type(p)!=mp_attr);
6351 } else if ( name_type(p)==mp_structured_root ) {
6352 p=link(p); goto FOUND;
6354 if ( name_type(p)!=mp_attr ) mp_confusion(mp, "var");
6355 @:this can't happen var}{\quad var@>
6356 r=mp_get_avail(mp); info(r)=attr_loc(p);
6363 @ @<Preface the output with a part specifier...@>=
6364 { switch (name_type(p)) {
6365 case mp_x_part_sector: mp_print_char(mp, 'x'); break;
6366 case mp_y_part_sector: mp_print_char(mp, 'y'); break;
6367 case mp_xx_part_sector: mp_print(mp, "xx"); break;
6368 case mp_xy_part_sector: mp_print(mp, "xy"); break;
6369 case mp_yx_part_sector: mp_print(mp, "yx"); break;
6370 case mp_yy_part_sector: mp_print(mp, "yy"); break;
6371 case mp_red_part_sector: mp_print(mp, "red"); break;
6372 case mp_green_part_sector: mp_print(mp, "green"); break;
6373 case mp_blue_part_sector: mp_print(mp, "blue"); break;
6374 case mp_cyan_part_sector: mp_print(mp, "cyan"); break;
6375 case mp_magenta_part_sector: mp_print(mp, "magenta"); break;
6376 case mp_yellow_part_sector: mp_print(mp, "yellow"); break;
6377 case mp_black_part_sector: mp_print(mp, "black"); break;
6378 case mp_grey_part_sector: mp_print(mp, "grey"); break;
6380 mp_print(mp, "%CAPSULE"); mp_print_int(mp, p-null); return;
6383 } /* there are no other cases */
6384 mp_print(mp, "part ");
6385 p=link(p-mp->sector_offset[name_type(p)]);
6388 @ The |interesting| function returns |true| if a given variable is not
6389 in a capsule, or if the user wants to trace capsules.
6392 boolean mp_interesting (MP mp,pointer p) {
6393 small_number t; /* a |name_type| */
6394 if ( mp->internal[mp_tracing_capsules]>0 ) {
6398 if ( t>=mp_x_part_sector ) if ( t!=mp_capsule )
6399 t=name_type(link(p-mp->sector_offset[t]));
6400 return (t!=mp_capsule);
6404 @ Now here is a subroutine that converts an unstructured type into an
6405 equivalent structured type, by inserting a |mp_structured| node that is
6406 capable of growing. This operation is done only when |name_type(p)=root|,
6407 |subscr|, or |attr|.
6409 The procedure returns a pointer to the new node that has taken node~|p|'s
6410 place in the structure. Node~|p| itself does not move, nor are its
6411 |value| or |type| fields changed in any way.
6414 pointer mp_new_structure (MP mp,pointer p) {
6415 pointer q,r=0; /* list manipulation registers */
6416 switch (name_type(p)) {
6418 q=link(p); r=mp_get_node(mp, value_node_size); equiv(q)=r;
6421 @<Link a new subscript node |r| in place of node |p|@>;
6424 @<Link a new attribute node |r| in place of node |p|@>;
6427 mp_confusion(mp, "struct");
6428 @:this can't happen struct}{\quad struct@>
6431 link(r)=link(p); type(r)=mp_structured; name_type(r)=name_type(p);
6432 attr_head(r)=p; name_type(p)=mp_structured_root;
6433 q=mp_get_node(mp, attr_node_size); link(p)=q; subscr_head(r)=q;
6434 parent(q)=r; type(q)=undefined; name_type(q)=mp_attr; link(q)=end_attr;
6435 attr_loc(q)=collective_subscript;
6439 @ @<Link a new subscript node |r| in place of node |p|@>=
6444 } while (name_type(q)!=mp_attr);
6445 q=parent(q); r=subscr_head_loc(q); /* |link(r)=subscr_head(q)| */
6449 r=mp_get_node(mp, subscr_node_size);
6450 link(q)=r; subscript(r)=subscript(p);
6453 @ If the attribute is |collective_subscript|, there are two pointers to
6454 node~|p|, so we must change both of them.
6456 @<Link a new attribute node |r| in place of node |p|@>=
6458 q=parent(p); r=attr_head(q);
6462 r=mp_get_node(mp, attr_node_size); link(q)=r;
6463 mp->mem[attr_loc_loc(r)]=mp->mem[attr_loc_loc(p)]; /* copy |attr_loc| and |parent| */
6464 if ( attr_loc(p)==collective_subscript ) {
6465 q=subscr_head_loc(parent(p));
6466 while ( link(q)!=p ) q=link(q);
6471 @ The |find_variable| routine is given a pointer~|t| to a nonempty token
6472 list of suffixes; it returns a pointer to the corresponding two-word
6473 value. For example, if |t| points to token \.x followed by a numeric
6474 token containing the value~7, |find_variable| finds where the value of
6475 \.{x7} is stored in memory. This may seem a simple task, and it
6476 usually is, except when \.{x7} has never been referenced before.
6477 Indeed, \.x may never have even been subscripted before; complexities
6478 arise with respect to updating the collective subscript information.
6480 If a macro type is detected anywhere along path~|t|, or if the first
6481 item on |t| isn't a |tag_token|, the value |null| is returned.
6482 Otherwise |p| will be a non-null pointer to a node such that
6483 |undefined<type(p)<mp_structured|.
6485 @d abort_find { return null; }
6488 pointer mp_find_variable (MP mp,pointer t) {
6489 pointer p,q,r,s; /* nodes in the ``value'' line */
6490 pointer pp,qq,rr,ss; /* nodes in the ``collective'' line */
6491 integer n; /* subscript or attribute */
6492 memory_word save_word; /* temporary storage for a word of |mem| */
6494 p=info(t); t=link(t);
6495 if ( (eq_type(p) % outer_tag) != tag_token ) abort_find;
6496 if ( equiv(p)==null ) mp_new_root(mp, p);
6499 @<Make sure that both nodes |p| and |pp| are of |mp_structured| type@>;
6500 if ( t<mp->hi_mem_min ) {
6501 @<Descend one level for the subscript |value(t)|@>
6503 @<Descend one level for the attribute |info(t)|@>;
6507 if ( type(pp)>=mp_structured ) {
6508 if ( type(pp)==mp_structured ) pp=attr_head(pp); else abort_find;
6510 if ( type(p)==mp_structured ) p=attr_head(p);
6511 if ( type(p)==undefined ) {
6512 if ( type(pp)==undefined ) { type(pp)=mp_numeric_type; value(pp)=null; };
6513 type(p)=type(pp); value(p)=null;
6518 @ Although |pp| and |p| begin together, they diverge when a subscript occurs;
6519 |pp|~stays in the collective line while |p|~goes through actual subscript
6522 @<Make sure that both nodes |p| and |pp|...@>=
6523 if ( type(pp)!=mp_structured ) {
6524 if ( type(pp)>mp_structured ) abort_find;
6525 ss=mp_new_structure(mp, pp);
6528 }; /* now |type(pp)=mp_structured| */
6529 if ( type(p)!=mp_structured ) /* it cannot be |>mp_structured| */
6530 p=mp_new_structure(mp, p) /* now |type(p)=mp_structured| */
6532 @ We want this part of the program to be reasonably fast, in case there are
6534 lots of subscripts at the same level of the data structure. Therefore
6535 we store an ``infinite'' value in the word that appears at the end of the
6536 subscript list, even though that word isn't part of a subscript node.
6538 @<Descend one level for the subscript |value(t)|@>=
6541 pp=link(attr_head(pp)); /* now |attr_loc(pp)=collective_subscript| */
6542 q=link(attr_head(p)); save_word=mp->mem[subscript_loc(q)];
6543 subscript(q)=el_gordo; s=subscr_head_loc(p); /* |link(s)=subscr_head(p)| */
6546 } while (n>subscript(s));
6547 if ( n==subscript(s) ) {
6550 p=mp_get_node(mp, subscr_node_size); link(r)=p; link(p)=s;
6551 subscript(p)=n; name_type(p)=mp_subscr; type(p)=undefined;
6553 mp->mem[subscript_loc(q)]=save_word;
6556 @ @<Descend one level for the attribute |info(t)|@>=
6562 } while (n>attr_loc(ss));
6563 if ( n<attr_loc(ss) ) {
6564 qq=mp_get_node(mp, attr_node_size); link(rr)=qq; link(qq)=ss;
6565 attr_loc(qq)=n; name_type(qq)=mp_attr; type(qq)=undefined;
6566 parent(qq)=pp; ss=qq;
6571 pp=ss; s=attr_head(p);
6574 } while (n>attr_loc(s));
6575 if ( n==attr_loc(s) ) {
6578 q=mp_get_node(mp, attr_node_size); link(r)=q; link(q)=s;
6579 attr_loc(q)=n; name_type(q)=mp_attr; type(q)=undefined;
6585 @ Variables lose their former values when they appear in a type declaration,
6586 or when they are defined to be macros or \&{let} equal to something else.
6587 A subroutine will be defined later that recycles the storage associated
6588 with any particular |type| or |value|; our goal now is to study a higher
6589 level process called |flush_variable|, which selectively frees parts of a
6592 This routine has some complexity because of examples such as
6593 `\hbox{\tt numeric x[]a[]b}'
6594 which recycles all variables of the form \.{x[i]a[j]b} (and no others), while
6595 `\hbox{\tt vardef x[]a[]=...}'
6596 discards all variables of the form \.{x[i]a[j]} followed by an arbitrary
6597 suffix, except for the collective node \.{x[]a[]} itself. The obvious way
6598 to handle such examples is to use recursion; so that's what we~do.
6601 Parameter |p| points to the root information of the variable;
6602 parameter |t| points to a list of one-word nodes that represent
6603 suffixes, with |info=collective_subscript| for subscripts.
6606 @<Declare subroutines for printing expressions@>
6607 @<Declare basic dependency-list subroutines@>
6608 @<Declare the recycling subroutines@>
6609 void mp_flush_cur_exp (MP mp,scaled v) ;
6610 @<Declare the procedure called |flush_below_variable|@>
6613 void mp_flush_variable (MP mp,pointer p, pointer t, boolean discard_suffixes) {
6614 pointer q,r; /* list manipulation */
6615 halfword n; /* attribute to match */
6617 if ( type(p)!=mp_structured ) return;
6618 n=info(t); t=link(t);
6619 if ( n==collective_subscript ) {
6620 r=subscr_head_loc(p); q=link(r); /* |q=subscr_head(p)| */
6621 while ( name_type(q)==mp_subscr ){
6622 mp_flush_variable(mp, q,t,discard_suffixes);
6624 if ( type(q)==mp_structured ) r=q;
6625 else { link(r)=link(q); mp_free_node(mp, q,subscr_node_size); }
6635 } while (attr_loc(p)<n);
6636 if ( attr_loc(p)!=n ) return;
6638 if ( discard_suffixes ) {
6639 mp_flush_below_variable(mp, p);
6641 if ( type(p)==mp_structured ) p=attr_head(p);
6642 mp_recycle_value(mp, p);
6646 @ The next procedure is simpler; it wipes out everything but |p| itself,
6647 which becomes undefined.
6649 @<Declare the procedure called |flush_below_variable|@>=
6650 void mp_flush_below_variable (MP mp, pointer p);
6653 void mp_flush_below_variable (MP mp,pointer p) {
6654 pointer q,r; /* list manipulation registers */
6655 if ( type(p)!=mp_structured ) {
6656 mp_recycle_value(mp, p); /* this sets |type(p)=undefined| */
6659 while ( name_type(q)==mp_subscr ) {
6660 mp_flush_below_variable(mp, q); r=q; q=link(q);
6661 mp_free_node(mp, r,subscr_node_size);
6663 r=attr_head(p); q=link(r); mp_recycle_value(mp, r);
6664 if ( name_type(p)<=mp_saved_root ) mp_free_node(mp, r,value_node_size);
6665 else mp_free_node(mp, r,subscr_node_size);
6666 /* we assume that |subscr_node_size=attr_node_size| */
6668 mp_flush_below_variable(mp, q); r=q; q=link(q); mp_free_node(mp, r,attr_node_size);
6669 } while (q!=end_attr);
6674 @ Just before assigning a new value to a variable, we will recycle the
6675 old value and make the old value undefined. The |und_type| routine
6676 determines what type of undefined value should be given, based on
6677 the current type before recycling.
6680 small_number mp_und_type (MP mp,pointer p) {
6682 case undefined: case mp_vacuous:
6684 case mp_boolean_type: case mp_unknown_boolean:
6685 return mp_unknown_boolean;
6686 case mp_string_type: case mp_unknown_string:
6687 return mp_unknown_string;
6688 case mp_pen_type: case mp_unknown_pen:
6689 return mp_unknown_pen;
6690 case mp_path_type: case mp_unknown_path:
6691 return mp_unknown_path;
6692 case mp_picture_type: case mp_unknown_picture:
6693 return mp_unknown_picture;
6694 case mp_transform_type: case mp_color_type: case mp_cmykcolor_type:
6695 case mp_pair_type: case mp_numeric_type:
6697 case mp_known: case mp_dependent: case mp_proto_dependent: case mp_independent:
6698 return mp_numeric_type;
6699 } /* there are no other cases */
6703 @ The |clear_symbol| routine is used when we want to redefine the equivalent
6704 of a symbolic token. It must remove any variable structure or macro
6705 definition that is currently attached to that symbol. If the |saving|
6706 parameter is true, a subsidiary structure is saved instead of destroyed.
6709 void mp_clear_symbol (MP mp,pointer p, boolean saving) {
6710 pointer q; /* |equiv(p)| */
6712 switch (eq_type(p) % outer_tag) {
6714 case secondary_primary_macro:
6715 case tertiary_secondary_macro:
6716 case expression_tertiary_macro:
6717 if ( ! saving ) mp_delete_mac_ref(mp, q);
6722 name_type(q)=mp_saved_root;
6724 mp_flush_below_variable(mp, q);
6725 mp_free_node(mp,q,value_node_size);
6732 mp->eqtb[p]=mp->eqtb[frozen_undefined];
6735 @* \[16] Saving and restoring equivalents.
6736 The nested structure given by \&{begingroup} and \&{endgroup}
6737 allows |eqtb| entries to be saved and restored, so that temporary changes
6738 can be made without difficulty. When the user requests a current value to
6739 be saved, \MP\ puts that value into its ``save stack.'' An appearance of
6740 \&{endgroup} ultimately causes the old values to be removed from the save
6741 stack and put back in their former places.
6743 The save stack is a linked list containing three kinds of entries,
6744 distinguished by their |info| fields. If |p| points to a saved item,
6748 |info(p)=0| stands for a group boundary; each \&{begingroup} contributes
6749 such an item to the save stack and each \&{endgroup} cuts back the stack
6750 until the most recent such entry has been removed.
6753 |info(p)=q|, where |1<=q<=hash_end|, means that |mem[p+1]| holds the former
6754 contents of |eqtb[q]|. Such save stack entries are generated by \&{save}
6758 |info(p)=hash_end+q|, where |q>0|, means that |value(p)| is a |scaled|
6759 integer to be restored to internal parameter number~|q|. Such entries
6760 are generated by \&{interim} commands.
6763 The global variable |save_ptr| points to the top item on the save stack.
6765 @d save_node_size 2 /* number of words per non-boundary save-stack node */
6766 @d saved_equiv(A) mp->mem[(A)+1].hh /* where an |eqtb| entry gets saved */
6767 @d save_boundary_item(A) { (A)=mp_get_avail(mp); info((A))=0;
6768 link((A))=mp->save_ptr; mp->save_ptr=(A);
6772 pointer save_ptr; /* the most recently saved item */
6774 @ @<Set init...@>=mp->save_ptr=null;
6776 @ The |save_variable| routine is given a hash address |q|; it salts this
6777 address in the save stack, together with its current equivalent,
6778 then makes token~|q| behave as though it were brand new.
6780 Nothing is stacked when |save_ptr=null|, however; there's no way to remove
6781 things from the stack when the program is not inside a group, so there's
6782 no point in wasting the space.
6784 @c void mp_save_variable (MP mp,pointer q) {
6785 pointer p; /* temporary register */
6786 if ( mp->save_ptr!=null ){
6787 p=mp_get_node(mp, save_node_size); info(p)=q; link(p)=mp->save_ptr;
6788 saved_equiv(p)=mp->eqtb[q]; mp->save_ptr=p;
6790 mp_clear_symbol(mp, q,(mp->save_ptr!=null));
6793 @ Similarly, |save_internal| is given the location |q| of an internal
6794 quantity like |mp_tracing_pens|. It creates a save stack entry of the
6797 @c void mp_save_internal (MP mp,halfword q) {
6798 pointer p; /* new item for the save stack */
6799 if ( mp->save_ptr!=null ){
6800 p=mp_get_node(mp, save_node_size); info(p)=hash_end+q;
6801 link(p)=mp->save_ptr; value(p)=mp->internal[q]; mp->save_ptr=p;
6805 @ At the end of a group, the |unsave| routine restores all of the saved
6806 equivalents in reverse order. This routine will be called only when there
6807 is at least one boundary item on the save stack.
6810 void mp_unsave (MP mp) {
6811 pointer q; /* index to saved item */
6812 pointer p; /* temporary register */
6813 while ( info(mp->save_ptr)!=0 ) {
6814 q=info(mp->save_ptr);
6816 if ( mp->internal[mp_tracing_restores]>0 ) {
6817 mp_begin_diagnostic(mp); mp_print_nl(mp, "{restoring ");
6818 mp_print(mp, mp->int_name[q-(hash_end)]); mp_print_char(mp, '=');
6819 mp_print_scaled(mp, value(mp->save_ptr)); mp_print_char(mp, '}');
6820 mp_end_diagnostic(mp, false);
6822 mp->internal[q-(hash_end)]=value(mp->save_ptr);
6824 if ( mp->internal[mp_tracing_restores]>0 ) {
6825 mp_begin_diagnostic(mp); mp_print_nl(mp, "{restoring ");
6826 mp_print_text(q); mp_print_char(mp, '}');
6827 mp_end_diagnostic(mp, false);
6829 mp_clear_symbol(mp, q,false);
6830 mp->eqtb[q]=saved_equiv(mp->save_ptr);
6831 if ( eq_type(q) % outer_tag==tag_token ) {
6833 if ( p!=null ) name_type(p)=mp_root;
6836 p=link(mp->save_ptr);
6837 mp_free_node(mp, mp->save_ptr,save_node_size); mp->save_ptr=p;
6839 p=link(mp->save_ptr); free_avail(mp->save_ptr); mp->save_ptr=p;
6842 @* \[17] Data structures for paths.
6843 When a \MP\ user specifies a path, \MP\ will create a list of knots
6844 and control points for the associated cubic spline curves. If the
6845 knots are $z_0$, $z_1$, \dots, $z_n$, there are control points
6846 $z_k^+$ and $z_{k+1}^-$ such that the cubic splines between knots
6847 $z_k$ and $z_{k+1}$ are defined by B\'ezier's formula
6848 @:Bezier}{B\'ezier, Pierre Etienne@>
6849 $$\eqalign{z(t)&=B(z_k,z_k^+,z_{k+1}^-,z_{k+1};t)\cr
6850 &=(1-t)^3z_k+3(1-t)^2tz_k^++3(1-t)t^2z_{k+1}^-+t^3z_{k+1}\cr}$$
6853 There is a 8-word node for each knot $z_k$, containing one word of
6854 control information and six words for the |x| and |y| coordinates of
6855 $z_k^-$ and $z_k$ and~$z_k^+$. The control information appears in the
6856 |left_type| and |right_type| fields, which each occupy a quarter of
6857 the first word in the node; they specify properties of the curve as it
6858 enters and leaves the knot. There's also a halfword |link| field,
6859 which points to the following knot, and a final supplementary word (of
6860 which only a quarter is used).
6862 If the path is a closed contour, knots 0 and |n| are identical;
6863 i.e., the |link| in knot |n-1| points to knot~0. But if the path
6864 is not closed, the |left_type| of knot~0 and the |right_type| of knot~|n|
6865 are equal to |endpoint|. In the latter case the |link| in knot~|n| points
6866 to knot~0, and the control points $z_0^-$ and $z_n^+$ are not used.
6868 @d left_type(A) mp->mem[(A)].hh.b0 /* characterizes the path entering this knot */
6869 @d right_type(A) mp->mem[(A)].hh.b1 /* characterizes the path leaving this knot */
6870 @d x_coord(A) mp->mem[(A)+1].sc /* the |x| coordinate of this knot */
6871 @d y_coord(A) mp->mem[(A)+2].sc /* the |y| coordinate of this knot */
6872 @d left_x(A) mp->mem[(A)+3].sc /* the |x| coordinate of previous control point */
6873 @d left_y(A) mp->mem[(A)+4].sc /* the |y| coordinate of previous control point */
6874 @d right_x(A) mp->mem[(A)+5].sc /* the |x| coordinate of next control point */
6875 @d right_y(A) mp->mem[(A)+6].sc /* the |y| coordinate of next control point */
6876 @d x_loc(A) ((A)+1) /* where the |x| coordinate is stored in a knot */
6877 @d y_loc(A) ((A)+2) /* where the |y| coordinate is stored in a knot */
6878 @d knot_coord(A) mp->mem[(A)].sc /* |x| or |y| coordinate given |x_loc| or |y_loc| */
6879 @d left_coord(A) mp->mem[(A)+2].sc
6880 /* coordinate of previous control point given |x_loc| or |y_loc| */
6881 @d right_coord(A) mp->mem[(A)+4].sc
6882 /* coordinate of next control point given |x_loc| or |y_loc| */
6883 @d knot_node_size 8 /* number of words in a knot node */
6887 mp_endpoint=0, /* |left_type| at path beginning and |right_type| at path end */
6888 mp_explicit, /* |left_type| or |right_type| when control points are known */
6889 mp_given, /* |left_type| or |right_type| when a direction is given */
6890 mp_curl, /* |left_type| or |right_type| when a curl is desired */
6891 mp_open, /* |left_type| or |right_type| when \MP\ should choose the direction */
6895 @ Before the B\'ezier control points have been calculated, the memory
6896 space they will ultimately occupy is taken up by information that can be
6897 used to compute them. There are four cases:
6900 \textindent{$\bullet$} If |right_type=mp_open|, the curve should leave
6901 the knot in the same direction it entered; \MP\ will figure out a
6905 \textindent{$\bullet$} If |right_type=mp_curl|, the curve should leave the
6906 knot in a direction depending on the angle at which it enters the next
6907 knot and on the curl parameter stored in |right_curl|.
6910 \textindent{$\bullet$} If |right_type=mp_given|, the curve should leave the
6911 knot in a nonzero direction stored as an |angle| in |right_given|.
6914 \textindent{$\bullet$} If |right_type=mp_explicit|, the B\'ezier control
6915 point for leaving this knot has already been computed; it is in the
6916 |right_x| and |right_y| fields.
6919 The rules for |left_type| are similar, but they refer to the curve entering
6920 the knot, and to \\{left} fields instead of \\{right} fields.
6922 Non-|explicit| control points will be chosen based on ``tension'' parameters
6923 in the |left_tension| and |right_tension| fields. The
6924 `\&{atleast}' option is represented by negative tension values.
6925 @:at_least_}{\&{atleast} primitive@>
6927 For example, the \MP\ path specification
6928 $$\.{z0..z1..tension atleast 1..\{curl 2\}z2..z3\{-1,-2\}..tension
6930 where \.p is the path `\.{z4..controls z45 and z54..z5}', will be represented
6932 \def\lodash{\hbox to 1.1em{\thinspace\hrulefill\thinspace}}
6933 $$\vbox{\halign{#\hfil&&\qquad#\hfil\cr
6934 |left_type|&\\{left} info&|x_coord,y_coord|&|right_type|&\\{right} info\cr
6936 |endpoint|&\lodash$,\,$\lodash&$x_0,y_0$&|curl|&$1.0,1.0$\cr
6937 |open|&\lodash$,1.0$&$x_1,y_1$&|open|&\lodash$,-1.0$\cr
6938 |curl|&$2.0,-1.0$&$x_2,y_2$&|curl|&$2.0,1.0$\cr
6939 |given|&$d,1.0$&$x_3,y_3$&|given|&$d,3.0$\cr
6940 |open|&\lodash$,4.0$&$x_4,y_4$&|explicit|&$x_{45},y_{45}$\cr
6941 |explicit|&$x_{54},y_{54}$&$x_5,y_5$&|endpoint|&\lodash$,\,$\lodash\cr}}$$
6942 Here |d| is the |angle| obtained by calling |n_arg(-unity,-two)|.
6943 Of course, this example is more complicated than anything a normal user
6946 These types must satisfy certain restrictions because of the form of \MP's
6948 (i)~|open| type never appears in the same node together with |endpoint|,
6950 (ii)~The |right_type| of a node is |explicit| if and only if the
6951 |left_type| of the following node is |explicit|.
6952 (iii)~|endpoint| types occur only at the ends, as mentioned above.
6954 @d left_curl left_x /* curl information when entering this knot */
6955 @d left_given left_x /* given direction when entering this knot */
6956 @d left_tension left_y /* tension information when entering this knot */
6957 @d right_curl right_x /* curl information when leaving this knot */
6958 @d right_given right_x /* given direction when leaving this knot */
6959 @d right_tension right_y /* tension information when leaving this knot */
6961 @ Knots can be user-supplied, or they can be created by program code,
6962 like the |split_cubic| function, or |copy_path|. The distinction is
6963 needed for the cleanup routine that runs after |split_cubic|, because
6964 it should only delete knots it has previously inserted, and never
6965 anything that was user-supplied. In order to be able to differentiate
6966 one knot from another, we will set |originator(p):=mp_metapost_user| when
6967 it appeared in the actual metapost program, and
6968 |originator(p):=mp_program_code| in all other cases.
6970 @d originator(A) mp->mem[(A)+7].hh.b0 /* the creator of this knot */
6974 mp_program_code=0, /* not created by a user */
6975 mp_metapost_user /* created by a user */
6978 @ Here is a routine that prints a given knot list
6979 in symbolic form. It illustrates the conventions discussed above,
6980 and checks for anomalies that might arise while \MP\ is being debugged.
6982 @<Declare subroutines for printing expressions@>=
6983 void mp_pr_path (MP mp,pointer h);
6986 void mp_pr_path (MP mp,pointer h) {
6987 pointer p,q; /* for list traversal */
6991 if ( (p==null)||(q==null) ) {
6992 mp_print_nl(mp, "???"); return; /* this won't happen */
6995 @<Print information for adjacent knots |p| and |q|@>;
6998 if ( (p!=h)||(left_type(h)!=mp_endpoint) ) {
6999 @<Print two dots, followed by |given| or |curl| if present@>;
7002 if ( left_type(h)!=mp_endpoint )
7003 mp_print(mp, "cycle");
7006 @ @<Print information for adjacent knots...@>=
7007 mp_print_two(mp, x_coord(p),y_coord(p));
7008 switch (right_type(p)) {
7010 if ( left_type(p)==mp_open ) mp_print(mp, "{open?}"); /* can't happen */
7012 if ( (left_type(q)!=mp_endpoint)||(q!=h) ) q=null; /* force an error */
7016 @<Print control points between |p| and |q|, then |goto done1|@>;
7019 @<Print information for a curve that begins |open|@>;
7023 @<Print information for a curve that begins |curl| or |given|@>;
7026 mp_print(mp, "???"); /* can't happen */
7030 if ( left_type(q)<=mp_explicit ) {
7031 mp_print(mp, "..control?"); /* can't happen */
7033 } else if ( (right_tension(p)!=unity)||(left_tension(q)!=unity) ) {
7034 @<Print tension between |p| and |q|@>;
7037 @ Since |n_sin_cos| produces |fraction| results, which we will print as if they
7038 were |scaled|, the magnitude of a |given| direction vector will be~4096.
7040 @<Print two dots...@>=
7042 mp_print_nl(mp, " ..");
7043 if ( left_type(p)==mp_given ) {
7044 mp_n_sin_cos(mp, left_given(p)); mp_print_char(mp, '{');
7045 mp_print_scaled(mp, mp->n_cos); mp_print_char(mp, ',');
7046 mp_print_scaled(mp, mp->n_sin); mp_print_char(mp, '}');
7047 } else if ( left_type(p)==mp_curl ){
7048 mp_print(mp, "{curl ");
7049 mp_print_scaled(mp, left_curl(p)); mp_print_char(mp, '}');
7053 @ @<Print tension between |p| and |q|@>=
7055 mp_print(mp, "..tension ");
7056 if ( right_tension(p)<0 ) mp_print(mp, "atleast");
7057 mp_print_scaled(mp, abs(right_tension(p)));
7058 if ( right_tension(p)!=left_tension(q) ){
7059 mp_print(mp, " and ");
7060 if ( left_tension(q)<0 ) mp_print(mp, "atleast");
7061 mp_print_scaled(mp, abs(left_tension(q)));
7065 @ @<Print control points between |p| and |q|, then |goto done1|@>=
7067 mp_print(mp, "..controls ");
7068 mp_print_two(mp, right_x(p),right_y(p));
7069 mp_print(mp, " and ");
7070 if ( left_type(q)!=mp_explicit ) {
7071 mp_print(mp, "??"); /* can't happen */
7074 mp_print_two(mp, left_x(q),left_y(q));
7079 @ @<Print information for a curve that begins |open|@>=
7080 if ( (left_type(p)!=mp_explicit)&&(left_type(p)!=mp_open) ) {
7081 mp_print(mp, "{open?}"); /* can't happen */
7085 @ A curl of 1 is shown explicitly, so that the user sees clearly that
7086 \MP's default curl is present.
7088 @<Print information for a curve that begins |curl|...@>=
7090 if ( left_type(p)==mp_open )
7091 mp_print(mp, "??"); /* can't happen */
7093 if ( right_type(p)==mp_curl ) {
7094 mp_print(mp, "{curl "); mp_print_scaled(mp, right_curl(p));
7096 mp_n_sin_cos(mp, right_given(p)); mp_print_char(mp, '{');
7097 mp_print_scaled(mp, mp->n_cos); mp_print_char(mp, ',');
7098 mp_print_scaled(mp, mp->n_sin);
7100 mp_print_char(mp, '}');
7103 @ It is convenient to have another version of |pr_path| that prints the path
7104 as a diagnostic message.
7106 @<Declare subroutines for printing expressions@>=
7107 void mp_print_path (MP mp,pointer h, const char *s, boolean nuline) {
7108 mp_print_diagnostic(mp, "Path", s, nuline); mp_print_ln(mp);
7111 mp_end_diagnostic(mp, true);
7114 @ If we want to duplicate a knot node, we can say |copy_knot|:
7117 pointer mp_copy_knot (MP mp,pointer p) {
7118 pointer q; /* the copy */
7119 int k; /* runs through the words of a knot node */
7120 q=mp_get_node(mp, knot_node_size);
7121 for (k=0;k<knot_node_size;k++) {
7122 mp->mem[q+k]=mp->mem[p+k];
7124 originator(q)=originator(p);
7128 @ The |copy_path| routine makes a clone of a given path.
7131 pointer mp_copy_path (MP mp, pointer p) {
7132 pointer q,pp,qq; /* for list manipulation */
7133 q=mp_copy_knot(mp, p);
7136 link(qq)=mp_copy_knot(mp, pp);
7145 @ Just before |ship_out|, knot lists are exported for printing.
7147 The |gr_XXXX| macros are defined in |mppsout.h|.
7150 mp_knot *mp_export_knot (MP mp,pointer p) {
7151 mp_knot *q; /* the copy */
7154 q = mp_xmalloc(mp, 1, sizeof (mp_knot));
7155 memset(q,0,sizeof (mp_knot));
7156 gr_left_type(q) = left_type(p);
7157 gr_right_type(q) = right_type(p);
7158 gr_x_coord(q) = x_coord(p);
7159 gr_y_coord(q) = y_coord(p);
7160 gr_left_x(q) = left_x(p);
7161 gr_left_y(q) = left_y(p);
7162 gr_right_x(q) = right_x(p);
7163 gr_right_y(q) = right_y(p);
7164 gr_originator(q) = originator(p);
7168 @ The |export_knot_list| routine therefore also makes a clone
7172 mp_knot *mp_export_knot_list (MP mp, pointer p) {
7173 mp_knot *q, *qq; /* for list manipulation */
7174 pointer pp; /* for list manipulation */
7177 q=mp_export_knot(mp, p);
7180 gr_next_knot(qq)=mp_export_knot(mp, pp);
7181 qq=gr_next_knot(qq);
7189 @ Similarly, there's a way to copy the {\sl reverse\/} of a path. This procedure
7190 returns a pointer to the first node of the copy, if the path is a cycle,
7191 but to the final node of a non-cyclic copy. The global
7192 variable |path_tail| will point to the final node of the original path;
7193 this trick makes it easier to implement `\&{doublepath}'.
7195 All node types are assumed to be |endpoint| or |explicit| only.
7198 pointer mp_htap_ypoc (MP mp,pointer p) {
7199 pointer q,pp,qq,rr; /* for list manipulation */
7200 q=mp_get_node(mp, knot_node_size); /* this will correspond to |p| */
7203 right_type(qq)=left_type(pp); left_type(qq)=right_type(pp);
7204 x_coord(qq)=x_coord(pp); y_coord(qq)=y_coord(pp);
7205 right_x(qq)=left_x(pp); right_y(qq)=left_y(pp);
7206 left_x(qq)=right_x(pp); left_y(qq)=right_y(pp);
7207 originator(qq)=originator(pp);
7208 if ( link(pp)==p ) {
7209 link(q)=qq; mp->path_tail=pp; return q;
7211 rr=mp_get_node(mp, knot_node_size); link(rr)=qq; qq=rr; pp=link(pp);
7216 pointer path_tail; /* the node that links to the beginning of a path */
7218 @ When a cyclic list of knot nodes is no longer needed, it can be recycled by
7219 calling the following subroutine.
7221 @<Declare the recycling subroutines@>=
7222 void mp_toss_knot_list (MP mp,pointer p) ;
7225 void mp_toss_knot_list (MP mp,pointer p) {
7226 pointer q; /* the node being freed */
7227 pointer r; /* the next node */
7231 mp_free_node(mp, q,knot_node_size); q=r;
7235 @* \[18] Choosing control points.
7236 Now we must actually delve into one of \MP's more difficult routines,
7237 the |make_choices| procedure that chooses angles and control points for
7238 the splines of a curve when the user has not specified them explicitly.
7239 The parameter to |make_choices| points to a list of knots and
7240 path information, as described above.
7242 A path decomposes into independent segments at ``breakpoint'' knots,
7243 which are knots whose left and right angles are both prespecified in
7244 some way (i.e., their |left_type| and |right_type| aren't both open).
7247 @<Declare the procedure called |solve_choices|@>
7248 void mp_make_choices (MP mp,pointer knots) {
7249 pointer h; /* the first breakpoint */
7250 pointer p,q; /* consecutive breakpoints being processed */
7251 @<Other local variables for |make_choices|@>;
7252 check_arith; /* make sure that |arith_error=false| */
7253 if ( mp->internal[mp_tracing_choices]>0 )
7254 mp_print_path(mp, knots,", before choices",true);
7255 @<If consecutive knots are equal, join them explicitly@>;
7256 @<Find the first breakpoint, |h|, on the path;
7257 insert an artificial breakpoint if the path is an unbroken cycle@>;
7260 @<Fill in the control points between |p| and the next breakpoint,
7261 then advance |p| to that breakpoint@>;
7263 if ( mp->internal[mp_tracing_choices]>0 )
7264 mp_print_path(mp, knots,", after choices",true);
7265 if ( mp->arith_error ) {
7266 @<Report an unexpected problem during the choice-making@>;
7270 @ @<Report an unexpected problem during the choice...@>=
7272 print_err("Some number got too big");
7273 @.Some number got too big@>
7274 help2("The path that I just computed is out of range.")
7275 ("So it will probably look funny. Proceed, for a laugh.");
7276 mp_put_get_error(mp); mp->arith_error=false;
7279 @ Two knots in a row with the same coordinates will always be joined
7280 by an explicit ``curve'' whose control points are identical with the
7283 @<If consecutive knots are equal, join them explicitly@>=
7287 if ( x_coord(p)==x_coord(q) && y_coord(p)==y_coord(q) && right_type(p)>mp_explicit ) {
7288 right_type(p)=mp_explicit;
7289 if ( left_type(p)==mp_open ) {
7290 left_type(p)=mp_curl; left_curl(p)=unity;
7292 left_type(q)=mp_explicit;
7293 if ( right_type(q)==mp_open ) {
7294 right_type(q)=mp_curl; right_curl(q)=unity;
7296 right_x(p)=x_coord(p); left_x(q)=x_coord(p);
7297 right_y(p)=y_coord(p); left_y(q)=y_coord(p);
7302 @ If there are no breakpoints, it is necessary to compute the direction
7303 angles around an entire cycle. In this case the |left_type| of the first
7304 node is temporarily changed to |end_cycle|.
7306 @<Find the first breakpoint, |h|, on the path...@>=
7309 if ( left_type(h)!=mp_open ) break;
7310 if ( right_type(h)!=mp_open ) break;
7313 left_type(h)=mp_end_cycle; break;
7317 @ If |right_type(p)<given| and |q=link(p)|, we must have
7318 |right_type(p)=left_type(q)=mp_explicit| or |endpoint|.
7320 @<Fill in the control points between |p| and the next breakpoint...@>=
7322 if ( right_type(p)>=mp_given ) {
7323 while ( (left_type(q)==mp_open)&&(right_type(q)==mp_open) ) q=link(q);
7324 @<Fill in the control information between
7325 consecutive breakpoints |p| and |q|@>;
7326 } else if ( right_type(p)==mp_endpoint ) {
7327 @<Give reasonable values for the unused control points between |p| and~|q|@>;
7331 @ This step makes it possible to transform an explicitly computed path without
7332 checking the |left_type| and |right_type| fields.
7334 @<Give reasonable values for the unused control points between |p| and~|q|@>=
7336 right_x(p)=x_coord(p); right_y(p)=y_coord(p);
7337 left_x(q)=x_coord(q); left_y(q)=y_coord(q);
7340 @ Before we can go further into the way choices are made, we need to
7341 consider the underlying theory. The basic ideas implemented in |make_choices|
7342 are due to John Hobby, who introduced the notion of ``mock curvature''
7343 @^Hobby, John Douglas@>
7344 at a knot. Angles are chosen so that they preserve mock curvature when
7345 a knot is passed, and this has been found to produce excellent results.
7347 It is convenient to introduce some notations that simplify the necessary
7348 formulas. Let $d_{k,k+1}=\vert z\k-z_k\vert$ be the (nonzero) distance
7349 between knots |k| and |k+1|; and let
7350 $${z\k-z_k\over z_k-z_{k-1}}={d_{k,k+1}\over d_{k-1,k}}e^{i\psi_k}$$
7351 so that a polygonal line from $z_{k-1}$ to $z_k$ to $z\k$ turns left
7352 through an angle of~$\psi_k$. We assume that $\vert\psi_k\vert\L180^\circ$.
7353 The control points for the spline from $z_k$ to $z\k$ will be denoted by
7354 $$\eqalign{z_k^+&=z_k+
7355 \textstyle{1\over3}\rho_k e^{i\theta_k}(z\k-z_k),\cr
7357 \textstyle{1\over3}\sigma\k e^{-i\phi\k}(z\k-z_k),\cr}$$
7358 where $\rho_k$ and $\sigma\k$ are nonnegative ``velocity ratios'' at the
7359 beginning and end of the curve, while $\theta_k$ and $\phi\k$ are the
7360 corresponding ``offset angles.'' These angles satisfy the condition
7361 $$\theta_k+\phi_k+\psi_k=0,\eqno(*)$$
7362 whenever the curve leaves an intermediate knot~|k| in the direction that
7365 @ Let $\alpha_k$ and $\beta\k$ be the reciprocals of the ``tension'' of
7366 the curve at its beginning and ending points. This means that
7367 $\rho_k=\alpha_k f(\theta_k,\phi\k)$ and $\sigma\k=\beta\k f(\phi\k,\theta_k)$,
7368 where $f(\theta,\phi)$ is \MP's standard velocity function defined in
7369 the |velocity| subroutine. The cubic spline $B(z_k^{\phantom+},z_k^+,
7370 z\k^-,z\k^{\phantom+};t)$
7373 $${2\sigma\k\sin(\theta_k+\phi\k)-6\sin\theta_k\over\rho_k^2d_{k,k+1}}
7374 \qquad{\rm and}\qquad
7375 {2\rho_k\sin(\theta_k+\phi\k)-6\sin\phi\k\over\sigma\k^2d_{k,k+1}}$$
7376 at |t=0| and |t=1|, respectively. The mock curvature is the linear
7378 approximation to this true curvature that arises in the limit for
7379 small $\theta_k$ and~$\phi\k$, if second-order terms are discarded.
7380 The standard velocity function satisfies
7381 $$f(\theta,\phi)=1+O(\theta^2+\theta\phi+\phi^2);$$
7382 hence the mock curvatures are respectively
7383 $${2\beta\k(\theta_k+\phi\k)-6\theta_k\over\alpha_k^2d_{k,k+1}}
7384 \qquad{\rm and}\qquad
7385 {2\alpha_k(\theta_k+\phi\k)-6\phi\k\over\beta\k^2d_{k,k+1}}.\eqno(**)$$
7387 @ The turning angles $\psi_k$ are given, and equation $(*)$ above
7388 determines $\phi_k$ when $\theta_k$ is known, so the task of
7389 angle selection is essentially to choose appropriate values for each
7390 $\theta_k$. When equation~$(*)$ is used to eliminate $\phi$~variables
7391 from $(**)$, we obtain a system of linear equations of the form
7392 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
7394 $$A_k={\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
7395 \qquad B_k={3-\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
7396 \qquad C_k={3-\beta\k\over\alpha_k^2d_{k,k+1}},
7397 \qquad D_k={\beta\k\over\alpha_k^2d_{k,k+1}}.$$
7398 The tensions are always $3\over4$ or more, hence each $\alpha$ and~$\beta$
7399 will be at most $4\over3$. It follows that $B_k\G{5\over4}A_k$ and
7400 $C_k\G{5\over4}D_k$; hence the equations are diagonally dominant;
7401 hence they have a unique solution. Moreover, in most cases the tensions
7402 are equal to~1, so that $B_k=2A_k$ and $C_k=2D_k$. This makes the
7403 solution numerically stable, and there is an exponential damping
7404 effect: The data at knot $k\pm j$ affects the angle at knot~$k$ by
7405 a factor of~$O(2^{-j})$.
7407 @ However, we still must consider the angles at the starting and ending
7408 knots of a non-cyclic path. These angles might be given explicitly, or
7409 they might be specified implicitly in terms of an amount of ``curl.''
7411 Let's assume that angles need to be determined for a non-cyclic path
7412 starting at $z_0$ and ending at~$z_n$. Then equations of the form
7413 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta_{k+1}=R_k$$
7414 have been given for $0<k<n$, and it will be convenient to introduce
7415 equations of the same form for $k=0$ and $k=n$, where
7416 $$A_0=B_0=C_n=D_n=0.$$
7417 If $\theta_0$ is supposed to have a given value $E_0$, we simply
7418 define $C_0=1$, $D_0=0$, and $R_0=E_0$. Otherwise a curl
7419 parameter, $\gamma_0$, has been specified at~$z_0$; this means
7420 that the mock curvature at $z_0$ should be $\gamma_0$ times the
7421 mock curvature at $z_1$; i.e.,
7422 $${2\beta_1(\theta_0+\phi_1)-6\theta_0\over\alpha_0^2d_{01}}
7423 =\gamma_0{2\alpha_0(\theta_0+\phi_1)-6\phi_1\over\beta_1^2d_{01}}.$$
7424 This equation simplifies to
7425 $$(\alpha_0\chi_0+3-\beta_1)\theta_0+
7426 \bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\theta_1=
7427 -\bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\psi_1,$$
7428 where $\chi_0=\alpha_0^2\gamma_0/\beta_1^2$; so we can set $C_0=
7429 \chi_0\alpha_0+3-\beta_1$, $D_0=(3-\alpha_0)\chi_0+\beta_1$, $R_0=-D_0\psi_1$.
7430 It can be shown that $C_0>0$ and $C_0B_1-A_1D_0>0$ when $\gamma_0\G0$,
7431 hence the linear equations remain nonsingular.
7433 Similar considerations apply at the right end, when the final angle $\phi_n$
7434 may or may not need to be determined. It is convenient to let $\psi_n=0$,
7435 hence $\theta_n=-\phi_n$. We either have an explicit equation $\theta_n=E_n$,
7437 $$\bigl((3-\beta_n)\chi_n+\alpha_{n-1}\bigr)\theta_{n-1}+
7438 (\beta_n\chi_n+3-\alpha_{n-1})\theta_n=0,\qquad
7439 \chi_n={\beta_n^2\gamma_n\over\alpha_{n-1}^2}.$$
7441 When |make_choices| chooses angles, it must compute the coefficients of
7442 these linear equations, then solve the equations. To compute the coefficients,
7443 it is necessary to compute arctangents of the given turning angles~$\psi_k$.
7444 When the equations are solved, the chosen directions $\theta_k$ are put
7445 back into the form of control points by essentially computing sines and
7448 @ OK, we are ready to make the hard choices of |make_choices|.
7449 Most of the work is relegated to an auxiliary procedure
7450 called |solve_choices|, which has been introduced to keep
7451 |make_choices| from being extremely long.
7453 @<Fill in the control information between...@>=
7454 @<Calculate the turning angles $\psi_k$ and the distances $d_{k,k+1}$;
7455 set $n$ to the length of the path@>;
7456 @<Remove |open| types at the breakpoints@>;
7457 mp_solve_choices(mp, p,q,n)
7459 @ It's convenient to precompute quantities that will be needed several
7460 times later. The values of |delta_x[k]| and |delta_y[k]| will be the
7461 coordinates of $z\k-z_k$, and the magnitude of this vector will be
7462 |delta[k]=@t$d_{k,k+1}$@>|. The path angle $\psi_k$ between $z_k-z_{k-1}$
7463 and $z\k-z_k$ will be stored in |psi[k]|.
7466 int path_size; /* maximum number of knots between breakpoints of a path */
7469 scaled *delta; /* knot differences */
7470 angle *psi; /* turning angles */
7472 @ @<Allocate or initialize ...@>=
7478 @ @<Dealloc variables@>=
7484 @ @<Other local variables for |make_choices|@>=
7485 int k,n; /* current and final knot numbers */
7486 pointer s,t; /* registers for list traversal */
7487 scaled delx,dely; /* directions where |open| meets |explicit| */
7488 fraction sine,cosine; /* trig functions of various angles */
7490 @ @<Calculate the turning angles...@>=
7493 k=0; s=p; n=mp->path_size;
7496 mp->delta_x[k]=x_coord(t)-x_coord(s);
7497 mp->delta_y[k]=y_coord(t)-y_coord(s);
7498 mp->delta[k]=mp_pyth_add(mp, mp->delta_x[k],mp->delta_y[k]);
7500 sine=mp_make_fraction(mp, mp->delta_y[k-1],mp->delta[k-1]);
7501 cosine=mp_make_fraction(mp, mp->delta_x[k-1],mp->delta[k-1]);
7502 mp->psi[k]=mp_n_arg(mp, mp_take_fraction(mp, mp->delta_x[k],cosine)+
7503 mp_take_fraction(mp, mp->delta_y[k],sine),
7504 mp_take_fraction(mp, mp->delta_y[k],cosine)-
7505 mp_take_fraction(mp, mp->delta_x[k],sine));
7508 if ( k==mp->path_size ) {
7509 mp_reallocate_paths(mp, mp->path_size+(mp->path_size>>2));
7510 goto RESTART; /* retry, loop size has changed */
7513 } while (!((k>=n)&&(left_type(s)!=mp_end_cycle)));
7514 if ( k==n ) mp->psi[n]=0; else mp->psi[k]=mp->psi[1];
7517 @ When we get to this point of the code, |right_type(p)| is either
7518 |given| or |curl| or |open|. If it is |open|, we must have
7519 |left_type(p)=mp_end_cycle| or |left_type(p)=mp_explicit|. In the latter
7520 case, the |open| type is converted to |given|; however, if the
7521 velocity coming into this knot is zero, the |open| type is
7522 converted to a |curl|, since we don't know the incoming direction.
7524 Similarly, |left_type(q)| is either |given| or |curl| or |open| or
7525 |mp_end_cycle|. The |open| possibility is reduced either to |given| or to |curl|.
7527 @<Remove |open| types at the breakpoints@>=
7528 if ( left_type(q)==mp_open ) {
7529 delx=right_x(q)-x_coord(q); dely=right_y(q)-y_coord(q);
7530 if ( (delx==0)&&(dely==0) ) {
7531 left_type(q)=mp_curl; left_curl(q)=unity;
7533 left_type(q)=mp_given; left_given(q)=mp_n_arg(mp, delx,dely);
7536 if ( (right_type(p)==mp_open)&&(left_type(p)==mp_explicit) ) {
7537 delx=x_coord(p)-left_x(p); dely=y_coord(p)-left_y(p);
7538 if ( (delx==0)&&(dely==0) ) {
7539 right_type(p)=mp_curl; right_curl(p)=unity;
7541 right_type(p)=mp_given; right_given(p)=mp_n_arg(mp, delx,dely);
7545 @ Linear equations need to be solved whenever |n>1|; and also when |n=1|
7546 and exactly one of the breakpoints involves a curl. The simplest case occurs
7547 when |n=1| and there is a curl at both breakpoints; then we simply draw
7550 But before coding up the simple cases, we might as well face the general case,
7551 since we must deal with it sooner or later, and since the general case
7552 is likely to give some insight into the way simple cases can be handled best.
7554 When there is no cycle, the linear equations to be solved form a tridiagonal
7555 system, and we can apply the standard technique of Gaussian elimination
7556 to convert that system to a sequence of equations of the form
7557 $$\theta_0+u_0\theta_1=v_0,\quad
7558 \theta_1+u_1\theta_2=v_1,\quad\ldots,\quad
7559 \theta_{n-1}+u_{n-1}\theta_n=v_{n-1},\quad
7561 It is possible to do this diagonalization while generating the equations.
7562 Once $\theta_n$ is known, it is easy to determine $\theta_{n-1}$, \dots,
7563 $\theta_1$, $\theta_0$; thus, the equations will be solved.
7565 The procedure is slightly more complex when there is a cycle, but the
7566 basic idea will be nearly the same. In the cyclic case the right-hand
7567 sides will be $v_k+w_k\theta_0$ instead of simply $v_k$, and we will start
7568 the process off with $u_0=v_0=0$, $w_0=1$. The final equation will be not
7569 $\theta_n=v_n$ but $\theta_n+u_n\theta_1=v_n+w_n\theta_0$; an appropriate
7570 ending routine will take account of the fact that $\theta_n=\theta_0$ and
7571 eliminate the $w$'s from the system, after which the solution can be
7574 When $u_k$, $v_k$, and $w_k$ are being computed, the three pointer
7575 variables |r|, |s|,~|t| will point respectively to knots |k-1|, |k|,
7576 and~|k+1|. The $u$'s and $w$'s are scaled by $2^{28}$, i.e., they are
7577 of type |fraction|; the $\theta$'s and $v$'s are of type |angle|.
7580 angle *theta; /* values of $\theta_k$ */
7581 fraction *uu; /* values of $u_k$ */
7582 angle *vv; /* values of $v_k$ */
7583 fraction *ww; /* values of $w_k$ */
7585 @ @<Allocate or initialize ...@>=
7591 @ @<Dealloc variables@>=
7597 @ @<Declare |mp_reallocate| functions@>=
7598 void mp_reallocate_paths (MP mp, int l);
7601 void mp_reallocate_paths (MP mp, int l) {
7602 XREALLOC (mp->delta_x, l, scaled);
7603 XREALLOC (mp->delta_y, l, scaled);
7604 XREALLOC (mp->delta, l, scaled);
7605 XREALLOC (mp->psi, l, angle);
7606 XREALLOC (mp->theta, l, angle);
7607 XREALLOC (mp->uu, l, fraction);
7608 XREALLOC (mp->vv, l, angle);
7609 XREALLOC (mp->ww, l, fraction);
7613 @ Our immediate problem is to get the ball rolling by setting up the
7614 first equation or by realizing that no equations are needed, and to fit
7615 this initialization into a framework suitable for the overall computation.
7617 @<Declare the procedure called |solve_choices|@>=
7618 @<Declare subroutines needed by |solve_choices|@>
7619 void mp_solve_choices (MP mp,pointer p, pointer q, halfword n) {
7620 int k; /* current knot number */
7621 pointer r,s,t; /* registers for list traversal */
7622 @<Other local variables for |solve_choices|@>;
7627 @<Get the linear equations started; or |return|
7628 with the control points in place, if linear equations
7631 switch (left_type(s)) {
7632 case mp_end_cycle: case mp_open:
7633 @<Set up equation to match mock curvatures
7634 at $z_k$; then |goto found| with $\theta_n$
7635 adjusted to equal $\theta_0$, if a cycle has ended@>;
7638 @<Set up equation for a curl at $\theta_n$
7642 @<Calculate the given value of $\theta_n$
7645 } /* there are no other cases */
7650 @<Finish choosing angles and assigning control points@>;
7653 @ On the first time through the loop, we have |k=0| and |r| is not yet
7654 defined. The first linear equation, if any, will have $A_0=B_0=0$.
7656 @<Get the linear equations started...@>=
7657 switch (right_type(s)) {
7659 if ( left_type(t)==mp_given ) {
7660 @<Reduce to simple case of two givens and |return|@>
7662 @<Set up the equation for a given value of $\theta_0$@>;
7666 if ( left_type(t)==mp_curl ) {
7667 @<Reduce to simple case of straight line and |return|@>
7669 @<Set up the equation for a curl at $\theta_0$@>;
7673 mp->uu[0]=0; mp->vv[0]=0; mp->ww[0]=fraction_one;
7674 /* this begins a cycle */
7676 } /* there are no other cases */
7678 @ The general equation that specifies equality of mock curvature at $z_k$ is
7679 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
7680 as derived above. We want to combine this with the already-derived equation
7681 $\theta_{k-1}+u_{k-1}\theta_k=v_{k-1}+w_{k-1}\theta_0$ in order to obtain
7683 $\theta_k+u_k\theta\k=v_k+w_k\theta_0$. This can be done by dividing the
7685 $$(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}
7686 -A_kw_{k-1}\theta_0$$
7687 by $B_k-u_{k-1}A_k+C_k$. The trick is to do this carefully with
7688 fixed-point arithmetic, avoiding the chance of overflow while retaining
7691 The calculations will be performed in several registers that
7692 provide temporary storage for intermediate quantities.
7694 @<Other local variables for |solve_choices|@>=
7695 fraction aa,bb,cc,ff,acc; /* temporary registers */
7696 scaled dd,ee; /* likewise, but |scaled| */
7697 scaled lt,rt; /* tension values */
7699 @ @<Set up equation to match mock curvatures...@>=
7700 { @<Calculate the values $\\{aa}=A_k/B_k$, $\\{bb}=D_k/C_k$,
7701 $\\{dd}=(3-\alpha_{k-1})d_{k,k+1}$, $\\{ee}=(3-\beta\k)d_{k-1,k}$,
7702 and $\\{cc}=(B_k-u_{k-1}A_k)/B_k$@>;
7703 @<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>;
7704 mp->uu[k]=mp_take_fraction(mp, ff,bb);
7705 @<Calculate the values of $v_k$ and $w_k$@>;
7706 if ( left_type(s)==mp_end_cycle ) {
7707 @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>;
7711 @ Since tension values are never less than 3/4, the values |aa| and
7712 |bb| computed here are never more than 4/5.
7714 @<Calculate the values $\\{aa}=...@>=
7715 if ( abs(right_tension(r))==unity) {
7716 aa=fraction_half; dd=2*mp->delta[k];
7718 aa=mp_make_fraction(mp, unity,3*abs(right_tension(r))-unity);
7719 dd=mp_take_fraction(mp, mp->delta[k],
7720 fraction_three-mp_make_fraction(mp, unity,abs(right_tension(r))));
7722 if ( abs(left_tension(t))==unity ){
7723 bb=fraction_half; ee=2*mp->delta[k-1];
7725 bb=mp_make_fraction(mp, unity,3*abs(left_tension(t))-unity);
7726 ee=mp_take_fraction(mp, mp->delta[k-1],
7727 fraction_three-mp_make_fraction(mp, unity,abs(left_tension(t))));
7729 cc=fraction_one-mp_take_fraction(mp, mp->uu[k-1],aa)
7731 @ The ratio to be calculated in this step can be written in the form
7732 $$\beta_k^2\cdot\\{ee}\over\beta_k^2\cdot\\{ee}+\alpha_k^2\cdot
7733 \\{cc}\cdot\\{dd},$$
7734 because of the quantities just calculated. The values of |dd| and |ee|
7735 will not be needed after this step has been performed.
7737 @<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>=
7738 dd=mp_take_fraction(mp, dd,cc); lt=abs(left_tension(s)); rt=abs(right_tension(s));
7739 if ( lt!=rt ) { /* $\beta_k^{-1}\ne\alpha_k^{-1}$ */
7741 ff=mp_make_fraction(mp, lt,rt);
7742 ff=mp_take_fraction(mp, ff,ff); /* $\alpha_k^2/\beta_k^2$ */
7743 dd=mp_take_fraction(mp, dd,ff);
7745 ff=mp_make_fraction(mp, rt,lt);
7746 ff=mp_take_fraction(mp, ff,ff); /* $\beta_k^2/\alpha_k^2$ */
7747 ee=mp_take_fraction(mp, ee,ff);
7750 ff=mp_make_fraction(mp, ee,ee+dd)
7752 @ The value of $u_{k-1}$ will be |<=1| except when $k=1$ and the previous
7753 equation was specified by a curl. In that case we must use a special
7754 method of computation to prevent overflow.
7756 Fortunately, the calculations turn out to be even simpler in this ``hard''
7757 case. The curl equation makes $w_0=0$ and $v_0=-u_0\psi_1$, hence
7758 $-B_1\psi_1-A_1v_0=-(B_1-u_0A_1)\psi_1=-\\{cc}\cdot B_1\psi_1$.
7760 @<Calculate the values of $v_k$ and $w_k$@>=
7761 acc=-mp_take_fraction(mp, mp->psi[k+1],mp->uu[k]);
7762 if ( right_type(r)==mp_curl ) {
7764 mp->vv[k]=acc-mp_take_fraction(mp, mp->psi[1],fraction_one-ff);
7766 ff=mp_make_fraction(mp, fraction_one-ff,cc); /* this is
7767 $B_k/(C_k+B_k-u_{k-1}A_k)<5$ */
7768 acc=acc-mp_take_fraction(mp, mp->psi[k],ff);
7769 ff=mp_take_fraction(mp, ff,aa); /* this is $A_k/(C_k+B_k-u_{k-1}A_k)$ */
7770 mp->vv[k]=acc-mp_take_fraction(mp, mp->vv[k-1],ff);
7771 if ( mp->ww[k-1]==0 ) mp->ww[k]=0;
7772 else mp->ww[k]=-mp_take_fraction(mp, mp->ww[k-1],ff);
7775 @ When a complete cycle has been traversed, we have $\theta_k+u_k\theta\k=
7776 v_k+w_k\theta_0$, for |1<=k<=n|. We would like to determine the value of
7777 $\theta_n$ and reduce the system to the form $\theta_k+u_k\theta\k=v_k$
7778 for |0<=k<n|, so that the cyclic case can be finished up just as if there
7781 The idea in the following code is to observe that
7782 $$\eqalign{\theta_n&=v_n+w_n\theta_0-u_n\theta_1=\cdots\cr
7783 &=v_n+w_n\theta_0-u_n\bigl(v_1+w_1\theta_0-u_1(v_2+\cdots
7784 -u_{n-2}(v_{n-1}+w_{n-1}\theta_0-u_{n-1}\theta_0))\bigr),\cr}$$
7785 so we can solve for $\theta_n=\theta_0$.
7787 @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>=
7789 aa=0; bb=fraction_one; /* we have |k=n| */
7792 aa=mp->vv[k]-mp_take_fraction(mp, aa,mp->uu[k]);
7793 bb=mp->ww[k]-mp_take_fraction(mp, bb,mp->uu[k]);
7794 } while (k!=n); /* now $\theta_n=\\{aa}+\\{bb}\cdot\theta_n$ */
7795 aa=mp_make_fraction(mp, aa,fraction_one-bb);
7796 mp->theta[n]=aa; mp->vv[0]=aa;
7797 for (k=1;k<=n-1;k++) {
7798 mp->vv[k]=mp->vv[k]+mp_take_fraction(mp, aa,mp->ww[k]);
7803 @ @d reduce_angle(A) if ( abs((A))>one_eighty_deg ) {
7804 if ( (A)>0 ) (A)=(A)-three_sixty_deg; else (A)=(A)+three_sixty_deg; }
7806 @<Calculate the given value of $\theta_n$...@>=
7808 mp->theta[n]=left_given(s)-mp_n_arg(mp, mp->delta_x[n-1],mp->delta_y[n-1]);
7809 reduce_angle(mp->theta[n]);
7813 @ @<Set up the equation for a given value of $\theta_0$@>=
7815 mp->vv[0]=right_given(s)-mp_n_arg(mp, mp->delta_x[0],mp->delta_y[0]);
7816 reduce_angle(mp->vv[0]);
7817 mp->uu[0]=0; mp->ww[0]=0;
7820 @ @<Set up the equation for a curl at $\theta_0$@>=
7821 { cc=right_curl(s); lt=abs(left_tension(t)); rt=abs(right_tension(s));
7822 if ( (rt==unity)&&(lt==unity) )
7823 mp->uu[0]=mp_make_fraction(mp, cc+cc+unity,cc+two);
7825 mp->uu[0]=mp_curl_ratio(mp, cc,rt,lt);
7826 mp->vv[0]=-mp_take_fraction(mp, mp->psi[1],mp->uu[0]); mp->ww[0]=0;
7829 @ @<Set up equation for a curl at $\theta_n$...@>=
7830 { cc=left_curl(s); lt=abs(left_tension(s)); rt=abs(right_tension(r));
7831 if ( (rt==unity)&&(lt==unity) )
7832 ff=mp_make_fraction(mp, cc+cc+unity,cc+two);
7834 ff=mp_curl_ratio(mp, cc,lt,rt);
7835 mp->theta[n]=-mp_make_fraction(mp, mp_take_fraction(mp, mp->vv[n-1],ff),
7836 fraction_one-mp_take_fraction(mp, ff,mp->uu[n-1]));
7840 @ The |curl_ratio| subroutine has three arguments, which our previous notation
7841 encourages us to call $\gamma$, $\alpha^{-1}$, and $\beta^{-1}$. It is
7842 a somewhat tedious program to calculate
7843 $${(3-\alpha)\alpha^2\gamma+\beta^3\over
7844 \alpha^3\gamma+(3-\beta)\beta^2},$$
7845 with the result reduced to 4 if it exceeds 4. (This reduction of curl
7846 is necessary only if the curl and tension are both large.)
7847 The values of $\alpha$ and $\beta$ will be at most~4/3.
7849 @<Declare subroutines needed by |solve_choices|@>=
7850 fraction mp_curl_ratio (MP mp,scaled gamma, scaled a_tension,
7852 fraction alpha,beta,num,denom,ff; /* registers */
7853 alpha=mp_make_fraction(mp, unity,a_tension);
7854 beta=mp_make_fraction(mp, unity,b_tension);
7855 if ( alpha<=beta ) {
7856 ff=mp_make_fraction(mp, alpha,beta); ff=mp_take_fraction(mp, ff,ff);
7857 gamma=mp_take_fraction(mp, gamma,ff);
7858 beta=beta / 010000; /* convert |fraction| to |scaled| */
7859 denom=mp_take_fraction(mp, gamma,alpha)+three-beta;
7860 num=mp_take_fraction(mp, gamma,fraction_three-alpha)+beta;
7862 ff=mp_make_fraction(mp, beta,alpha); ff=mp_take_fraction(mp, ff,ff);
7863 beta=mp_take_fraction(mp, beta,ff) / 010000; /* convert |fraction| to |scaled| */
7864 denom=mp_take_fraction(mp, gamma,alpha)+(ff / 1365)-beta;
7865 /* $1365\approx 2^{12}/3$ */
7866 num=mp_take_fraction(mp, gamma,fraction_three-alpha)+beta;
7868 if ( num>=denom+denom+denom+denom ) return fraction_four;
7869 else return mp_make_fraction(mp, num,denom);
7872 @ We're in the home stretch now.
7874 @<Finish choosing angles and assigning control points@>=
7875 for (k=n-1;k>=0;k--) {
7876 mp->theta[k]=mp->vv[k]-mp_take_fraction(mp,mp->theta[k+1],mp->uu[k]);
7881 mp_n_sin_cos(mp, mp->theta[k]); mp->st=mp->n_sin; mp->ct=mp->n_cos;
7882 mp_n_sin_cos(mp, -mp->psi[k+1]-mp->theta[k+1]); mp->sf=mp->n_sin; mp->cf=mp->n_cos;
7883 mp_set_controls(mp, s,t,k);
7887 @ The |set_controls| routine actually puts the control points into
7888 a pair of consecutive nodes |p| and~|q|. Global variables are used to
7889 record the values of $\sin\theta$, $\cos\theta$, $\sin\phi$, and
7890 $\cos\phi$ needed in this calculation.
7896 fraction cf; /* sines and cosines */
7898 @ @<Declare subroutines needed by |solve_choices|@>=
7899 void mp_set_controls (MP mp,pointer p, pointer q, integer k) {
7900 fraction rr,ss; /* velocities, divided by thrice the tension */
7901 scaled lt,rt; /* tensions */
7902 fraction sine; /* $\sin(\theta+\phi)$ */
7903 lt=abs(left_tension(q)); rt=abs(right_tension(p));
7904 rr=mp_velocity(mp, mp->st,mp->ct,mp->sf,mp->cf,rt);
7905 ss=mp_velocity(mp, mp->sf,mp->cf,mp->st,mp->ct,lt);
7906 if ( (right_tension(p)<0)||(left_tension(q)<0) ) {
7907 @<Decrease the velocities,
7908 if necessary, to stay inside the bounding triangle@>;
7910 right_x(p)=x_coord(p)+mp_take_fraction(mp,
7911 mp_take_fraction(mp, mp->delta_x[k],mp->ct)-
7912 mp_take_fraction(mp, mp->delta_y[k],mp->st),rr);
7913 right_y(p)=y_coord(p)+mp_take_fraction(mp,
7914 mp_take_fraction(mp, mp->delta_y[k],mp->ct)+
7915 mp_take_fraction(mp, mp->delta_x[k],mp->st),rr);
7916 left_x(q)=x_coord(q)-mp_take_fraction(mp,
7917 mp_take_fraction(mp, mp->delta_x[k],mp->cf)+
7918 mp_take_fraction(mp, mp->delta_y[k],mp->sf),ss);
7919 left_y(q)=y_coord(q)-mp_take_fraction(mp,
7920 mp_take_fraction(mp, mp->delta_y[k],mp->cf)-
7921 mp_take_fraction(mp, mp->delta_x[k],mp->sf),ss);
7922 right_type(p)=mp_explicit; left_type(q)=mp_explicit;
7925 @ The boundedness conditions $\\{rr}\L\sin\phi\,/\sin(\theta+\phi)$ and
7926 $\\{ss}\L\sin\theta\,/\sin(\theta+\phi)$ are to be enforced if $\sin\theta$,
7927 $\sin\phi$, and $\sin(\theta+\phi)$ all have the same sign. Otherwise
7928 there is no ``bounding triangle.''
7930 @<Decrease the velocities, if necessary...@>=
7931 if (((mp->st>=0)&&(mp->sf>=0))||((mp->st<=0)&&(mp->sf<=0)) ) {
7932 sine=mp_take_fraction(mp, abs(mp->st),mp->cf)+
7933 mp_take_fraction(mp, abs(mp->sf),mp->ct);
7935 sine=mp_take_fraction(mp, sine,fraction_one+unity); /* safety factor */
7936 if ( right_tension(p)<0 )
7937 if ( mp_ab_vs_cd(mp, abs(mp->sf),fraction_one,rr,sine)<0 )
7938 rr=mp_make_fraction(mp, abs(mp->sf),sine);
7939 if ( left_tension(q)<0 )
7940 if ( mp_ab_vs_cd(mp, abs(mp->st),fraction_one,ss,sine)<0 )
7941 ss=mp_make_fraction(mp, abs(mp->st),sine);
7945 @ Only the simple cases remain to be handled.
7947 @<Reduce to simple case of two givens and |return|@>=
7949 aa=mp_n_arg(mp, mp->delta_x[0],mp->delta_y[0]);
7950 mp_n_sin_cos(mp, right_given(p)-aa); mp->ct=mp->n_cos; mp->st=mp->n_sin;
7951 mp_n_sin_cos(mp, left_given(q)-aa); mp->cf=mp->n_cos; mp->sf=-mp->n_sin;
7952 mp_set_controls(mp, p,q,0); return;
7955 @ @<Reduce to simple case of straight line and |return|@>=
7957 right_type(p)=mp_explicit; left_type(q)=mp_explicit;
7958 lt=abs(left_tension(q)); rt=abs(right_tension(p));
7960 if ( mp->delta_x[0]>=0 ) right_x(p)=x_coord(p)+((mp->delta_x[0]+1) / 3);
7961 else right_x(p)=x_coord(p)+((mp->delta_x[0]-1) / 3);
7962 if ( mp->delta_y[0]>=0 ) right_y(p)=y_coord(p)+((mp->delta_y[0]+1) / 3);
7963 else right_y(p)=y_coord(p)+((mp->delta_y[0]-1) / 3);
7965 ff=mp_make_fraction(mp, unity,3*rt); /* $\alpha/3$ */
7966 right_x(p)=x_coord(p)+mp_take_fraction(mp, mp->delta_x[0],ff);
7967 right_y(p)=y_coord(p)+mp_take_fraction(mp, mp->delta_y[0],ff);
7970 if ( mp->delta_x[0]>=0 ) left_x(q)=x_coord(q)-((mp->delta_x[0]+1) / 3);
7971 else left_x(q)=x_coord(q)-((mp->delta_x[0]-1) / 3);
7972 if ( mp->delta_y[0]>=0 ) left_y(q)=y_coord(q)-((mp->delta_y[0]+1) / 3);
7973 else left_y(q)=y_coord(q)-((mp->delta_y[0]-1) / 3);
7975 ff=mp_make_fraction(mp, unity,3*lt); /* $\beta/3$ */
7976 left_x(q)=x_coord(q)-mp_take_fraction(mp, mp->delta_x[0],ff);
7977 left_y(q)=y_coord(q)-mp_take_fraction(mp, mp->delta_y[0],ff);
7982 @* \[19] Measuring paths.
7983 \MP's \&{llcorner}, \&{lrcorner}, \&{ulcorner}, and \&{urcorner} operators
7984 allow the user to measure the bounding box of anything that can go into a
7985 picture. It's easy to get rough bounds on the $x$ and $y$ extent of a path
7986 by just finding the bounding box of the knots and the control points. We
7987 need a more accurate version of the bounding box, but we can still use the
7988 easy estimate to save time by focusing on the interesting parts of the path.
7990 @ Computing an accurate bounding box involves a theme that will come up again
7991 and again. Given a Bernshte{\u\i}n polynomial
7992 @^Bernshte{\u\i}n, Serge{\u\i} Natanovich@>
7993 $$B(z_0,z_1,\ldots,z_n;t)=\sum_k{n\choose k}t^k(1-t)^{n-k}z_k,$$
7994 we can conveniently bisect its range as follows:
7997 \textindent{1)} Let $z_k^{(0)}=z_k$, for |0<=k<=n|.
8000 \textindent{2)} Let $z_k^{(j+1)}={1\over2}(z_k^{(j)}+z\k^{(j)})$, for
8001 |0<=k<n-j|, for |0<=j<n|.
8005 $$B(z_0,z_1,\ldots,z_n;t)=B(z_0^{(0)},z_0^{(1)},\ldots,z_0^{(n)};2t)
8006 =B(z_0^{(n)},z_1^{(n-1)},\ldots,z_n^{(0)};2t-1).$$
8007 This formula gives us the coefficients of polynomials to use over the ranges
8008 $0\L t\L{1\over2}$ and ${1\over2}\L t\L1$.
8010 @ Now here's a subroutine that's handy for all sorts of path computations:
8011 Given a quadratic polynomial $B(a,b,c;t)$, the |crossing_point| function
8012 returns the unique |fraction| value |t| between 0 and~1 at which
8013 $B(a,b,c;t)$ changes from positive to negative, or returns
8014 |t=fraction_one+1| if no such value exists. If |a<0| (so that $B(a,b,c;t)$
8015 is already negative at |t=0|), |crossing_point| returns the value zero.
8017 @d no_crossing { return (fraction_one+1); }
8018 @d one_crossing { return fraction_one; }
8019 @d zero_crossing { return 0; }
8020 @d mp_crossing_point(M,A,B,C) mp_do_crossing_point(A,B,C)
8022 @c fraction mp_do_crossing_point (integer a, integer b, integer c) {
8023 integer d; /* recursive counter */
8024 integer x,xx,x0,x1,x2; /* temporary registers for bisection */
8025 if ( a<0 ) zero_crossing;
8028 if ( c>0 ) { no_crossing; }
8029 else if ( (a==0)&&(b==0) ) { no_crossing;}
8030 else { one_crossing; }
8032 if ( a==0 ) zero_crossing;
8033 } else if ( a==0 ) {
8034 if ( b<=0 ) zero_crossing;
8036 @<Use bisection to find the crossing point, if one exists@>;
8039 @ The general bisection method is quite simple when $n=2$, hence
8040 |crossing_point| does not take much time. At each stage in the
8041 recursion we have a subinterval defined by |l| and~|j| such that
8042 $B(a,b,c;2^{-l}(j+t))=B(x_0,x_1,x_2;t)$, and we want to ``zero in'' on
8043 the subinterval where $x_0\G0$ and $\min(x_1,x_2)<0$.
8045 It is convenient for purposes of calculation to combine the values
8046 of |l| and~|j| in a single variable $d=2^l+j$, because the operation
8047 of bisection then corresponds simply to doubling $d$ and possibly
8048 adding~1. Furthermore it proves to be convenient to modify
8049 our previous conventions for bisection slightly, maintaining the
8050 variables $X_0=2^lx_0$, $X_1=2^l(x_0-x_1)$, and $X_2=2^l(x_1-x_2)$.
8051 With these variables the conditions $x_0\ge0$ and $\min(x_1,x_2)<0$ are
8052 equivalent to $\max(X_1,X_1+X_2)>X_0\ge0$.
8054 The following code maintains the invariant relations
8055 $0\L|x0|<\max(|x1|,|x1|+|x2|)$,
8056 $\vert|x1|\vert<2^{30}$, $\vert|x2|\vert<2^{30}$;
8057 it has been constructed in such a way that no arithmetic overflow
8058 will occur if the inputs satisfy
8059 $a<2^{30}$, $\vert a-b\vert<2^{30}$, and $\vert b-c\vert<2^{30}$.
8061 @<Use bisection to find the crossing point...@>=
8062 d=1; x0=a; x1=a-b; x2=b-c;
8073 if ( x<=x0 ) { if ( x+x2<=x0 ) no_crossing; }
8077 } while (d<fraction_one);
8078 return (d-fraction_one)
8080 @ Here is a routine that computes the $x$ or $y$ coordinate of the point on
8081 a cubic corresponding to the |fraction| value~|t|.
8083 It is convenient to define a \.{WEB} macro |t_of_the_way| such that
8084 |t_of_the_way(a,b)| expands to |a-(a-b)*t|, i.e., to |t[a,b]|.
8086 @d t_of_the_way(A,B) ((A)-mp_take_fraction(mp,((A)-(B)),t))
8088 @c scaled mp_eval_cubic (MP mp,pointer p, pointer q, fraction t) {
8089 scaled x1,x2,x3; /* intermediate values */
8090 x1=t_of_the_way(knot_coord(p),right_coord(p));
8091 x2=t_of_the_way(right_coord(p),left_coord(q));
8092 x3=t_of_the_way(left_coord(q),knot_coord(q));
8093 x1=t_of_the_way(x1,x2);
8094 x2=t_of_the_way(x2,x3);
8095 return t_of_the_way(x1,x2);
8098 @ The actual bounding box information is stored in global variables.
8099 Since it is convenient to address the $x$ and $y$ information
8100 separately, we define arrays indexed by |x_code..y_code| and use
8101 macros to give them more convenient names.
8105 mp_x_code=0, /* index for |minx| and |maxx| */
8106 mp_y_code /* index for |miny| and |maxy| */
8110 @d minx mp->bbmin[mp_x_code]
8111 @d maxx mp->bbmax[mp_x_code]
8112 @d miny mp->bbmin[mp_y_code]
8113 @d maxy mp->bbmax[mp_y_code]
8116 scaled bbmin[mp_y_code+1];
8117 scaled bbmax[mp_y_code+1];
8118 /* the result of procedures that compute bounding box information */
8120 @ Now we're ready for the key part of the bounding box computation.
8121 The |bound_cubic| procedure updates |bbmin[c]| and |bbmax[c]| based on
8122 $$B(\hbox{|knot_coord(p)|}, \hbox{|right_coord(p)|},
8123 \hbox{|left_coord(q)|}, \hbox{|knot_coord(q)|};t)
8125 for $0<t\le1$. In other words, the procedure adjusts the bounds to
8126 accommodate |knot_coord(q)| and any extremes over the range $0<t<1$.
8127 The |c| parameter is |x_code| or |y_code|.
8129 @c void mp_bound_cubic (MP mp,pointer p, pointer q, small_number c) {
8130 boolean wavy; /* whether we need to look for extremes */
8131 scaled del1,del2,del3,del,dmax; /* proportional to the control
8132 points of a quadratic derived from a cubic */
8133 fraction t,tt; /* where a quadratic crosses zero */
8134 scaled x; /* a value that |bbmin[c]| and |bbmax[c]| must accommodate */
8136 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8137 @<Check the control points against the bounding box and set |wavy:=true|
8138 if any of them lie outside@>;
8140 del1=right_coord(p)-knot_coord(p);
8141 del2=left_coord(q)-right_coord(p);
8142 del3=knot_coord(q)-left_coord(q);
8143 @<Scale up |del1|, |del2|, and |del3| for greater accuracy;
8144 also set |del| to the first nonzero element of |(del1,del2,del3)|@>;
8146 negate(del1); negate(del2); negate(del3);
8148 t=mp_crossing_point(mp, del1,del2,del3);
8149 if ( t<fraction_one ) {
8150 @<Test the extremes of the cubic against the bounding box@>;
8155 @ @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>=
8156 if ( x<mp->bbmin[c] ) mp->bbmin[c]=x;
8157 if ( x>mp->bbmax[c] ) mp->bbmax[c]=x
8159 @ @<Check the control points against the bounding box and set...@>=
8161 if ( mp->bbmin[c]<=right_coord(p) )
8162 if ( right_coord(p)<=mp->bbmax[c] )
8163 if ( mp->bbmin[c]<=left_coord(q) )
8164 if ( left_coord(q)<=mp->bbmax[c] )
8167 @ If |del1=del2=del3=0|, it's impossible to obey the title of this
8168 section. We just set |del=0| in that case.
8170 @<Scale up |del1|, |del2|, and |del3| for greater accuracy...@>=
8171 if ( del1!=0 ) del=del1;
8172 else if ( del2!=0 ) del=del2;
8176 if ( abs(del2)>dmax ) dmax=abs(del2);
8177 if ( abs(del3)>dmax ) dmax=abs(del3);
8178 while ( dmax<fraction_half ) {
8179 dmax+=dmax; del1+=del1; del2+=del2; del3+=del3;
8183 @ Since |crossing_point| has tried to choose |t| so that
8184 $B(|del1|,|del2|,|del3|;\tau)$ crosses zero at $\tau=|t|$ with negative
8185 slope, the value of |del2| computed below should not be positive.
8186 But rounding error could make it slightly positive in which case we
8187 must cut it to zero to avoid confusion.
8189 @<Test the extremes of the cubic against the bounding box@>=
8191 x=mp_eval_cubic(mp, p,q,t);
8192 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8193 del2=t_of_the_way(del2,del3);
8194 /* now |0,del2,del3| represent the derivative on the remaining interval */
8195 if ( del2>0 ) del2=0;
8196 tt=mp_crossing_point(mp, 0,-del2,-del3);
8197 if ( tt<fraction_one ) {
8198 @<Test the second extreme against the bounding box@>;
8202 @ @<Test the second extreme against the bounding box@>=
8204 x=mp_eval_cubic(mp, p,q,t_of_the_way(tt,fraction_one));
8205 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8208 @ Finding the bounding box of a path is basically a matter of applying
8209 |bound_cubic| twice for each pair of adjacent knots.
8211 @c void mp_path_bbox (MP mp,pointer h) {
8212 pointer p,q; /* a pair of adjacent knots */
8213 minx=x_coord(h); miny=y_coord(h);
8214 maxx=minx; maxy=miny;
8217 if ( right_type(p)==mp_endpoint ) return;
8219 mp_bound_cubic(mp, x_loc(p),x_loc(q),mp_x_code);
8220 mp_bound_cubic(mp, y_loc(p),y_loc(q),mp_y_code);
8225 @ Another important way to measure a path is to find its arc length. This
8226 is best done by using the general bisection algorithm to subdivide the path
8227 until obtaining ``well behaved'' subpaths whose arc lengths can be approximated
8230 Since the arc length is the integral with respect to time of the magnitude of
8231 the velocity, it is natural to use Simpson's rule for the approximation.
8233 If $\dot B(t)$ is the spline velocity, Simpson's rule gives
8234 $$ \vb\dot B(0)\vb + 4\vb\dot B({1\over2})\vb + \vb\dot B(1)\vb \over 6 $$
8235 for the arc length of a path of length~1. For a cubic spline
8236 $B(z_0,z_1,z_2,z_3;t)$, the time derivative $\dot B(t)$ is
8237 $3B(dz_0,dz_1,dz_2;t)$, where $dz_i=z_{i+1}-z_i$. Hence the arc length
8239 $$ {\vb dz_0\vb \over 2} + 2\vb dz_{02}\vb + {\vb dz_2\vb \over 2}, $$
8241 $$ dz_{02}={1\over2}\left({dz_0+dz_1\over 2}+{dz_1+dz_2\over 2}\right)$$
8242 is the result of the bisection algorithm.
8244 @ The remaining problem is how to decide when a subpath is ``well behaved.''
8245 This could be done via the theoretical error bound for Simpson's rule,
8247 but this is impractical because it requires an estimate of the fourth
8248 derivative of the quantity being integrated. It is much easier to just perform
8249 a bisection step and see how much the arc length estimate changes. Since the
8250 error for Simpson's rule is proportional to the fourth power of the sample
8251 spacing, the remaining error is typically about $1\over16$ of the amount of
8252 the change. We say ``typically'' because the error has a pseudo-random behavior
8253 that could cause the two estimates to agree when each contain large errors.
8255 To protect against disasters such as undetected cusps, the bisection process
8256 should always continue until all the $dz_i$ vectors belong to a single
8257 $90^\circ$ sector. This ensures that no point on the spline can have velocity
8258 less than 70\% of the minimum of $\vb dz_0\vb$, $\vb dz_1\vb$ and $\vb dz_2\vb$.
8259 If such a spline happens to produce an erroneous arc length estimate that
8260 is little changed by bisection, the amount of the error is likely to be fairly
8261 small. We will try to arrange things so that freak accidents of this type do
8262 not destroy the inverse relationship between the \&{arclength} and
8263 \&{arctime} operations.
8264 @:arclength_}{\&{arclength} primitive@>
8265 @:arctime_}{\&{arctime} primitive@>
8267 @ The \&{arclength} and \&{arctime} operations are both based on a recursive
8269 function that finds the arc length of a cubic spline given $dz_0$, $dz_1$,
8270 $dz_2$. This |arc_test| routine also takes an arc length goal |a_goal| and
8271 returns the time when the arc length reaches |a_goal| if there is such a time.
8272 Thus the return value is either an arc length less than |a_goal| or, if the
8273 arc length would be at least |a_goal|, it returns a time value decreased by
8274 |two|. This allows the caller to use the sign of the result to distinguish
8275 between arc lengths and time values. On certain types of overflow, it is
8276 possible for |a_goal| and the result of |arc_test| both to be |el_gordo|.
8277 Otherwise, the result is always less than |a_goal|.
8279 Rather than halving the control point coordinates on each recursive call to
8280 |arc_test|, it is better to keep them proportional to velocity on the original
8281 curve and halve the results instead. This means that recursive calls can
8282 potentially use larger error tolerances in their arc length estimates. How
8283 much larger depends on to what extent the errors behave as though they are
8284 independent of each other. To save computing time, we use optimistic assumptions
8285 and increase the tolerance by a factor of about $\sqrt2$ for each recursive
8288 In addition to the tolerance parameter, |arc_test| should also have parameters
8289 for ${1\over3}\vb\dot B(0)\vb$, ${2\over3}\vb\dot B({1\over2})\vb$, and
8290 ${1\over3}\vb\dot B(1)\vb$. These quantities are relatively expensive to compute
8291 and they are needed in different instances of |arc_test|.
8293 @c @<Declare subroutines needed by |arc_test|@>
8294 scaled mp_arc_test (MP mp, scaled dx0, scaled dy0, scaled dx1, scaled dy1,
8295 scaled dx2, scaled dy2, scaled v0, scaled v02,
8296 scaled v2, scaled a_goal, scaled tol) {
8297 boolean simple; /* are the control points confined to a $90^\circ$ sector? */
8298 scaled dx01, dy01, dx12, dy12, dx02, dy02; /* bisection results */
8300 /* twice the velocity magnitudes at $t={1\over4}$ and $t={3\over4}$ */
8301 scaled arc; /* best arc length estimate before recursion */
8302 @<Other local variables in |arc_test|@>;
8303 @<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,
8305 @<Initialize |v002|, |v022|, and the arc length estimate |arc|; if it overflows
8306 set |arc_test| and |return|@>;
8307 @<Test if the control points are confined to one quadrant or rotating them
8308 $45^\circ$ would put them in one quadrant. Then set |simple| appropriately@>;
8309 if ( simple && (abs(arc-v02-halfp(v0+v2)) <= tol) ) {
8310 if ( arc < a_goal ) {
8313 @<Estimate when the arc length reaches |a_goal| and set |arc_test| to
8314 that time minus |two|@>;
8317 @<Use one or two recursive calls to compute the |arc_test| function@>;
8321 @ The |tol| value should by multiplied by $\sqrt 2$ before making recursive
8322 calls, but $1.5$ is an adequate approximation. It is best to avoid using
8323 |make_fraction| in this inner loop.
8326 @<Use one or two recursive calls to compute the |arc_test| function@>=
8328 @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is as
8329 large as possible@>;
8330 tol = tol + halfp(tol);
8331 a = mp_arc_test(mp, dx0,dy0, dx01,dy01, dx02,dy02, v0, v002,
8332 halfp(v02), a_new, tol);
8334 return (-halfp(two-a));
8336 @<Update |a_new| to reduce |a_new+a_aux| by |a|@>;
8337 b = mp_arc_test(mp, dx02,dy02, dx12,dy12, dx2,dy2,
8338 halfp(v02), v022, v2, a_new, tol);
8340 return (-halfp(-b) - half_unit);
8342 return (a + half(b-a));
8346 @ @<Other local variables in |arc_test|@>=
8347 scaled a,b; /* results of recursive calls */
8348 scaled a_new,a_aux; /* the sum of these gives the |a_goal| */
8350 @ @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is...@>=
8351 a_aux = el_gordo - a_goal;
8352 if ( a_goal > a_aux ) {
8353 a_aux = a_goal - a_aux;
8356 a_new = a_goal + a_goal;
8360 @ There is no need to maintain |a_aux| at this point so we use it as a temporary
8361 to force the additions and subtractions to be done in an order that avoids
8364 @<Update |a_new| to reduce |a_new+a_aux| by |a|@>=
8367 a_new = a_new + a_aux;
8370 @ This code assumes all {\it dx} and {\it dy} variables have magnitude less than
8371 |fraction_four|. To simplify the rest of the |arc_test| routine, we strengthen
8372 this assumption by requiring the norm of each $({\it dx},{\it dy})$ pair to obey
8373 this bound. Note that recursive calls will maintain this invariant.
8375 @<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,...@>=
8376 dx01 = half(dx0 + dx1);
8377 dx12 = half(dx1 + dx2);
8378 dx02 = half(dx01 + dx12);
8379 dy01 = half(dy0 + dy1);
8380 dy12 = half(dy1 + dy2);
8381 dy02 = half(dy01 + dy12)
8383 @ We should be careful to keep |arc<el_gordo| so that calling |arc_test| with
8384 |a_goal=el_gordo| is guaranteed to yield the arc length.
8386 @<Initialize |v002|, |v022|, and the arc length estimate |arc|;...@>=
8387 v002 = mp_pyth_add(mp, dx01+half(dx0+dx02), dy01+half(dy0+dy02));
8388 v022 = mp_pyth_add(mp, dx12+half(dx02+dx2), dy12+half(dy02+dy2));
8390 arc1 = v002 + half(halfp(v0+tmp) - v002);
8391 arc = v022 + half(halfp(v2+tmp) - v022);
8392 if ( (arc < el_gordo-arc1) ) {
8395 mp->arith_error = true;
8396 if ( a_goal==el_gordo ) return (el_gordo);
8400 @ @<Other local variables in |arc_test|@>=
8401 scaled tmp, tmp2; /* all purpose temporary registers */
8402 scaled arc1; /* arc length estimate for the first half */
8404 @ @<Test if the control points are confined to one quadrant or rotating...@>=
8405 simple = ((dx0>=0) && (dx1>=0) && (dx2>=0)) ||
8406 ((dx0<=0) && (dx1<=0) && (dx2<=0));
8408 simple = ((dy0>=0) && (dy1>=0) && (dy2>=0)) ||
8409 ((dy0<=0) && (dy1<=0) && (dy2<=0));
8411 simple = ((dx0>=dy0) && (dx1>=dy1) && (dx2>=dy2)) ||
8412 ((dx0<=dy0) && (dx1<=dy1) && (dx2<=dy2));
8414 simple = ((-dx0>=dy0) && (-dx1>=dy1) && (-dx2>=dy2)) ||
8415 ((-dx0<=dy0) && (-dx1<=dy1) && (-dx2<=dy2));
8418 @ Since Simpson's rule is based on approximating the integrand by a parabola,
8420 it is appropriate to use the same approximation to decide when the integral
8421 reaches the intermediate value |a_goal|. At this point
8423 {\vb\dot B(0)\vb\over 3} &= \hbox{|v0|}, \qquad
8424 {\vb\dot B({1\over4})\vb\over 3} = {\hbox{|v002|}\over 2}, \qquad
8425 {\vb\dot B({1\over2})\vb\over 3} = {\hbox{|v02|}\over 2}, \cr
8426 {\vb\dot B({3\over4})\vb\over 3} &= {\hbox{|v022|}\over 2}, \qquad
8427 {\vb\dot B(1)\vb\over 3} = \hbox{|v2|} \cr
8431 $$ {\vb\dot B(t)\vb\over 3} \approx
8432 \cases{B\left(\hbox{|v0|},
8433 \hbox{|v002|}-{1\over 2}\hbox{|v0|}-{1\over 4}\hbox{|v02|},
8434 {1\over 2}\hbox{|v02|}; 2t \right)&
8435 if $t\le{1\over 2}$\cr
8436 B\left({1\over 2}\hbox{|v02|},
8437 \hbox{|v022|}-{1\over 4}\hbox{|v02|}-{1\over 2}\hbox{|v2|},
8438 \hbox{|v2|}; 2t-1 \right)&
8439 if $t\ge{1\over 2}$.\cr}
8442 We can integrate $\vb\dot B(t)\vb$ by using
8443 $$\int 3B(a,b,c;\tau)\,dt =
8444 {B(0,a,a+b,a+b+c;\tau) + {\rm constant} \over {d\tau\over dt}}.
8447 This construction allows us to find the time when the arc length reaches
8448 |a_goal| by solving a cubic equation of the form
8449 $$ B(0,a,a+b,a+b+c;\tau) = x, $$
8450 where $\tau$ is $2t$ or $2t+1$, $x$ is |a_goal| or |a_goal-arc1|, and $a$, $b$,
8451 and $c$ are the Bernshte{\u\i}n coefficients from $(*)$ divided by
8452 @^Bernshte{\u\i}n, Serge{\u\i} Natanovich@>
8453 $d\tau\over dt$. We shall define a function |solve_rising_cubic| that finds
8454 $\tau$ given $a$, $b$, $c$, and $x$.
8456 @<Estimate when the arc length reaches |a_goal| and set |arc_test| to...@>=
8458 tmp = (v02 + 2) / 4;
8459 if ( a_goal<=arc1 ) {
8462 (halfp(mp_solve_rising_cubic(mp, tmp2, arc1-tmp2-tmp, tmp, a_goal))- two);
8465 return ((half_unit - two) +
8466 halfp(mp_solve_rising_cubic(mp, tmp, arc-arc1-tmp-tmp2, tmp2, a_goal-arc1)));
8470 @ Here is the |solve_rising_cubic| routine that finds the time~$t$ when
8471 $$ B(0, a, a+b, a+b+c; t) = x. $$
8472 This routine is based on |crossing_point| but is simplified by the
8473 assumptions that $B(a,b,c;t)\ge0$ for $0\le t\le1$ and that |0<=x<=a+b+c|.
8474 If rounding error causes this condition to be violated slightly, we just ignore
8475 it and proceed with binary search. This finds a time when the function value
8476 reaches |x| and the slope is positive.
8478 @<Declare subroutines needed by |arc_test|@>=
8479 scaled mp_solve_rising_cubic (MP mp,scaled a, scaled b, scaled c, scaled x) {
8480 scaled ab, bc, ac; /* bisection results */
8481 integer t; /* $2^k+q$ where unscaled answer is in $[q2^{-k},(q+1)2^{-k})$ */
8482 integer xx; /* temporary for updating |x| */
8483 if ( (a<0) || (c<0) ) mp_confusion(mp, "rising?");
8484 @:this can't happen rising?}{\quad rising?@>
8487 } else if ( x >= a+b+c ) {
8491 @<Rescale if necessary to make sure |a|, |b|, and |c| are all less than
8495 @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>;
8496 xx = x - a - ab - ac;
8497 if ( xx < -x ) { x+=x; b=ab; c=ac; }
8498 else { x = x + xx; a=ac; b=bc; t = t+1; };
8499 } while (t < unity);
8504 @ @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>=
8509 @ @d one_third_el_gordo 05252525252 /* upper bound on |a|, |b|, and |c| */
8511 @<Rescale if necessary to make sure |a|, |b|, and |c| are all less than...@>=
8512 while ((a>one_third_el_gordo)||(b>one_third_el_gordo)||(c>one_third_el_gordo)) {
8519 @ It is convenient to have a simpler interface to |arc_test| that requires no
8520 unnecessary arguments and ensures that each $({\it dx},{\it dy})$ pair has
8521 length less than |fraction_four|.
8523 @d arc_tol 16 /* quit when change in arc length estimate reaches this */
8525 @c scaled mp_do_arc_test (MP mp,scaled dx0, scaled dy0, scaled dx1,
8526 scaled dy1, scaled dx2, scaled dy2, scaled a_goal) {
8527 scaled v0,v1,v2; /* length of each $({\it dx},{\it dy})$ pair */
8528 scaled v02; /* twice the norm of the quadratic at $t={1\over2}$ */
8529 v0 = mp_pyth_add(mp, dx0,dy0);
8530 v1 = mp_pyth_add(mp, dx1,dy1);
8531 v2 = mp_pyth_add(mp, dx2,dy2);
8532 if ( (v0>=fraction_four) || (v1>=fraction_four) || (v2>=fraction_four) ) {
8533 mp->arith_error = true;
8534 if ( a_goal==el_gordo ) return el_gordo;
8537 v02 = mp_pyth_add(mp, dx1+half(dx0+dx2), dy1+half(dy0+dy2));
8538 return (mp_arc_test(mp, dx0,dy0, dx1,dy1, dx2,dy2,
8539 v0, v02, v2, a_goal, arc_tol));
8543 @ Now it is easy to find the arc length of an entire path.
8545 @c scaled mp_get_arc_length (MP mp,pointer h) {
8546 pointer p,q; /* for traversing the path */
8547 scaled a,a_tot; /* current and total arc lengths */
8550 while ( right_type(p)!=mp_endpoint ){
8552 a = mp_do_arc_test(mp, right_x(p)-x_coord(p), right_y(p)-y_coord(p),
8553 left_x(q)-right_x(p), left_y(q)-right_y(p),
8554 x_coord(q)-left_x(q), y_coord(q)-left_y(q), el_gordo);
8555 a_tot = mp_slow_add(mp, a, a_tot);
8556 if ( q==h ) break; else p=q;
8562 @ The inverse operation of finding the time on a path~|h| when the arc length
8563 reaches some value |arc0| can also be accomplished via |do_arc_test|. Some care
8564 is required to handle very large times or negative times on cyclic paths. For
8565 non-cyclic paths, |arc0| values that are negative or too large cause
8566 |get_arc_time| to return 0 or the length of path~|h|.
8568 If |arc0| is greater than the arc length of a cyclic path~|h|, the result is a
8569 time value greater than the length of the path. Since it could be much greater,
8570 we must be prepared to compute the arc length of path~|h| and divide this into
8571 |arc0| to find how many multiples of the length of path~|h| to add.
8573 @c scaled mp_get_arc_time (MP mp,pointer h, scaled arc0) {
8574 pointer p,q; /* for traversing the path */
8575 scaled t_tot; /* accumulator for the result */
8576 scaled t; /* the result of |do_arc_test| */
8577 scaled arc; /* portion of |arc0| not used up so far */
8578 integer n; /* number of extra times to go around the cycle */
8580 @<Deal with a negative |arc0| value and |return|@>;
8582 if ( arc0==el_gordo ) decr(arc0);
8586 while ( (right_type(p)!=mp_endpoint) && (arc>0) ) {
8588 t = mp_do_arc_test(mp, right_x(p)-x_coord(p), right_y(p)-y_coord(p),
8589 left_x(q)-right_x(p), left_y(q)-right_y(p),
8590 x_coord(q)-left_x(q), y_coord(q)-left_y(q), arc);
8591 @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>;
8593 @<Update |t_tot| and |arc| to avoid going around the cyclic
8594 path too many times but set |arith_error:=true| and |goto done| on
8603 @ @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>=
8604 if ( t<0 ) { t_tot = t_tot + t + two; arc = 0; }
8605 else { t_tot = t_tot + unity; arc = arc - t; }
8607 @ @<Deal with a negative |arc0| value and |return|@>=
8609 if ( left_type(h)==mp_endpoint ) {
8612 p = mp_htap_ypoc(mp, h);
8613 t_tot = -mp_get_arc_time(mp, p, -arc0);
8614 mp_toss_knot_list(mp, p);
8620 @ @<Update |t_tot| and |arc| to avoid going around the cyclic...@>=
8622 n = arc / (arc0 - arc);
8623 arc = arc - n*(arc0 - arc);
8624 if ( t_tot > (el_gordo / (n+1)) ) {
8627 t_tot = (n + 1)*t_tot;
8630 @* \[20] Data structures for pens.
8631 A Pen in \MP\ can be either elliptical or polygonal. Elliptical pens result
8632 in \ps\ \&{stroke} commands, while anything drawn with a polygonal pen is
8633 @:stroke}{\&{stroke} command@>
8634 converted into an area fill as described in the next part of this program.
8635 The mathematics behind this process is based on simple aspects of the theory
8636 of tracings developed by Leo Guibas, Lyle Ramshaw, and Jorge Stolfi
8637 [``A kinematic framework for computational geometry,'' Proc.\ IEEE Symp.\
8638 Foundations of Computer Science {\bf 24} (1983), 100--111].
8640 Polygonal pens are created from paths via \MP's \&{makepen} primitive.
8641 @:makepen_}{\&{makepen} primitive@>
8642 This path representation is almost sufficient for our purposes except that
8643 a pen path should always be a convex polygon with the vertices in
8644 counter-clockwise order.
8645 Since we will need to scan pen polygons both forward and backward, a pen
8646 should be represented as a doubly linked ring of knot nodes. There is
8647 room for the extra back pointer because we do not need the
8648 |left_type| or |right_type| fields. In fact, we don't need the |left_x|,
8649 |left_y|, |right_x|, or |right_y| fields either but we leave these alone
8650 so that certain procedures can operate on both pens and paths. In particular,
8651 pens can be copied using |copy_path| and recycled using |toss_knot_list|.
8654 /* this replaces the |left_type| and |right_type| fields in a pen knot */
8656 @ The |make_pen| procedure turns a path into a pen by initializing
8657 the |knil| pointers and making sure the knots form a convex polygon.
8658 Thus each cubic in the given path becomes a straight line and the control
8659 points are ignored. If the path is not cyclic, the ends are connected by a
8662 @d copy_pen(A) mp_make_pen(mp, mp_copy_path(mp, (A)),false)
8664 @c @<Declare a function called |convex_hull|@>
8665 pointer mp_make_pen (MP mp,pointer h, boolean need_hull) {
8666 pointer p,q; /* two consecutive knots */
8673 h=mp_convex_hull(mp, h);
8674 @<Make sure |h| isn't confused with an elliptical pen@>;
8679 @ The only information required about an elliptical pen is the overall
8680 transformation that has been applied to the original \&{pencircle}.
8681 @:pencircle_}{\&{pencircle} primitive@>
8682 Since it suffices to keep track of how the three points $(0,0)$, $(1,0)$,
8683 and $(0,1)$ are transformed, an elliptical pen can be stored in a single
8684 knot node and transformed as if it were a path.
8686 @d pen_is_elliptical(A) ((A)==link((A)))
8688 @c pointer mp_get_pen_circle (MP mp,scaled diam) {
8689 pointer h; /* the knot node to return */
8690 h=mp_get_node(mp, knot_node_size);
8691 link(h)=h; knil(h)=h;
8692 originator(h)=mp_program_code;
8693 x_coord(h)=0; y_coord(h)=0;
8694 left_x(h)=diam; left_y(h)=0;
8695 right_x(h)=0; right_y(h)=diam;
8699 @ If the polygon being returned by |make_pen| has only one vertex, it will
8700 be interpreted as an elliptical pen. This is no problem since a degenerate
8701 polygon can equally well be thought of as a degenerate ellipse. We need only
8702 initialize the |left_x|, |left_y|, |right_x|, and |right_y| fields.
8704 @<Make sure |h| isn't confused with an elliptical pen@>=
8705 if ( pen_is_elliptical( h) ){
8706 left_x(h)=x_coord(h); left_y(h)=y_coord(h);
8707 right_x(h)=x_coord(h); right_y(h)=y_coord(h);
8710 @ We have to cheat a little here but most operations on pens only use
8711 the first three words in each knot node.
8712 @^data structure assumptions@>
8714 @<Initialize a pen at |test_pen| so that it fits in nine words@>=
8715 x_coord(test_pen)=-half_unit;
8716 y_coord(test_pen)=0;
8717 x_coord(test_pen+3)=half_unit;
8718 y_coord(test_pen+3)=0;
8719 x_coord(test_pen+6)=0;
8720 y_coord(test_pen+6)=unity;
8721 link(test_pen)=test_pen+3;
8722 link(test_pen+3)=test_pen+6;
8723 link(test_pen+6)=test_pen;
8724 knil(test_pen)=test_pen+6;
8725 knil(test_pen+3)=test_pen;
8726 knil(test_pen+6)=test_pen+3
8728 @ Printing a polygonal pen is very much like printing a path
8730 @<Declare subroutines for printing expressions@>=
8731 void mp_pr_pen (MP mp,pointer h) {
8732 pointer p,q; /* for list traversal */
8733 if ( pen_is_elliptical(h) ) {
8734 @<Print the elliptical pen |h|@>;
8738 mp_print_two(mp, x_coord(p),y_coord(p));
8739 mp_print_nl(mp, " .. ");
8740 @<Advance |p| making sure the links are OK and |return| if there is
8743 mp_print(mp, "cycle");
8747 @ @<Advance |p| making sure the links are OK and |return| if there is...@>=
8749 if ( (q==null) || (knil(q)!=p) ) {
8750 mp_print_nl(mp, "???"); return; /* this won't happen */
8755 @ @<Print the elliptical pen |h|@>=
8757 mp_print(mp, "pencircle transformed (");
8758 mp_print_scaled(mp, x_coord(h));
8759 mp_print_char(mp, ',');
8760 mp_print_scaled(mp, y_coord(h));
8761 mp_print_char(mp, ',');
8762 mp_print_scaled(mp, left_x(h)-x_coord(h));
8763 mp_print_char(mp, ',');
8764 mp_print_scaled(mp, right_x(h)-x_coord(h));
8765 mp_print_char(mp, ',');
8766 mp_print_scaled(mp, left_y(h)-y_coord(h));
8767 mp_print_char(mp, ',');
8768 mp_print_scaled(mp, right_y(h)-y_coord(h));
8769 mp_print_char(mp, ')');
8772 @ Here us another version of |pr_pen| that prints the pen as a diagnostic
8775 @<Declare subroutines for printing expressions@>=
8776 void mp_print_pen (MP mp,pointer h, const char *s, boolean nuline) {
8777 mp_print_diagnostic(mp, "Pen",s,nuline); mp_print_ln(mp);
8780 mp_end_diagnostic(mp, true);
8783 @ Making a polygonal pen into a path involves restoring the |left_type| and
8784 |right_type| fields and setting the control points so as to make a polygonal
8788 void mp_make_path (MP mp,pointer h) {
8789 pointer p; /* for traversing the knot list */
8790 small_number k; /* a loop counter */
8791 @<Other local variables in |make_path|@>;
8792 if ( pen_is_elliptical(h) ) {
8793 @<Make the elliptical pen |h| into a path@>;
8797 left_type(p)=mp_explicit;
8798 right_type(p)=mp_explicit;
8799 @<copy the coordinates of knot |p| into its control points@>;
8805 @ @<copy the coordinates of knot |p| into its control points@>=
8806 left_x(p)=x_coord(p);
8807 left_y(p)=y_coord(p);
8808 right_x(p)=x_coord(p);
8809 right_y(p)=y_coord(p)
8811 @ We need an eight knot path to get a good approximation to an ellipse.
8813 @<Make the elliptical pen |h| into a path@>=
8815 @<Extract the transformation parameters from the elliptical pen~|h|@>;
8817 for (k=0;k<=7;k++ ) {
8818 @<Initialize |p| as the |k|th knot of a circle of unit diameter,
8819 transforming it appropriately@>;
8820 if ( k==7 ) link(p)=h; else link(p)=mp_get_node(mp, knot_node_size);
8825 @ @<Extract the transformation parameters from the elliptical pen~|h|@>=
8826 center_x=x_coord(h);
8827 center_y=y_coord(h);
8828 width_x=left_x(h)-center_x;
8829 width_y=left_y(h)-center_y;
8830 height_x=right_x(h)-center_x;
8831 height_y=right_y(h)-center_y
8833 @ @<Other local variables in |make_path|@>=
8834 scaled center_x,center_y; /* translation parameters for an elliptical pen */
8835 scaled width_x,width_y; /* the effect of a unit change in $x$ */
8836 scaled height_x,height_y; /* the effect of a unit change in $y$ */
8837 scaled dx,dy; /* the vector from knot |p| to its right control point */
8839 /* |k| advanced $270^\circ$ around the ring (cf. $\sin\theta=\cos(\theta+270)$) */
8841 @ The only tricky thing here are the tables |half_cos| and |d_cos| used to
8842 find the point $k/8$ of the way around the circle and the direction vector
8845 @<Initialize |p| as the |k|th knot of a circle of unit diameter,...@>=
8847 x_coord(p)=center_x+mp_take_fraction(mp, mp->half_cos[k],width_x)
8848 +mp_take_fraction(mp, mp->half_cos[kk],height_x);
8849 y_coord(p)=center_y+mp_take_fraction(mp, mp->half_cos[k],width_y)
8850 +mp_take_fraction(mp, mp->half_cos[kk],height_y);
8851 dx=-mp_take_fraction(mp, mp->d_cos[kk],width_x)
8852 +mp_take_fraction(mp, mp->d_cos[k],height_x);
8853 dy=-mp_take_fraction(mp, mp->d_cos[kk],width_y)
8854 +mp_take_fraction(mp, mp->d_cos[k],height_y);
8855 right_x(p)=x_coord(p)+dx;
8856 right_y(p)=y_coord(p)+dy;
8857 left_x(p)=x_coord(p)-dx;
8858 left_y(p)=y_coord(p)-dy;
8859 left_type(p)=mp_explicit;
8860 right_type(p)=mp_explicit;
8861 originator(p)=mp_program_code
8864 fraction half_cos[8]; /* ${1\over2}\cos(45k)$ */
8865 fraction d_cos[8]; /* a magic constant times $\cos(45k)$ */
8867 @ The magic constant for |d_cos| is the distance between $({1\over2},0)$ and
8868 $({1\over4}\sqrt2,{1\over4}\sqrt2)$ times the result of the |velocity|
8869 function for $\theta=\phi=22.5^\circ$. This comes out to be
8870 $$ d = {\sqrt{2-\sqrt2}\over 3+3\cos22.5^\circ}
8871 \approx 0.132608244919772.
8875 mp->half_cos[0]=fraction_half;
8876 mp->half_cos[1]=94906266; /* $2^{26}\sqrt2\approx94906265.62$ */
8878 mp->d_cos[0]=35596755; /* $2^{28}d\approx35596754.69$ */
8879 mp->d_cos[1]=25170707; /* $2^{27}\sqrt2\,d\approx25170706.63$ */
8881 for (k=3;k<= 4;k++ ) {
8882 mp->half_cos[k]=-mp->half_cos[4-k];
8883 mp->d_cos[k]=-mp->d_cos[4-k];
8885 for (k=5;k<= 7;k++ ) {
8886 mp->half_cos[k]=mp->half_cos[8-k];
8887 mp->d_cos[k]=mp->d_cos[8-k];
8890 @ The |convex_hull| function forces a pen polygon to be convex when it is
8891 returned by |make_pen| and after any subsequent transformation where rounding
8892 error might allow the convexity to be lost.
8893 The convex hull algorithm used here is described by F.~P. Preparata and
8894 M.~I. Shamos [{\sl Computational Geometry}, Springer-Verlag, 1985].
8896 @<Declare a function called |convex_hull|@>=
8897 @<Declare a procedure called |move_knot|@>
8898 pointer mp_convex_hull (MP mp,pointer h) { /* Make a polygonal pen convex */
8899 pointer l,r; /* the leftmost and rightmost knots */
8900 pointer p,q; /* knots being scanned */
8901 pointer s; /* the starting point for an upcoming scan */
8902 scaled dx,dy; /* a temporary pointer */
8903 if ( pen_is_elliptical(h) ) {
8906 @<Set |l| to the leftmost knot in polygon~|h|@>;
8907 @<Set |r| to the rightmost knot in polygon~|h|@>;
8910 @<Find any knots on the path from |l| to |r| above the |l|-|r| line and
8911 move them past~|r|@>;
8912 @<Find any knots on the path from |s| to |l| below the |l|-|r| line and
8913 move them past~|l|@>;
8914 @<Sort the path from |l| to |r| by increasing $x$@>;
8915 @<Sort the path from |r| to |l| by decreasing $x$@>;
8918 @<Do a Gramm scan and remove vertices where there is no left turn@>;
8924 @ All comparisons are done primarily on $x$ and secondarily on $y$.
8926 @<Set |l| to the leftmost knot in polygon~|h|@>=
8930 if ( x_coord(p)<=x_coord(l) )
8931 if ( (x_coord(p)<x_coord(l)) || (y_coord(p)<y_coord(l)) )
8936 @ @<Set |r| to the rightmost knot in polygon~|h|@>=
8940 if ( x_coord(p)>=x_coord(r) )
8941 if ( (x_coord(p)>x_coord(r)) || (y_coord(p)>y_coord(r)) )
8946 @ @<Find any knots on the path from |l| to |r| above the |l|-|r| line...@>=
8947 dx=x_coord(r)-x_coord(l);
8948 dy=y_coord(r)-y_coord(l);
8952 if ( mp_ab_vs_cd(mp, dx,y_coord(p)-y_coord(l),dy,x_coord(p)-x_coord(l))>0 )
8953 mp_move_knot(mp, p, r);
8957 @ The |move_knot| procedure removes |p| from a doubly linked list and inserts
8960 @ @<Declare a procedure called |move_knot|@>=
8961 void mp_move_knot (MP mp,pointer p, pointer q) {
8962 link(knil(p))=link(p);
8963 knil(link(p))=knil(p);
8970 @ @<Find any knots on the path from |s| to |l| below the |l|-|r| line...@>=
8974 if ( mp_ab_vs_cd(mp, dx,y_coord(p)-y_coord(l),dy,x_coord(p)-x_coord(l))<0 )
8975 mp_move_knot(mp, p,l);
8979 @ The list is likely to be in order already so we just do linear insertions.
8980 Secondary comparisons on $y$ ensure that the sort is consistent with the
8981 choice of |l| and |r|.
8983 @<Sort the path from |l| to |r| by increasing $x$@>=
8987 while ( x_coord(q)>x_coord(p) ) q=knil(q);
8988 while ( x_coord(q)==x_coord(p) ) {
8989 if ( y_coord(q)>y_coord(p) ) q=knil(q); else break;
8991 if ( q==knil(p) ) p=link(p);
8992 else { p=link(p); mp_move_knot(mp, knil(p),q); };
8995 @ @<Sort the path from |r| to |l| by decreasing $x$@>=
8999 while ( x_coord(q)<x_coord(p) ) q=knil(q);
9000 while ( x_coord(q)==x_coord(p) ) {
9001 if ( y_coord(q)<y_coord(p) ) q=knil(q); else break;
9003 if ( q==knil(p) ) p=link(p);
9004 else { p=link(p); mp_move_knot(mp, knil(p),q); };
9007 @ The condition involving |ab_vs_cd| tests if there is not a left turn
9008 at knot |q|. There usually will be a left turn so we streamline the case
9009 where the |then| clause is not executed.
9011 @<Do a Gramm scan and remove vertices where there...@>=
9015 dx=x_coord(q)-x_coord(p);
9016 dy=y_coord(q)-y_coord(p);
9020 if ( mp_ab_vs_cd(mp, dx,y_coord(q)-y_coord(p),dy,x_coord(q)-x_coord(p))<=0 ) {
9021 @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>;
9026 @ @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>=
9029 mp_free_node(mp, p,knot_node_size);
9030 link(s)=q; knil(q)=s;
9032 else { p=knil(s); q=s; };
9035 @ The |find_offset| procedure sets global variables |(cur_x,cur_y)| to the
9036 offset associated with the given direction |(x,y)|. If two different offsets
9037 apply, it chooses one of them.
9040 void mp_find_offset (MP mp,scaled x, scaled y, pointer h) {
9041 pointer p,q; /* consecutive knots */
9043 /* the transformation matrix for an elliptical pen */
9044 fraction xx,yy; /* untransformed offset for an elliptical pen */
9045 fraction d; /* a temporary register */
9046 if ( pen_is_elliptical(h) ) {
9047 @<Find the offset for |(x,y)| on the elliptical pen~|h|@>
9052 } while (!(mp_ab_vs_cd(mp, x_coord(q)-x_coord(p),y, y_coord(q)-y_coord(p),x)>=0));
9055 } while (!(mp_ab_vs_cd(mp, x_coord(q)-x_coord(p),y, y_coord(q)-y_coord(p),x)<=0));
9056 mp->cur_x=x_coord(p);
9057 mp->cur_y=y_coord(p);
9063 scaled cur_y; /* all-purpose return value registers */
9065 @ @<Find the offset for |(x,y)| on the elliptical pen~|h|@>=
9066 if ( (x==0) && (y==0) ) {
9067 mp->cur_x=x_coord(h); mp->cur_y=y_coord(h);
9069 @<Find the non-constant part of the transformation for |h|@>;
9070 while ( (abs(x)<fraction_half) && (abs(y)<fraction_half) ){
9073 @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the
9074 untransformed version of |(x,y)|@>;
9075 mp->cur_x=x_coord(h)+mp_take_fraction(mp, xx,wx)+mp_take_fraction(mp, yy,hx);
9076 mp->cur_y=y_coord(h)+mp_take_fraction(mp, xx,wy)+mp_take_fraction(mp, yy,hy);
9079 @ @<Find the non-constant part of the transformation for |h|@>=
9080 wx=left_x(h)-x_coord(h);
9081 wy=left_y(h)-y_coord(h);
9082 hx=right_x(h)-x_coord(h);
9083 hy=right_y(h)-y_coord(h)
9085 @ @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the...@>=
9086 yy=-(mp_take_fraction(mp, x,hy)+mp_take_fraction(mp, y,-hx));
9087 xx=mp_take_fraction(mp, x,-wy)+mp_take_fraction(mp, y,wx);
9088 d=mp_pyth_add(mp, xx,yy);
9090 xx=half(mp_make_fraction(mp, xx,d));
9091 yy=half(mp_make_fraction(mp, yy,d));
9094 @ Finding the bounding box of a pen is easy except if the pen is elliptical.
9095 But we can handle that case by just calling |find_offset| twice. The answer
9096 is stored in the global variables |minx|, |maxx|, |miny|, and |maxy|.
9099 void mp_pen_bbox (MP mp,pointer h) {
9100 pointer p; /* for scanning the knot list */
9101 if ( pen_is_elliptical(h) ) {
9102 @<Find the bounding box of an elliptical pen@>;
9104 minx=x_coord(h); maxx=minx;
9105 miny=y_coord(h); maxy=miny;
9108 if ( x_coord(p)<minx ) minx=x_coord(p);
9109 if ( y_coord(p)<miny ) miny=y_coord(p);
9110 if ( x_coord(p)>maxx ) maxx=x_coord(p);
9111 if ( y_coord(p)>maxy ) maxy=y_coord(p);
9117 @ @<Find the bounding box of an elliptical pen@>=
9119 mp_find_offset(mp, 0,fraction_one,h);
9121 minx=2*x_coord(h)-mp->cur_x;
9122 mp_find_offset(mp, -fraction_one,0,h);
9124 miny=2*y_coord(h)-mp->cur_y;
9127 @* \[21] Edge structures.
9128 Now we come to \MP's internal scheme for representing pictures.
9129 The representation is very different from \MF's edge structures
9130 because \MP\ pictures contain \ps\ graphics objects instead of pixel
9131 images. However, the basic idea is somewhat similar in that shapes
9132 are represented via their boundaries.
9134 The main purpose of edge structures is to keep track of graphical objects
9135 until it is time to translate them into \ps. Since \MP\ does not need to
9136 know anything about an edge structure other than how to translate it into
9137 \ps\ and how to find its bounding box, edge structures can be just linked
9138 lists of graphical objects. \MP\ has no easy way to determine whether
9139 two such objects overlap, but it suffices to draw the first one first and
9140 let the second one overwrite it if necessary.
9143 enum mp_graphical_object_code {
9144 @<Graphical object codes@>
9148 @ Let's consider the types of graphical objects one at a time.
9149 First of all, a filled contour is represented by a eight-word node. The first
9150 word contains |type| and |link| fields, and the next six words contain a
9151 pointer to a cyclic path and the value to use for \ps' \&{currentrgbcolor}
9152 parameter. If a pen is used for filling |pen_p|, |ljoin_val| and |miterlim_val|
9153 give the relevant information.
9155 @d path_p(A) link((A)+1)
9156 /* a pointer to the path that needs filling */
9157 @d pen_p(A) info((A)+1)
9158 /* a pointer to the pen to fill or stroke with */
9159 @d color_model(A) type((A)+2) /* the color model */
9160 @d obj_red_loc(A) ((A)+3) /* the first of three locations for the color */
9161 @d obj_cyan_loc obj_red_loc /* the first of four locations for the color */
9162 @d obj_grey_loc obj_red_loc /* the location for the color */
9163 @d red_val(A) mp->mem[(A)+3].sc
9164 /* the red component of the color in the range $0\ldots1$ */
9167 @d green_val(A) mp->mem[(A)+4].sc
9168 /* the green component of the color in the range $0\ldots1$ */
9169 @d magenta_val green_val
9170 @d blue_val(A) mp->mem[(A)+5].sc
9171 /* the blue component of the color in the range $0\ldots1$ */
9172 @d yellow_val blue_val
9173 @d black_val(A) mp->mem[(A)+6].sc
9174 /* the blue component of the color in the range $0\ldots1$ */
9175 @d ljoin_val(A) name_type((A)) /* the value of \&{linejoin} */
9176 @:mp_linejoin_}{\&{linejoin} primitive@>
9177 @d miterlim_val(A) mp->mem[(A)+7].sc /* the value of \&{miterlimit} */
9178 @:mp_miterlimit_}{\&{miterlimit} primitive@>
9179 @d obj_color_part(A) mp->mem[(A)+3-red_part].sc
9180 /* interpret an object pointer that has been offset by |red_part..blue_part| */
9181 @d pre_script(A) mp->mem[(A)+8].hh.lh
9182 @d post_script(A) mp->mem[(A)+8].hh.rh
9185 @ @<Graphical object codes@>=
9189 pointer mp_new_fill_node (MP mp,pointer p) {
9190 /* make a fill node for cyclic path |p| and color black */
9191 pointer t; /* the new node */
9192 t=mp_get_node(mp, fill_node_size);
9193 type(t)=mp_fill_code;
9195 pen_p(t)=null; /* |null| means don't use a pen */
9200 color_model(t)=mp_uninitialized_model;
9202 post_script(t)=null;
9203 @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>;
9207 @ @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>=
9208 if ( mp->internal[mp_linejoin]>unity ) ljoin_val(t)=2;
9209 else if ( mp->internal[mp_linejoin]>0 ) ljoin_val(t)=1;
9210 else ljoin_val(t)=0;
9211 if ( mp->internal[mp_miterlimit]<unity )
9212 miterlim_val(t)=unity;
9214 miterlim_val(t)=mp->internal[mp_miterlimit]
9216 @ A stroked path is represented by an eight-word node that is like a filled
9217 contour node except that it contains the current \&{linecap} value, a scale
9218 factor for the dash pattern, and a pointer that is non-null if the stroke
9219 is to be dashed. The purpose of the scale factor is to allow a picture to
9220 be transformed without touching the picture that |dash_p| points to.
9222 @d dash_p(A) link((A)+9)
9223 /* a pointer to the edge structure that gives the dash pattern */
9224 @d lcap_val(A) type((A)+9)
9225 /* the value of \&{linecap} */
9226 @:mp_linecap_}{\&{linecap} primitive@>
9227 @d dash_scale(A) mp->mem[(A)+10].sc /* dash lengths are scaled by this factor */
9228 @d stroked_node_size 11
9230 @ @<Graphical object codes@>=
9234 pointer mp_new_stroked_node (MP mp,pointer p) {
9235 /* make a stroked node for path |p| with |pen_p(p)| temporarily |null| */
9236 pointer t; /* the new node */
9237 t=mp_get_node(mp, stroked_node_size);
9238 type(t)=mp_stroked_code;
9239 path_p(t)=p; pen_p(t)=null;
9241 dash_scale(t)=unity;
9246 color_model(t)=mp_uninitialized_model;
9248 post_script(t)=null;
9249 @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>;
9250 if ( mp->internal[mp_linecap]>unity ) lcap_val(t)=2;
9251 else if ( mp->internal[mp_linecap]>0 ) lcap_val(t)=1;
9256 @ When a dashed line is computed in a transformed coordinate system, the dash
9257 lengths get scaled like the pen shape and we need to compensate for this. Since
9258 there is no unique scale factor for an arbitrary transformation, we use the
9259 the square root of the determinant. The properties of the determinant make it
9260 easier to maintain the |dash_scale|. The computation is fairly straight-forward
9261 except for the initialization of the scale factor |s|. The factor of 64 is
9262 needed because |square_rt| scales its result by $2^8$ while we need $2^{14}$
9263 to counteract the effect of |take_fraction|.
9265 @<Declare subroutines needed by |print_edges|@>=
9266 scaled mp_sqrt_det (MP mp,scaled a, scaled b, scaled c, scaled d) {
9267 scaled maxabs; /* $max(|a|,|b|,|c|,|d|)$ */
9268 integer s; /* amount by which the result of |square_rt| needs to be scaled */
9269 @<Initialize |maxabs|@>;
9271 while ( (maxabs<fraction_one) && (s>1) ){
9272 a+=a; b+=b; c+=c; d+=d;
9273 maxabs+=maxabs; s=halfp(s);
9275 return s*mp_square_rt(mp, abs(mp_take_fraction(mp, a,d)-mp_take_fraction(mp, b,c)));
9278 scaled mp_get_pen_scale (MP mp,pointer p) {
9279 return mp_sqrt_det(mp,
9280 left_x(p)-x_coord(p), right_x(p)-x_coord(p),
9281 left_y(p)-y_coord(p), right_y(p)-y_coord(p));
9284 @ @<Internal library ...@>=
9285 scaled mp_sqrt_det (MP mp,scaled a, scaled b, scaled c, scaled d) ;
9288 @ @<Initialize |maxabs|@>=
9290 if ( abs(b)>maxabs ) maxabs=abs(b);
9291 if ( abs(c)>maxabs ) maxabs=abs(c);
9292 if ( abs(d)>maxabs ) maxabs=abs(d)
9294 @ When a picture contains text, this is represented by a fourteen-word node
9295 where the color information and |type| and |link| fields are augmented by
9296 additional fields that describe the text and how it is transformed.
9297 The |path_p| and |pen_p| pointers are replaced by a number that identifies
9298 the font and a string number that gives the text to be displayed.
9299 The |width|, |height|, and |depth| fields
9300 give the dimensions of the text at its design size, and the remaining six
9301 words give a transformation to be applied to the text. The |new_text_node|
9302 function initializes everything to default values so that the text comes out
9303 black with its reference point at the origin.
9305 @d text_p(A) link((A)+1) /* a string pointer for the text to display */
9306 @d font_n(A) info((A)+1) /* the font number */
9307 @d width_val(A) mp->mem[(A)+7].sc /* unscaled width of the text */
9308 @d height_val(A) mp->mem[(A)+9].sc /* unscaled height of the text */
9309 @d depth_val(A) mp->mem[(A)+10].sc /* unscaled depth of the text */
9310 @d text_tx_loc(A) ((A)+11)
9311 /* the first of six locations for transformation parameters */
9312 @d tx_val(A) mp->mem[(A)+11].sc /* $x$ shift amount */
9313 @d ty_val(A) mp->mem[(A)+12].sc /* $y$ shift amount */
9314 @d txx_val(A) mp->mem[(A)+13].sc /* |txx| transformation parameter */
9315 @d txy_val(A) mp->mem[(A)+14].sc /* |txy| transformation parameter */
9316 @d tyx_val(A) mp->mem[(A)+15].sc /* |tyx| transformation parameter */
9317 @d tyy_val(A) mp->mem[(A)+16].sc /* |tyy| transformation parameter */
9318 @d text_trans_part(A) mp->mem[(A)+11-x_part].sc
9319 /* interpret a text node pointer that has been offset by |x_part..yy_part| */
9320 @d text_node_size 17
9322 @ @<Graphical object codes@>=
9325 @ @c @<Declare text measuring subroutines@>
9326 pointer mp_new_text_node (MP mp,char *f,str_number s) {
9327 /* make a text node for font |f| and text string |s| */
9328 pointer t; /* the new node */
9329 t=mp_get_node(mp, text_node_size);
9330 type(t)=mp_text_code;
9332 font_n(t)=mp_find_font(mp, f); /* this identifies the font */
9337 color_model(t)=mp_uninitialized_model;
9339 post_script(t)=null;
9340 tx_val(t)=0; ty_val(t)=0;
9341 txx_val(t)=unity; txy_val(t)=0;
9342 tyx_val(t)=0; tyy_val(t)=unity;
9343 mp_set_text_box(mp, t); /* this finds the bounding box */
9347 @ The last two types of graphical objects that can occur in an edge structure
9348 are clipping paths and \&{setbounds} paths. These are slightly more difficult
9349 @:set_bounds_}{\&{setbounds} primitive@>
9350 to implement because we must keep track of exactly what is being clipped or
9351 bounded when pictures get merged together. For this reason, each clipping or
9352 \&{setbounds} operation is represented by a pair of nodes: first comes a
9353 two-word node whose |path_p| gives the relevant path, then there is the list
9354 of objects to clip or bound followed by a two-word node whose second word is
9357 Using at least two words for each graphical object node allows them all to be
9358 allocated and deallocated similarly with a global array |gr_object_size| to
9359 give the size in words for each object type.
9361 @d start_clip_size 2
9362 @d start_bounds_size 2
9363 @d stop_clip_size 2 /* the second word is not used here */
9364 @d stop_bounds_size 2 /* the second word is not used here */
9366 @d stop_type(A) ((A)+2)
9367 /* matching |type| for |start_clip_code| or |start_bounds_code| */
9368 @d has_color(A) (type((A))<mp_start_clip_code)
9369 /* does a graphical object have color fields? */
9370 @d has_pen(A) (type((A))<mp_text_code)
9371 /* does a graphical object have a |pen_p| field? */
9372 @d is_start_or_stop(A) (type((A))>=mp_start_clip_code)
9373 @d is_stop(A) (type((A))>=mp_stop_clip_code)
9375 @ @<Graphical object codes@>=
9376 mp_start_clip_code=4, /* |type| of a node that starts clipping */
9377 mp_start_bounds_code=5, /* |type| of a node that gives a \&{setbounds} path */
9378 mp_stop_clip_code=6, /* |type| of a node that stops clipping */
9379 mp_stop_bounds_code=7, /* |type| of a node that stops \&{setbounds} */
9382 pointer mp_new_bounds_node (MP mp,pointer p, small_number c) {
9383 /* make a node of type |c| where |p| is the clipping or \&{setbounds} path */
9384 pointer t; /* the new node */
9385 t=mp_get_node(mp, mp->gr_object_size[c]);
9391 @ We need an array to keep track of the sizes of graphical objects.
9394 small_number gr_object_size[mp_stop_bounds_code+1];
9397 mp->gr_object_size[mp_fill_code]=fill_node_size;
9398 mp->gr_object_size[mp_stroked_code]=stroked_node_size;
9399 mp->gr_object_size[mp_text_code]=text_node_size;
9400 mp->gr_object_size[mp_start_clip_code]=start_clip_size;
9401 mp->gr_object_size[mp_stop_clip_code]=stop_clip_size;
9402 mp->gr_object_size[mp_start_bounds_code]=start_bounds_size;
9403 mp->gr_object_size[mp_stop_bounds_code]=stop_bounds_size;
9405 @ All the essential information in an edge structure is encoded as a linked list
9406 of graphical objects as we have just seen, but it is helpful to add some
9407 redundant information. A single edge structure might be used as a dash pattern
9408 many times, and it would be nice to avoid scanning the same structure
9409 repeatedly. Thus, an edge structure known to be a suitable dash pattern
9410 has a header that gives a list of dashes in a sorted order designed for rapid
9411 translation into \ps.
9413 Each dash is represented by a three-word node containing the initial and final
9414 $x$~coordinates as well as the usual |link| field. The |link| fields points to
9415 the dash node with the next higher $x$-coordinates and the final link points
9416 to a special location called |null_dash|. (There should be no overlap between
9417 dashes). Since the $y$~coordinate of the dash pattern is needed to determine
9418 the period of repetition, this needs to be stored in the edge header along
9419 with a pointer to the list of dash nodes.
9421 @d start_x(A) mp->mem[(A)+1].sc /* the starting $x$~coordinate in a dash node */
9422 @d stop_x(A) mp->mem[(A)+2].sc /* the ending $x$~coordinate in a dash node */
9425 /* in an edge header this points to the first dash node */
9426 @d dash_y(A) mp->mem[(A)+1].sc /* $y$ value for the dash list in an edge header */
9428 @ It is also convenient for an edge header to contain the bounding
9429 box information needed by the \&{llcorner} and \&{urcorner} operators
9430 so that this does not have to be recomputed unnecessarily. This is done by
9431 adding fields for the $x$~and $y$ extremes as well as a pointer that indicates
9432 how far the bounding box computation has gotten. Thus if the user asks for
9433 the bounding box and then adds some more text to the picture before asking
9434 for more bounding box information, the second computation need only look at
9435 the additional text.
9437 When the bounding box has not been computed, the |bblast| pointer points
9438 to a dummy link at the head of the graphical object list while the |minx_val|
9439 and |miny_val| fields contain |el_gordo| and the |maxx_val| and |maxy_val|
9440 fields contain |-el_gordo|.
9442 Since the bounding box of pictures containing objects of type
9443 |mp_start_bounds_code| depends on the value of \&{truecorners}, the bounding box
9444 @:mp_true_corners_}{\&{truecorners} primitive@>
9445 data might not be valid for all values of this parameter. Hence, the |bbtype|
9446 field is needed to keep track of this.
9448 @d minx_val(A) mp->mem[(A)+2].sc
9449 @d miny_val(A) mp->mem[(A)+3].sc
9450 @d maxx_val(A) mp->mem[(A)+4].sc
9451 @d maxy_val(A) mp->mem[(A)+5].sc
9452 @d bblast(A) link((A)+6) /* last item considered in bounding box computation */
9453 @d bbtype(A) info((A)+6) /* tells how bounding box data depends on \&{truecorners} */
9454 @d dummy_loc(A) ((A)+7) /* where the object list begins in an edge header */
9456 /* |bbtype| value when bounding box data is valid for all \&{truecorners} values */
9458 /* |bbtype| value when bounding box data is for \&{truecorners}${}\le 0$ */
9460 /* |bbtype| value when bounding box data is for \&{truecorners}${}>0$ */
9463 void mp_init_bbox (MP mp,pointer h) {
9464 /* Initialize the bounding box information in edge structure |h| */
9465 bblast(h)=dummy_loc(h);
9466 bbtype(h)=no_bounds;
9467 minx_val(h)=el_gordo;
9468 miny_val(h)=el_gordo;
9469 maxx_val(h)=-el_gordo;
9470 maxy_val(h)=-el_gordo;
9473 @ The only other entries in an edge header are a reference count in the first
9474 word and a pointer to the tail of the object list in the last word.
9476 @d obj_tail(A) info((A)+7) /* points to the last entry in the object list */
9477 @d edge_header_size 8
9480 void mp_init_edges (MP mp,pointer h) {
9481 /* initialize an edge header to null values */
9482 dash_list(h)=null_dash;
9483 obj_tail(h)=dummy_loc(h);
9484 link(dummy_loc(h))=null;
9486 mp_init_bbox(mp, h);
9489 @ Here is how edge structures are deleted. The process can be recursive because
9490 of the need to dereference edge structures that are used as dash patterns.
9493 @d add_edge_ref(A) incr(ref_count(A))
9494 @d delete_edge_ref(A) {
9495 if ( ref_count((A))==null )
9496 mp_toss_edges(mp, A);
9501 @<Declare the recycling subroutines@>=
9502 void mp_flush_dash_list (MP mp,pointer h);
9503 pointer mp_toss_gr_object (MP mp,pointer p) ;
9504 void mp_toss_edges (MP mp,pointer h) ;
9506 @ @c void mp_toss_edges (MP mp,pointer h) {
9507 pointer p,q; /* pointers that scan the list being recycled */
9508 pointer r; /* an edge structure that object |p| refers to */
9509 mp_flush_dash_list(mp, h);
9510 q=link(dummy_loc(h));
9511 while ( (q!=null) ) {
9513 r=mp_toss_gr_object(mp, p);
9514 if ( r!=null ) delete_edge_ref(r);
9516 mp_free_node(mp, h,edge_header_size);
9518 void mp_flush_dash_list (MP mp,pointer h) {
9519 pointer p,q; /* pointers that scan the list being recycled */
9521 while ( q!=null_dash ) {
9523 mp_free_node(mp, p,dash_node_size);
9525 dash_list(h)=null_dash;
9527 pointer mp_toss_gr_object (MP mp,pointer p) {
9528 /* returns an edge structure that needs to be dereferenced */
9529 pointer e; /* the edge structure to return */
9531 @<Prepare to recycle graphical object |p|@>;
9532 mp_free_node(mp, p,mp->gr_object_size[type(p)]);
9536 @ @<Prepare to recycle graphical object |p|@>=
9539 mp_toss_knot_list(mp, path_p(p));
9540 if ( pen_p(p)!=null ) mp_toss_knot_list(mp, pen_p(p));
9541 if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
9542 if ( post_script(p)!=null ) delete_str_ref(post_script(p));
9544 case mp_stroked_code:
9545 mp_toss_knot_list(mp, path_p(p));
9546 if ( pen_p(p)!=null ) mp_toss_knot_list(mp, pen_p(p));
9547 if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
9548 if ( post_script(p)!=null ) delete_str_ref(post_script(p));
9552 delete_str_ref(text_p(p));
9553 if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
9554 if ( post_script(p)!=null ) delete_str_ref(post_script(p));
9556 case mp_start_clip_code:
9557 case mp_start_bounds_code:
9558 mp_toss_knot_list(mp, path_p(p));
9560 case mp_stop_clip_code:
9561 case mp_stop_bounds_code:
9563 } /* there are no other cases */
9565 @ If we use |add_edge_ref| to ``copy'' edge structures, the real copying needs
9566 to be done before making a significant change to an edge structure. Much of
9567 the work is done in a separate routine |copy_objects| that copies a list of
9568 graphical objects into a new edge header.
9570 @c @<Declare a function called |copy_objects|@>
9571 pointer mp_private_edges (MP mp,pointer h) {
9572 /* make a private copy of the edge structure headed by |h| */
9573 pointer hh; /* the edge header for the new copy */
9574 pointer p,pp; /* pointers for copying the dash list */
9575 if ( ref_count(h)==null ) {
9579 hh=mp_copy_objects(mp, link(dummy_loc(h)),null);
9580 @<Copy the dash list from |h| to |hh|@>;
9581 @<Copy the bounding box information from |h| to |hh| and make |bblast(hh)|
9582 point into the new object list@>;
9587 @ Here we use the fact that |dash_list(hh)=link(hh)|.
9588 @^data structure assumptions@>
9590 @<Copy the dash list from |h| to |hh|@>=
9591 pp=hh; p=dash_list(h);
9592 while ( (p!=null_dash) ) {
9593 link(pp)=mp_get_node(mp, dash_node_size);
9595 start_x(pp)=start_x(p);
9596 stop_x(pp)=stop_x(p);
9600 dash_y(hh)=dash_y(h)
9603 @ |h| is an edge structure
9606 mp_dash_object *mp_export_dashes (MP mp, pointer q, scaled *w) {
9609 scaled scf; /* scale factor */
9610 scaled *dashes = NULL;
9613 if (h==null || dash_list(h)==null_dash)
9616 scf=mp_get_pen_scale(mp, pen_p(q));
9618 if (*w==0) scf = dash_scale(q); else return NULL;
9620 scf=mp_make_scaled(mp, *w,scf);
9621 scf=mp_take_scaled(mp, scf,dash_scale(q));
9624 d = mp_xmalloc(mp,1,sizeof(mp_dash_object));
9625 start_x(null_dash)=start_x(p)+dash_y(h);
9626 while (p != null_dash) {
9627 dashes = mp_xrealloc(mp, dashes, num_dashes+2, sizeof(scaled));
9628 dashes[(num_dashes-1)] =
9629 mp_take_scaled(mp,(stop_x(p)-start_x(p)),scf);
9630 dashes[(num_dashes)] =
9631 mp_take_scaled(mp,(start_x(link(p))-stop_x(p)),scf);
9632 dashes[(num_dashes+1)] = -1; /* terminus */
9636 d->array_field = dashes;
9638 mp_take_scaled(mp,mp_dash_offset(mp, h),scf);
9644 @ @<Copy the bounding box information from |h| to |hh|...@>=
9645 minx_val(hh)=minx_val(h);
9646 miny_val(hh)=miny_val(h);
9647 maxx_val(hh)=maxx_val(h);
9648 maxy_val(hh)=maxy_val(h);
9649 bbtype(hh)=bbtype(h);
9650 p=dummy_loc(h); pp=dummy_loc(hh);
9651 while ((p!=bblast(h)) ) {
9652 if ( p==null ) mp_confusion(mp, "bblast");
9653 @:this can't happen bblast}{\quad bblast@>
9654 p=link(p); pp=link(pp);
9658 @ Here is the promised routine for copying graphical objects into a new edge
9659 structure. It starts copying at object~|p| and stops just before object~|q|.
9660 If |q| is null, it copies the entire sublist headed at |p|. The resulting edge
9661 structure requires further initialization by |init_bbox|.
9663 @<Declare a function called |copy_objects|@>=
9664 pointer mp_copy_objects (MP mp, pointer p, pointer q) {
9665 pointer hh; /* the new edge header */
9666 pointer pp; /* the last newly copied object */
9667 small_number k; /* temporary register */
9668 hh=mp_get_node(mp, edge_header_size);
9669 dash_list(hh)=null_dash;
9673 @<Make |link(pp)| point to a copy of object |p|, and update |p| and |pp|@>;
9680 @ @<Make |link(pp)| point to a copy of object |p|, and update |p| and |pp|@>=
9681 { k=mp->gr_object_size[type(p)];
9682 link(pp)=mp_get_node(mp, k);
9684 while ( (k>0) ) { decr(k); mp->mem[pp+k]=mp->mem[p+k]; };
9685 @<Fix anything in graphical object |pp| that should differ from the
9686 corresponding field in |p|@>;
9690 @ @<Fix anything in graphical object |pp| that should differ from the...@>=
9692 case mp_start_clip_code:
9693 case mp_start_bounds_code:
9694 path_p(pp)=mp_copy_path(mp, path_p(p));
9697 path_p(pp)=mp_copy_path(mp, path_p(p));
9698 if ( pre_script(p)!=null ) add_str_ref(pre_script(p));
9699 if ( post_script(p)!=null ) add_str_ref(post_script(p));
9700 if ( pen_p(p)!=null ) pen_p(pp)=copy_pen(pen_p(p));
9702 case mp_stroked_code:
9703 if ( pre_script(p)!=null ) add_str_ref(pre_script(p));
9704 if ( post_script(p)!=null ) add_str_ref(post_script(p));
9705 path_p(pp)=mp_copy_path(mp, path_p(p));
9706 pen_p(pp)=copy_pen(pen_p(p));
9707 if ( dash_p(p)!=null ) add_edge_ref(dash_p(pp));
9710 if ( pre_script(p)!=null ) add_str_ref(pre_script(p));
9711 if ( post_script(p)!=null ) add_str_ref(post_script(p));
9712 add_str_ref(text_p(pp));
9714 case mp_stop_clip_code:
9715 case mp_stop_bounds_code:
9717 } /* there are no other cases */
9719 @ Here is one way to find an acceptable value for the second argument to
9720 |copy_objects|. Given a non-null graphical object list, |skip_1component|
9721 skips past one picture component, where a ``picture component'' is a single
9722 graphical object, or a start bounds or start clip object and everything up
9723 through the matching stop bounds or stop clip object. The macro version avoids
9724 procedure call overhead and error handling: |skip_component(p)(e)| advances |p|
9725 unless |p| points to a stop bounds or stop clip node, in which case it executes
9728 @d skip_component(A)
9729 if ( ! is_start_or_stop((A)) ) (A)=link((A));
9730 else if ( ! is_stop((A)) ) (A)=mp_skip_1component(mp, (A));
9734 pointer mp_skip_1component (MP mp,pointer p) {
9735 integer lev; /* current nesting level */
9738 if ( is_start_or_stop(p) ) {
9739 if ( is_stop(p) ) decr(lev); else incr(lev);
9746 @ Here is a diagnostic routine for printing an edge structure in symbolic form.
9748 @<Declare subroutines for printing expressions@>=
9749 @<Declare subroutines needed by |print_edges|@>
9750 void mp_print_edges (MP mp,pointer h, const char *s, boolean nuline) {
9751 pointer p; /* a graphical object to be printed */
9752 pointer hh,pp; /* temporary pointers */
9753 scaled scf; /* a scale factor for the dash pattern */
9754 boolean ok_to_dash; /* |false| for polygonal pen strokes */
9755 mp_print_diagnostic(mp, "Edge structure",s,nuline);
9757 while ( link(p)!=null ) {
9761 @<Cases for printing graphical object node |p|@>;
9763 mp_print(mp, "[unknown object type!]");
9767 mp_print_nl(mp, "End edges");
9768 if ( p!=obj_tail(h) ) mp_print(mp, "?");
9770 mp_end_diagnostic(mp, true);
9773 @ @<Cases for printing graphical object node |p|@>=
9775 mp_print(mp, "Filled contour ");
9776 mp_print_obj_color(mp, p);
9777 mp_print_char(mp, ':'); mp_print_ln(mp);
9778 mp_pr_path(mp, path_p(p)); mp_print_ln(mp);
9779 if ( (pen_p(p)!=null) ) {
9780 @<Print join type for graphical object |p|@>;
9781 mp_print(mp, " with pen"); mp_print_ln(mp);
9782 mp_pr_pen(mp, pen_p(p));
9786 @ @<Print join type for graphical object |p|@>=
9787 switch (ljoin_val(p)) {
9789 mp_print(mp, "mitered joins limited ");
9790 mp_print_scaled(mp, miterlim_val(p));
9793 mp_print(mp, "round joins");
9796 mp_print(mp, "beveled joins");
9799 mp_print(mp, "?? joins");
9804 @ For stroked nodes, we need to print |lcap_val(p)| as well.
9806 @<Print join and cap types for stroked node |p|@>=
9807 switch (lcap_val(p)) {
9808 case 0:mp_print(mp, "butt"); break;
9809 case 1:mp_print(mp, "round"); break;
9810 case 2:mp_print(mp, "square"); break;
9811 default: mp_print(mp, "??"); break;
9814 mp_print(mp, " ends, ");
9815 @<Print join type for graphical object |p|@>
9817 @ Here is a routine that prints the color of a graphical object if it isn't
9818 black (the default color).
9820 @<Declare subroutines needed by |print_edges|@>=
9821 @<Declare a procedure called |print_compact_node|@>
9822 void mp_print_obj_color (MP mp,pointer p) {
9823 if ( color_model(p)==mp_grey_model ) {
9824 if ( grey_val(p)>0 ) {
9825 mp_print(mp, "greyed ");
9826 mp_print_compact_node(mp, obj_grey_loc(p),1);
9828 } else if ( color_model(p)==mp_cmyk_model ) {
9829 if ( (cyan_val(p)>0) || (magenta_val(p)>0) ||
9830 (yellow_val(p)>0) || (black_val(p)>0) ) {
9831 mp_print(mp, "processcolored ");
9832 mp_print_compact_node(mp, obj_cyan_loc(p),4);
9834 } else if ( color_model(p)==mp_rgb_model ) {
9835 if ( (red_val(p)>0) || (green_val(p)>0) || (blue_val(p)>0) ) {
9836 mp_print(mp, "colored ");
9837 mp_print_compact_node(mp, obj_red_loc(p),3);
9842 @ We also need a procedure for printing consecutive scaled values as if they
9843 were a known big node.
9845 @<Declare a procedure called |print_compact_node|@>=
9846 void mp_print_compact_node (MP mp,pointer p, small_number k) {
9847 pointer q; /* last location to print */
9849 mp_print_char(mp, '(');
9851 mp_print_scaled(mp, mp->mem[p].sc);
9852 if ( p<q ) mp_print_char(mp, ',');
9855 mp_print_char(mp, ')');
9858 @ @<Cases for printing graphical object node |p|@>=
9859 case mp_stroked_code:
9860 mp_print(mp, "Filled pen stroke ");
9861 mp_print_obj_color(mp, p);
9862 mp_print_char(mp, ':'); mp_print_ln(mp);
9863 mp_pr_path(mp, path_p(p));
9864 if ( dash_p(p)!=null ) {
9865 mp_print_nl(mp, "dashed (");
9866 @<Finish printing the dash pattern that |p| refers to@>;
9869 @<Print join and cap types for stroked node |p|@>;
9870 mp_print(mp, " with pen"); mp_print_ln(mp);
9871 if ( pen_p(p)==null ) mp_print(mp, "???"); /* shouldn't happen */
9873 else mp_pr_pen(mp, pen_p(p));
9876 @ Normally, the |dash_list| field in an edge header is set to |null_dash|
9877 when it is not known to define a suitable dash pattern. This is disallowed
9878 here because the |dash_p| field should never point to such an edge header.
9879 Note that memory is allocated for |start_x(null_dash)| and we are free to
9880 give it any convenient value.
9882 @<Finish printing the dash pattern that |p| refers to@>=
9883 ok_to_dash=pen_is_elliptical(pen_p(p));
9884 if ( ! ok_to_dash ) scf=unity; else scf=dash_scale(p);
9887 if ( (pp==null_dash) || (dash_y(hh)<0) ) {
9888 mp_print(mp, " ??");
9889 } else { start_x(null_dash)=start_x(pp)+dash_y(hh);
9890 while ( pp!=null_dash ) {
9891 mp_print(mp, "on ");
9892 mp_print_scaled(mp, mp_take_scaled(mp, stop_x(pp)-start_x(pp),scf));
9893 mp_print(mp, " off ");
9894 mp_print_scaled(mp, mp_take_scaled(mp, start_x(link(pp))-stop_x(pp),scf));
9896 if ( pp!=null_dash ) mp_print_char(mp, ' ');
9898 mp_print(mp, ") shifted ");
9899 mp_print_scaled(mp, -mp_take_scaled(mp, mp_dash_offset(mp, hh),scf));
9900 if ( ! ok_to_dash || (dash_y(hh)==0) ) mp_print(mp, " (this will be ignored)");
9903 @ @<Declare subroutines needed by |print_edges|@>=
9904 scaled mp_dash_offset (MP mp,pointer h) {
9905 scaled x; /* the answer */
9906 if (dash_list(h)==null_dash || dash_y(h)<0) mp_confusion(mp, "dash0");
9907 @:this can't happen dash0}{\quad dash0@>
9908 if ( dash_y(h)==0 ) {
9911 x=-(start_x(dash_list(h)) % dash_y(h));
9912 if ( x<0 ) x=x+dash_y(h);
9917 @ @<Cases for printing graphical object node |p|@>=
9919 mp_print_char(mp, '"'); mp_print_str(mp,text_p(p));
9920 mp_print(mp, "\" infont \""); mp_print(mp, mp->font_name[font_n(p)]);
9921 mp_print_char(mp, '"'); mp_print_ln(mp);
9922 mp_print_obj_color(mp, p);
9923 mp_print(mp, "transformed ");
9924 mp_print_compact_node(mp, text_tx_loc(p),6);
9927 @ @<Cases for printing graphical object node |p|@>=
9928 case mp_start_clip_code:
9929 mp_print(mp, "clipping path:");
9931 mp_pr_path(mp, path_p(p));
9933 case mp_stop_clip_code:
9934 mp_print(mp, "stop clipping");
9937 @ @<Cases for printing graphical object node |p|@>=
9938 case mp_start_bounds_code:
9939 mp_print(mp, "setbounds path:");
9941 mp_pr_path(mp, path_p(p));
9943 case mp_stop_bounds_code:
9944 mp_print(mp, "end of setbounds");
9947 @ To initialize the |dash_list| field in an edge header~|h|, we need a
9948 subroutine that scans an edge structure and tries to interpret it as a dash
9949 pattern. This can only be done when there are no filled regions or clipping
9950 paths and all the pen strokes have the same color. The first step is to let
9951 $y_0$ be the initial $y$~coordinate of the first pen stroke. Then we implicitly
9952 project all the pen stroke paths onto the line $y=y_0$ and require that there
9953 be no retracing. If the resulting paths cover a range of $x$~coordinates of
9954 length $\Delta x$, we set |dash_y(h)| to the length of the dash pattern by
9955 finding the maximum of $\Delta x$ and the absolute value of~$y_0$.
9957 @c @<Declare a procedure called |x_retrace_error|@>
9958 pointer mp_make_dashes (MP mp,pointer h) { /* returns |h| or |null| */
9959 pointer p; /* this scans the stroked nodes in the object list */
9960 pointer p0; /* if not |null| this points to the first stroked node */
9961 pointer pp,qq,rr; /* pointers into |path_p(p)| */
9962 pointer d,dd; /* pointers used to create the dash list */
9964 @<Other local variables in |make_dashes|@>;
9965 y0=0; /* the initial $y$ coordinate */
9966 if ( dash_list(h)!=null_dash )
9969 p=link(dummy_loc(h));
9971 if ( type(p)!=mp_stroked_code ) {
9972 @<Compain that the edge structure contains a node of the wrong type
9973 and |goto not_found|@>;
9976 if ( p0==null ){ p0=p; y0=y_coord(pp); };
9977 @<Make |d| point to a new dash node created from stroke |p| and path |pp|
9978 or |goto not_found| if there is an error@>;
9979 @<Insert |d| into the dash list and |goto not_found| if there is an error@>;
9982 if ( dash_list(h)==null_dash )
9983 goto NOT_FOUND; /* No error message */
9984 @<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>;
9985 @<Set |dash_y(h)| and merge the first and last dashes if necessary@>;
9988 @<Flush the dash list, recycle |h| and return |null|@>;
9991 @ @<Compain that the edge structure contains a node of the wrong type...@>=
9993 print_err("Picture is too complicated to use as a dash pattern");
9994 help3("When you say `dashed p', picture p should not contain any")
9995 ("text, filled regions, or clipping paths. This time it did")
9996 ("so I'll just make it a solid line instead.");
9997 mp_put_get_error(mp);
10001 @ A similar error occurs when monotonicity fails.
10003 @<Declare a procedure called |x_retrace_error|@>=
10004 void mp_x_retrace_error (MP mp) {
10005 print_err("Picture is too complicated to use as a dash pattern");
10006 help3("When you say `dashed p', every path in p should be monotone")
10007 ("in x and there must be no overlapping. This failed")
10008 ("so I'll just make it a solid line instead.");
10009 mp_put_get_error(mp);
10012 @ We stash |p| in |info(d)| if |dash_p(p)<>0| so that subsequent processing can
10013 handle the case where the pen stroke |p| is itself dashed.
10015 @<Make |d| point to a new dash node created from stroke |p| and path...@>=
10016 @<Make sure |p| and |p0| are the same color and |goto not_found| if there is
10019 if ( link(pp)!=pp ) {
10021 qq=rr; rr=link(rr);
10022 @<Check for retracing between knots |qq| and |rr| and |goto not_found|
10023 if there is a problem@>;
10024 } while (right_type(rr)!=mp_endpoint);
10026 d=mp_get_node(mp, dash_node_size);
10027 if ( dash_p(p)==0 ) info(d)=0; else info(d)=p;
10028 if ( x_coord(pp)<x_coord(rr) ) {
10029 start_x(d)=x_coord(pp);
10030 stop_x(d)=x_coord(rr);
10032 start_x(d)=x_coord(rr);
10033 stop_x(d)=x_coord(pp);
10036 @ We also need to check for the case where the segment from |qq| to |rr| is
10037 monotone in $x$ but is reversed relative to the path from |pp| to |qq|.
10039 @<Check for retracing between knots |qq| and |rr| and |goto not_found|...@>=
10044 if ( (x0>x1) || (x1>x2) || (x2>x3) ) {
10045 if ( (x0<x1) || (x1<x2) || (x2<x3) ) {
10046 if ( mp_ab_vs_cd(mp, x2-x1,x2-x1,x1-x0,x3-x2)>0 ) {
10047 mp_x_retrace_error(mp); goto NOT_FOUND;
10051 if ( (x_coord(pp)>x0) || (x0>x3) ) {
10052 if ( (x_coord(pp)<x0) || (x0<x3) ) {
10053 mp_x_retrace_error(mp); goto NOT_FOUND;
10057 @ @<Other local variables in |make_dashes|@>=
10058 scaled x0,x1,x2,x3; /* $x$ coordinates of the segment from |qq| to |rr| */
10060 @ @<Make sure |p| and |p0| are the same color and |goto not_found|...@>=
10061 if ( (red_val(p)!=red_val(p0)) || (black_val(p)!=black_val(p0)) ||
10062 (green_val(p)!=green_val(p0)) || (blue_val(p)!=blue_val(p0)) ) {
10063 print_err("Picture is too complicated to use as a dash pattern");
10064 help3("When you say `dashed p', everything in picture p should")
10065 ("be the same color. I can\'t handle your color changes")
10066 ("so I'll just make it a solid line instead.");
10067 mp_put_get_error(mp);
10071 @ @<Insert |d| into the dash list and |goto not_found| if there is an error@>=
10072 start_x(null_dash)=stop_x(d);
10073 dd=h; /* this makes |link(dd)=dash_list(h)| */
10074 while ( start_x(link(dd))<stop_x(d) )
10077 if ( (stop_x(dd)>start_x(d)) )
10078 { mp_x_retrace_error(mp); goto NOT_FOUND; };
10083 @ @<Set |dash_y(h)| and merge the first and last dashes if necessary@>=
10085 while ( (link(d)!=null_dash) )
10088 dash_y(h)=stop_x(d)-start_x(dd);
10089 if ( abs(y0)>dash_y(h) ) {
10091 } else if ( d!=dd ) {
10092 dash_list(h)=link(dd);
10093 stop_x(d)=stop_x(dd)+dash_y(h);
10094 mp_free_node(mp, dd,dash_node_size);
10097 @ We get here when the argument is a null picture or when there is an error.
10098 Recovering from an error involves making |dash_list(h)| empty to indicate
10099 that |h| is not known to be a valid dash pattern. We also dereference |h|
10100 since it is not being used for the return value.
10102 @<Flush the dash list, recycle |h| and return |null|@>=
10103 mp_flush_dash_list(mp, h);
10104 delete_edge_ref(h);
10107 @ Having carefully saved the dashed stroked nodes in the
10108 corresponding dash nodes, we must be prepared to break up these dashes into
10111 @<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>=
10112 d=h; /* now |link(d)=dash_list(h)| */
10113 while ( link(d)!=null_dash ) {
10119 hsf=dash_scale(ds);
10120 if ( (hh==null) ) mp_confusion(mp, "dash1");
10121 @:this can't happen dash0}{\quad dash1@>
10122 if ( dash_y(hh)==0 ) {
10125 if ( dash_list(hh)==null ) mp_confusion(mp, "dash1");
10126 @:this can't happen dash0}{\quad dash1@>
10127 @<Replace |link(d)| by a dashed version as determined by edge header
10128 |hh| and scale factor |ds|@>;
10133 @ @<Other local variables in |make_dashes|@>=
10134 pointer dln; /* |link(d)| */
10135 pointer hh; /* an edge header that tells how to break up |dln| */
10136 scaled hsf; /* the dash pattern from |hh| gets scaled by this */
10137 pointer ds; /* the stroked node from which |hh| and |hsf| are derived */
10138 scaled xoff; /* added to $x$ values in |dash_list(hh)| to match |dln| */
10140 @ @<Replace |link(d)| by a dashed version as determined by edge header...@>=
10143 xoff=start_x(dln)-mp_take_scaled(mp, hsf,start_x(dd))-
10144 mp_take_scaled(mp, hsf,mp_dash_offset(mp, hh));
10145 start_x(null_dash)=mp_take_scaled(mp, hsf,start_x(dd))
10146 +mp_take_scaled(mp, hsf,dash_y(hh));
10147 stop_x(null_dash)=start_x(null_dash);
10148 @<Advance |dd| until finding the first dash that overlaps |dln| when
10149 offset by |xoff|@>;
10150 while ( start_x(dln)<=stop_x(dln) ) {
10151 @<If |dd| has `fallen off the end', back up to the beginning and fix |xoff|@>;
10152 @<Insert a dash between |d| and |dln| for the overlap with the offset version
10155 start_x(dln)=xoff+mp_take_scaled(mp, hsf,start_x(dd));
10158 mp_free_node(mp, dln,dash_node_size)
10160 @ The name of this module is a bit of a lie because we just find the
10161 first |dd| where |take_scaled (hsf, stop_x(dd))| is large enough to make an
10162 overlap possible. It could be that the unoffset version of dash |dln| falls
10163 in the gap between |dd| and its predecessor.
10165 @<Advance |dd| until finding the first dash that overlaps |dln| when...@>=
10166 while ( xoff+mp_take_scaled(mp, hsf,stop_x(dd))<start_x(dln) ) {
10170 @ @<If |dd| has `fallen off the end', back up to the beginning and fix...@>=
10171 if ( dd==null_dash ) {
10173 xoff=xoff+mp_take_scaled(mp, hsf,dash_y(hh));
10176 @ At this point we already know that
10177 |start_x(dln)<=xoff+take_scaled(hsf,stop_x(dd))|.
10179 @<Insert a dash between |d| and |dln| for the overlap with the offset...@>=
10180 if ( (xoff+mp_take_scaled(mp, hsf,start_x(dd)))<=stop_x(dln) ) {
10181 link(d)=mp_get_node(mp, dash_node_size);
10184 if ( start_x(dln)>(xoff+mp_take_scaled(mp, hsf,start_x(dd))))
10185 start_x(d)=start_x(dln);
10187 start_x(d)=xoff+mp_take_scaled(mp, hsf,start_x(dd));
10188 if ( stop_x(dln)<(xoff+mp_take_scaled(mp, hsf,stop_x(dd))))
10189 stop_x(d)=stop_x(dln);
10191 stop_x(d)=xoff+mp_take_scaled(mp, hsf,stop_x(dd));
10194 @ The next major task is to update the bounding box information in an edge
10195 header~|h|. This is done via a procedure |adjust_bbox| that enlarges an edge
10196 header's bounding box to accommodate the box computed by |path_bbox| or
10197 |pen_bbox|. (This is stored in global variables |minx|, |miny|, |maxx|, and
10200 @c void mp_adjust_bbox (MP mp,pointer h) {
10201 if ( minx<minx_val(h) ) minx_val(h)=minx;
10202 if ( miny<miny_val(h) ) miny_val(h)=miny;
10203 if ( maxx>maxx_val(h) ) maxx_val(h)=maxx;
10204 if ( maxy>maxy_val(h) ) maxy_val(h)=maxy;
10207 @ Here is a special routine for updating the bounding box information in
10208 edge header~|h| to account for the squared-off ends of a non-cyclic path~|p|
10209 that is to be stroked with the pen~|pp|.
10211 @c void mp_box_ends (MP mp, pointer p, pointer pp, pointer h) {
10212 pointer q; /* a knot node adjacent to knot |p| */
10213 fraction dx,dy; /* a unit vector in the direction out of the path at~|p| */
10214 scaled d; /* a factor for adjusting the length of |(dx,dy)| */
10215 scaled z; /* a coordinate being tested against the bounding box */
10216 scaled xx,yy; /* the extreme pen vertex in the |(dx,dy)| direction */
10217 integer i; /* a loop counter */
10218 if ( right_type(p)!=mp_endpoint ) {
10221 @<Make |(dx,dy)| the final direction for the path segment from
10222 |q| to~|p|; set~|d|@>;
10223 d=mp_pyth_add(mp, dx,dy);
10225 @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>;
10226 for (i=1;i<= 2;i++) {
10227 @<Use |(dx,dy)| to generate a vertex of the square end cap and
10228 update the bounding box to accommodate it@>;
10232 if ( right_type(p)==mp_endpoint ) {
10235 @<Advance |p| to the end of the path and make |q| the previous knot@>;
10241 @ @<Make |(dx,dy)| the final direction for the path segment from...@>=
10242 if ( q==link(p) ) {
10243 dx=x_coord(p)-right_x(p);
10244 dy=y_coord(p)-right_y(p);
10245 if ( (dx==0)&&(dy==0) ) {
10246 dx=x_coord(p)-left_x(q);
10247 dy=y_coord(p)-left_y(q);
10250 dx=x_coord(p)-left_x(p);
10251 dy=y_coord(p)-left_y(p);
10252 if ( (dx==0)&&(dy==0) ) {
10253 dx=x_coord(p)-right_x(q);
10254 dy=y_coord(p)-right_y(q);
10257 dx=x_coord(p)-x_coord(q);
10258 dy=y_coord(p)-y_coord(q)
10260 @ @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>=
10261 dx=mp_make_fraction(mp, dx,d);
10262 dy=mp_make_fraction(mp, dy,d);
10263 mp_find_offset(mp, -dy,dx,pp);
10264 xx=mp->cur_x; yy=mp->cur_y
10266 @ @<Use |(dx,dy)| to generate a vertex of the square end cap and...@>=
10267 mp_find_offset(mp, dx,dy,pp);
10268 d=mp_take_fraction(mp, xx-mp->cur_x,dx)+mp_take_fraction(mp, yy-mp->cur_y,dy);
10269 if ( ((d<0)&&(i==1)) || ((d>0)&&(i==2)))
10270 mp_confusion(mp, "box_ends");
10271 @:this can't happen box ends}{\quad\\{box\_ends}@>
10272 z=x_coord(p)+mp->cur_x+mp_take_fraction(mp, d,dx);
10273 if ( z<minx_val(h) ) minx_val(h)=z;
10274 if ( z>maxx_val(h) ) maxx_val(h)=z;
10275 z=y_coord(p)+mp->cur_y+mp_take_fraction(mp, d,dy);
10276 if ( z<miny_val(h) ) miny_val(h)=z;
10277 if ( z>maxy_val(h) ) maxy_val(h)=z
10279 @ @<Advance |p| to the end of the path and make |q| the previous knot@>=
10283 } while (right_type(p)!=mp_endpoint)
10285 @ The major difficulty in finding the bounding box of an edge structure is the
10286 effect of clipping paths. We treat them conservatively by only clipping to the
10287 clipping path's bounding box, but this still
10288 requires recursive calls to |set_bbox| in order to find the bounding box of
10290 the objects to be clipped. Such calls are distinguished by the fact that the
10291 boolean parameter |top_level| is false.
10293 @c void mp_set_bbox (MP mp,pointer h, boolean top_level) {
10294 pointer p; /* a graphical object being considered */
10295 scaled sminx,sminy,smaxx,smaxy;
10296 /* for saving the bounding box during recursive calls */
10297 scaled x0,x1,y0,y1; /* temporary registers */
10298 integer lev; /* nesting level for |mp_start_bounds_code| nodes */
10299 @<Wipe out any existing bounding box information if |bbtype(h)| is
10300 incompatible with |internal[mp_true_corners]|@>;
10301 while ( link(bblast(h))!=null ) {
10305 case mp_stop_clip_code:
10306 if ( top_level ) mp_confusion(mp, "bbox"); else return;
10307 @:this can't happen bbox}{\quad bbox@>
10309 @<Other cases for updating the bounding box based on the type of object |p|@>;
10310 } /* all cases are enumerated above */
10312 if ( ! top_level ) mp_confusion(mp, "bbox");
10315 @ @<Internal library declarations@>=
10316 void mp_set_bbox (MP mp,pointer h, boolean top_level);
10318 @ @<Wipe out any existing bounding box information if |bbtype(h)| is...@>=
10319 switch (bbtype(h)) {
10323 if ( mp->internal[mp_true_corners]>0 ) mp_init_bbox(mp, h);
10326 if ( mp->internal[mp_true_corners]<=0 ) mp_init_bbox(mp, h);
10328 } /* there are no other cases */
10330 @ @<Other cases for updating the bounding box...@>=
10332 mp_path_bbox(mp, path_p(p));
10333 if ( pen_p(p)!=null ) {
10336 mp_pen_bbox(mp, pen_p(p));
10342 mp_adjust_bbox(mp, h);
10345 @ @<Other cases for updating the bounding box...@>=
10346 case mp_start_bounds_code:
10347 if ( mp->internal[mp_true_corners]>0 ) {
10348 bbtype(h)=bounds_unset;
10350 bbtype(h)=bounds_set;
10351 mp_path_bbox(mp, path_p(p));
10352 mp_adjust_bbox(mp, h);
10353 @<Scan to the matching |mp_stop_bounds_code| node and update |p| and
10357 case mp_stop_bounds_code:
10358 if ( mp->internal[mp_true_corners]<=0 ) mp_confusion(mp, "bbox2");
10359 @:this can't happen bbox2}{\quad bbox2@>
10362 @ @<Scan to the matching |mp_stop_bounds_code| node and update |p| and...@>=
10365 if ( link(p)==null ) mp_confusion(mp, "bbox2");
10366 @:this can't happen bbox2}{\quad bbox2@>
10368 if ( type(p)==mp_start_bounds_code ) incr(lev);
10369 else if ( type(p)==mp_stop_bounds_code ) decr(lev);
10373 @ It saves a lot of grief here to be slightly conservative and not account for
10374 omitted parts of dashed lines. We also don't worry about the material omitted
10375 when using butt end caps. The basic computation is for round end caps and
10376 |box_ends| augments it for square end caps.
10378 @<Other cases for updating the bounding box...@>=
10379 case mp_stroked_code:
10380 mp_path_bbox(mp, path_p(p));
10383 mp_pen_bbox(mp, pen_p(p));
10388 mp_adjust_bbox(mp, h);
10389 if ( (left_type(path_p(p))==mp_endpoint)&&(lcap_val(p)==2) )
10390 mp_box_ends(mp, path_p(p), pen_p(p), h);
10393 @ The height width and depth information stored in a text node determines a
10394 rectangle that needs to be transformed according to the transformation
10395 parameters stored in the text node.
10397 @<Other cases for updating the bounding box...@>=
10399 x1=mp_take_scaled(mp, txx_val(p),width_val(p));
10400 y0=mp_take_scaled(mp, txy_val(p),-depth_val(p));
10401 y1=mp_take_scaled(mp, txy_val(p),height_val(p));
10404 if ( y0<y1 ) { minx=minx+y0; maxx=maxx+y1; }
10405 else { minx=minx+y1; maxx=maxx+y0; }
10406 if ( x1<0 ) minx=minx+x1; else maxx=maxx+x1;
10407 x1=mp_take_scaled(mp, tyx_val(p),width_val(p));
10408 y0=mp_take_scaled(mp, tyy_val(p),-depth_val(p));
10409 y1=mp_take_scaled(mp, tyy_val(p),height_val(p));
10412 if ( y0<y1 ) { miny=miny+y0; maxy=maxy+y1; }
10413 else { miny=miny+y1; maxy=maxy+y0; }
10414 if ( x1<0 ) miny=miny+x1; else maxy=maxy+x1;
10415 mp_adjust_bbox(mp, h);
10418 @ This case involves a recursive call that advances |bblast(h)| to the node of
10419 type |mp_stop_clip_code| that matches |p|.
10421 @<Other cases for updating the bounding box...@>=
10422 case mp_start_clip_code:
10423 mp_path_bbox(mp, path_p(p));
10426 sminx=minx_val(h); sminy=miny_val(h);
10427 smaxx=maxx_val(h); smaxy=maxy_val(h);
10428 @<Reinitialize the bounding box in header |h| and call |set_bbox| recursively
10429 starting at |link(p)|@>;
10430 @<Clip the bounding box in |h| to the rectangle given by |x0|, |x1|,
10432 minx=sminx; miny=sminy;
10433 maxx=smaxx; maxy=smaxy;
10434 mp_adjust_bbox(mp, h);
10437 @ @<Reinitialize the bounding box in header |h| and call |set_bbox|...@>=
10438 minx_val(h)=el_gordo;
10439 miny_val(h)=el_gordo;
10440 maxx_val(h)=-el_gordo;
10441 maxy_val(h)=-el_gordo;
10442 mp_set_bbox(mp, h,false)
10444 @ @<Clip the bounding box in |h| to the rectangle given by |x0|, |x1|,...@>=
10445 if ( minx_val(h)<x0 ) minx_val(h)=x0;
10446 if ( miny_val(h)<y0 ) miny_val(h)=y0;
10447 if ( maxx_val(h)>x1 ) maxx_val(h)=x1;
10448 if ( maxy_val(h)>y1 ) maxy_val(h)=y1
10450 @* \[22] Finding an envelope.
10451 When \MP\ has a path and a polygonal pen, it needs to express the desired
10452 shape in terms of things \ps\ can understand. The present task is to compute
10453 a new path that describes the region to be filled. It is convenient to
10454 define this as a two step process where the first step is determining what
10455 offset to use for each segment of the path.
10457 @ Given a pointer |c| to a cyclic path,
10458 and a pointer~|h| to the first knot of a pen polygon,
10459 the |offset_prep| routine changes the path into cubics that are
10460 associated with particular pen offsets. Thus if the cubic between |p|
10461 and~|q| is associated with the |k|th offset and the cubic between |q| and~|r|
10462 has offset |l| then |info(q)=zero_off+l-k|. (The constant |zero_off| is added
10463 to because |l-k| could be negative.)
10465 After overwriting the type information with offset differences, we no longer
10466 have a true path so we refer to the knot list returned by |offset_prep| as an
10469 Since an envelope spec only determines relative changes in pen offsets,
10470 |offset_prep| sets a global variable |spec_offset| to the relative change from
10471 |h| to the first offset.
10473 @d zero_off 16384 /* added to offset changes to make them positive */
10476 integer spec_offset; /* number of pen edges between |h| and the initial offset */
10478 @ @c @<Declare subroutines needed by |offset_prep|@>
10479 pointer mp_offset_prep (MP mp,pointer c, pointer h) {
10480 halfword n; /* the number of vertices in the pen polygon */
10481 pointer c0,p,q,q0,r,w, ww; /* for list manipulation */
10482 integer k_needed; /* amount to be added to |info(p)| when it is computed */
10483 pointer w0; /* a pointer to pen offset to use just before |p| */
10484 scaled dxin,dyin; /* the direction into knot |p| */
10485 integer turn_amt; /* change in pen offsets for the current cubic */
10486 @<Other local variables for |offset_prep|@>;
10488 @<Initialize the pen size~|n|@>;
10489 @<Initialize the incoming direction and pen offset at |c|@>;
10490 p=c; c0=c; k_needed=0;
10493 @<Split the cubic between |p| and |q|, if necessary, into cubics
10494 associated with single offsets, after which |q| should
10495 point to the end of the final such cubic@>;
10497 @<Advance |p| to node |q|, removing any ``dead'' cubics that
10498 might have been introduced by the splitting process@>;
10500 @<Fix the offset change in |info(c)| and set |c| to the return value of
10505 @ We shall want to keep track of where certain knots on the cyclic path
10506 wind up in the envelope spec. It doesn't suffice just to keep pointers to
10507 knot nodes because some nodes are deleted while removing dead cubics. Thus
10508 |offset_prep| updates the following pointers
10512 pointer spec_p2; /* pointers to distinguished knots */
10515 mp->spec_p1=null; mp->spec_p2=null;
10517 @ @<Initialize the pen size~|n|@>=
10524 @ Since the true incoming direction isn't known yet, we just pick a direction
10525 consistent with the pen offset~|h|. If this is wrong, it can be corrected
10528 @<Initialize the incoming direction and pen offset at |c|@>=
10529 dxin=x_coord(link(h))-x_coord(knil(h));
10530 dyin=y_coord(link(h))-y_coord(knil(h));
10531 if ( (dxin==0)&&(dyin==0) ) {
10532 dxin=y_coord(knil(h))-y_coord(h);
10533 dyin=x_coord(h)-x_coord(knil(h));
10537 @ We must be careful not to remove the only cubic in a cycle.
10539 But we must also be careful for another reason. If the user-supplied
10540 path starts with a set of degenerate cubics, the target node |q| can
10541 be collapsed to the initial node |p| which might be the same as the
10542 initial node |c| of the curve. This would cause the |offset_prep| routine
10543 to bail out too early, causing distress later on. (See for example
10544 the testcase reported by Bogus\l{}aw Jackowski in tracker id 267, case 52c
10547 @<Advance |p| to node |q|, removing any ``dead'' cubics...@>=
10551 if ( x_coord(p)==right_x(p) && y_coord(p)==right_y(p) &&
10552 x_coord(p)==left_x(r) && y_coord(p)==left_y(r) &&
10553 x_coord(p)==x_coord(r) && y_coord(p)==y_coord(r) &&
10555 @<Remove the cubic following |p| and update the data structures
10556 to merge |r| into |p|@>;
10560 /* Check if we removed too much */
10561 if ((q!=q0)&&(q!=c||c==c0))
10564 @ @<Remove the cubic following |p| and update the data structures...@>=
10565 { k_needed=info(p)-zero_off;
10569 info(p)=k_needed+info(r);
10572 if ( r==c ) { info(p)=info(c); c=p; };
10573 if ( r==mp->spec_p1 ) mp->spec_p1=p;
10574 if ( r==mp->spec_p2 ) mp->spec_p2=p;
10575 r=p; mp_remove_cubic(mp, p);
10578 @ Not setting the |info| field of the newly created knot allows the splitting
10579 routine to work for paths.
10581 @<Declare subroutines needed by |offset_prep|@>=
10582 void mp_split_cubic (MP mp,pointer p, fraction t) { /* splits the cubic after |p| */
10583 scaled v; /* an intermediate value */
10584 pointer q,r; /* for list manipulation */
10585 q=link(p); r=mp_get_node(mp, knot_node_size); link(p)=r; link(r)=q;
10586 originator(r)=mp_program_code;
10587 left_type(r)=mp_explicit; right_type(r)=mp_explicit;
10588 v=t_of_the_way(right_x(p),left_x(q));
10589 right_x(p)=t_of_the_way(x_coord(p),right_x(p));
10590 left_x(q)=t_of_the_way(left_x(q),x_coord(q));
10591 left_x(r)=t_of_the_way(right_x(p),v);
10592 right_x(r)=t_of_the_way(v,left_x(q));
10593 x_coord(r)=t_of_the_way(left_x(r),right_x(r));
10594 v=t_of_the_way(right_y(p),left_y(q));
10595 right_y(p)=t_of_the_way(y_coord(p),right_y(p));
10596 left_y(q)=t_of_the_way(left_y(q),y_coord(q));
10597 left_y(r)=t_of_the_way(right_y(p),v);
10598 right_y(r)=t_of_the_way(v,left_y(q));
10599 y_coord(r)=t_of_the_way(left_y(r),right_y(r));
10602 @ This does not set |info(p)| or |right_type(p)|.
10604 @<Declare subroutines needed by |offset_prep|@>=
10605 void mp_remove_cubic (MP mp,pointer p) { /* removes the dead cubic following~|p| */
10606 pointer q; /* the node that disappears */
10607 q=link(p); link(p)=link(q);
10608 right_x(p)=right_x(q); right_y(p)=right_y(q);
10609 mp_free_node(mp, q,knot_node_size);
10612 @ Let $d\prec d'$ mean that the counter-clockwise angle from $d$ to~$d'$ is
10613 strictly between zero and $180^\circ$. Then we can define $d\preceq d'$ to
10614 mean that the angle could be zero or $180^\circ$. If $w_k=(u_k,v_k)$ is the
10615 $k$th pen offset, the $k$th pen edge direction is defined by the formula
10616 $$d_k=(u\k-u_k,\,v\k-v_k).$$
10617 When listed by increasing $k$, these directions occur in counter-clockwise
10618 order so that $d_k\preceq d\k$ for all~$k$.
10619 The goal of |offset_prep| is to find an offset index~|k| to associate with
10620 each cubic, such that the direction $d(t)$ of the cubic satisfies
10621 $$d_{k-1}\preceq d(t)\preceq d_k\qquad\hbox{for $0\le t\le 1$.}\eqno(*)$$
10622 We may have to split a cubic into many pieces before each
10623 piece corresponds to a unique offset.
10625 @<Split the cubic between |p| and |q|, if necessary, into cubics...@>=
10626 info(p)=zero_off+k_needed;
10628 @<Prepare for derivative computations;
10629 |goto not_found| if the current cubic is dead@>;
10630 @<Find the initial direction |(dx,dy)|@>;
10631 @<Update |info(p)| and find the offset $w_k$ such that
10632 $d_{k-1}\preceq(\\{dx},\\{dy})\prec d_k$; also advance |w0| for
10633 the direction change at |p|@>;
10634 @<Find the final direction |(dxin,dyin)|@>;
10635 @<Decide on the net change in pen offsets and set |turn_amt|@>;
10636 @<Complete the offset splitting process@>;
10637 w0=mp_pen_walk(mp, w0,turn_amt)
10639 @ @<Declare subroutines needed by |offset_prep|@>=
10640 pointer mp_pen_walk (MP mp,pointer w, integer k) {
10641 /* walk |k| steps around a pen from |w| */
10642 while ( k>0 ) { w=link(w); decr(k); };
10643 while ( k<0 ) { w=knil(w); incr(k); };
10647 @ The direction of a cubic $B(z_0,z_1,z_2,z_3;t)=\bigl(x(t),y(t)\bigr)$ can be
10648 calculated from the quadratic polynomials
10649 ${1\over3}x'(t)=B(x_1-x_0,x_2-x_1,x_3-x_2;t)$ and
10650 ${1\over3}y'(t)=B(y_1-y_0,y_2-y_1,y_3-y_2;t)$.
10651 Since we may be calculating directions from several cubics
10652 split from the current one, it is desirable to do these calculations
10653 without losing too much precision. ``Scaled up'' values of the
10654 derivatives, which will be less tainted by accumulated errors than
10655 derivatives found from the cubics themselves, are maintained in
10656 local variables |x0|, |x1|, and |x2|, representing $X_0=2^l(x_1-x_0)$,
10657 $X_1=2^l(x_2-x_1)$, and $X_2=2^l(x_3-x_2)$; similarly |y0|, |y1|, and~|y2|
10658 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)$.
10660 @<Other local variables for |offset_prep|@>=
10661 integer x0,x1,x2,y0,y1,y2; /* representatives of derivatives */
10662 integer t0,t1,t2; /* coefficients of polynomial for slope testing */
10663 integer du,dv,dx,dy; /* for directions of the pen and the curve */
10664 integer dx0,dy0; /* initial direction for the first cubic in the curve */
10665 integer max_coef; /* used while scaling */
10666 integer x0a,x1a,x2a,y0a,y1a,y2a; /* intermediate values */
10667 fraction t; /* where the derivative passes through zero */
10668 fraction s; /* a temporary value */
10670 @ @<Prepare for derivative computations...@>=
10671 x0=right_x(p)-x_coord(p);
10672 x2=x_coord(q)-left_x(q);
10673 x1=left_x(q)-right_x(p);
10674 y0=right_y(p)-y_coord(p); y2=y_coord(q)-left_y(q);
10675 y1=left_y(q)-right_y(p);
10677 if ( abs(x1)>max_coef ) max_coef=abs(x1);
10678 if ( abs(x2)>max_coef ) max_coef=abs(x2);
10679 if ( abs(y0)>max_coef ) max_coef=abs(y0);
10680 if ( abs(y1)>max_coef ) max_coef=abs(y1);
10681 if ( abs(y2)>max_coef ) max_coef=abs(y2);
10682 if ( max_coef==0 ) goto NOT_FOUND;
10683 while ( max_coef<fraction_half ) {
10685 double(x0); double(x1); double(x2);
10686 double(y0); double(y1); double(y2);
10689 @ Let us first solve a special case of the problem: Suppose we
10690 know an index~$k$ such that either (i)~$d(t)\succeq d_{k-1}$ for all~$t$
10691 and $d(0)\prec d_k$, or (ii)~$d(t)\preceq d_k$ for all~$t$ and
10692 $d(0)\succ d_{k-1}$.
10693 Then, in a sense, we're halfway done, since one of the two relations
10694 in $(*)$ is satisfied, and the other couldn't be satisfied for
10695 any other value of~|k|.
10697 Actually, the conditions can be relaxed somewhat since a relation such as
10698 $d(t)\succeq d_{k-1}$ restricts $d(t)$ to a half plane when all that really
10699 matters is whether $d(t)$ crosses the ray in the $d_{k-1}$ direction from
10700 the origin. The condition for case~(i) becomes $d_{k-1}\preceq d(0)\prec d_k$
10701 and $d(t)$ never crosses the $d_{k-1}$ ray in the clockwise direction.
10702 Case~(ii) is similar except $d(t)$ cannot cross the $d_k$ ray in the
10703 counterclockwise direction.
10705 The |fin_offset_prep| subroutine solves the stated subproblem.
10706 It has a parameter called |rise| that is |1| in
10707 case~(i), |-1| in case~(ii). Parameters |x0| through |y2| represent
10708 the derivative of the cubic following |p|.
10709 The |w| parameter should point to offset~$w_k$ and |info(p)| should already
10710 be set properly. The |turn_amt| parameter gives the absolute value of the
10711 overall net change in pen offsets.
10713 @<Declare subroutines needed by |offset_prep|@>=
10714 void mp_fin_offset_prep (MP mp,pointer p, pointer w, integer
10715 x0,integer x1, integer x2, integer y0, integer y1, integer y2,
10716 integer rise, integer turn_amt) {
10717 pointer ww; /* for list manipulation */
10718 scaled du,dv; /* for slope calculation */
10719 integer t0,t1,t2; /* test coefficients */
10720 fraction t; /* place where the derivative passes a critical slope */
10721 fraction s; /* slope or reciprocal slope */
10722 integer v; /* intermediate value for updating |x0..y2| */
10723 pointer q; /* original |link(p)| */
10726 if ( rise>0 ) ww=link(w); /* a pointer to $w\k$ */
10727 else ww=knil(w); /* a pointer to $w_{k-1}$ */
10728 @<Compute test coefficients |(t0,t1,t2)|
10729 for $d(t)$ versus $d_k$ or $d_{k-1}$@>;
10730 t=mp_crossing_point(mp, t0,t1,t2);
10731 if ( t>=fraction_one ) {
10732 if ( turn_amt>0 ) t=fraction_one; else return;
10734 @<Split the cubic at $t$,
10735 and split off another cubic if the derivative crosses back@>;
10740 @ We want $B(\\{t0},\\{t1},\\{t2};t)$ to be the dot product of $d(t)$ with a
10741 $-90^\circ$ rotation of the vector from |w| to |ww|. This makes the resulting
10742 function cross from positive to negative when $d_{k-1}\preceq d(t)\preceq d_k$
10745 @<Compute test coefficients |(t0,t1,t2)| for $d(t)$ versus...@>=
10746 du=x_coord(ww)-x_coord(w); dv=y_coord(ww)-y_coord(w);
10747 if ( abs(du)>=abs(dv) ) {
10748 s=mp_make_fraction(mp, dv,du);
10749 t0=mp_take_fraction(mp, x0,s)-y0;
10750 t1=mp_take_fraction(mp, x1,s)-y1;
10751 t2=mp_take_fraction(mp, x2,s)-y2;
10752 if ( du<0 ) { negate(t0); negate(t1); negate(t2); }
10754 s=mp_make_fraction(mp, du,dv);
10755 t0=x0-mp_take_fraction(mp, y0,s);
10756 t1=x1-mp_take_fraction(mp, y1,s);
10757 t2=x2-mp_take_fraction(mp, y2,s);
10758 if ( dv<0 ) { negate(t0); negate(t1); negate(t2); }
10760 if ( t0<0 ) t0=0 /* should be positive without rounding error */
10762 @ The curve has crossed $d_k$ or $d_{k-1}$; its initial segment satisfies
10763 $(*)$, and it might cross again and return towards $s_{k-1}$ or $s_k$,
10764 respectively, yielding another solution of $(*)$.
10766 @<Split the cubic at $t$, and split off another...@>=
10768 mp_split_cubic(mp, p,t); p=link(p); info(p)=zero_off+rise;
10770 v=t_of_the_way(x0,x1); x1=t_of_the_way(x1,x2);
10771 x0=t_of_the_way(v,x1);
10772 v=t_of_the_way(y0,y1); y1=t_of_the_way(y1,y2);
10773 y0=t_of_the_way(v,y1);
10774 if ( turn_amt<0 ) {
10775 t1=t_of_the_way(t1,t2);
10776 if ( t1>0 ) t1=0; /* without rounding error, |t1| would be |<=0| */
10777 t=mp_crossing_point(mp, 0,-t1,-t2);
10778 if ( t>fraction_one ) t=fraction_one;
10780 if ( (t==fraction_one)&&(link(p)!=q) ) {
10781 info(link(p))=info(link(p))-rise;
10783 mp_split_cubic(mp, p,t); info(link(p))=zero_off-rise;
10784 v=t_of_the_way(x1,x2); x1=t_of_the_way(x0,x1);
10785 x2=t_of_the_way(x1,v);
10786 v=t_of_the_way(y1,y2); y1=t_of_the_way(y0,y1);
10787 y2=t_of_the_way(y1,v);
10792 @ Now we must consider the general problem of |offset_prep|, when
10793 nothing is known about a given cubic. We start by finding its
10794 direction in the vicinity of |t=0|.
10796 If $z'(t)=0$, the given cubic is numerically unstable but |offset_prep|
10797 has not yet introduced any more numerical errors. Thus we can compute
10798 the true initial direction for the given cubic, even if it is almost
10801 @<Find the initial direction |(dx,dy)|@>=
10803 if ( dx==0 && dy==0 ) {
10805 if ( dx==0 && dy==0 ) {
10809 if ( p==c ) { dx0=dx; dy0=dy; }
10811 @ @<Find the final direction |(dxin,dyin)|@>=
10813 if ( dxin==0 && dyin==0 ) {
10815 if ( dxin==0 && dyin==0 ) {
10820 @ The next step is to bracket the initial direction between consecutive
10821 edges of the pen polygon. We must be careful to turn clockwise only if
10822 this makes the turn less than $180^\circ$. (A $180^\circ$ turn must be
10823 counter-clockwise in order to make \&{doublepath} envelopes come out
10824 @:double_path_}{\&{doublepath} primitive@>
10825 right.) This code depends on |w0| being the offset for |(dxin,dyin)|.
10827 @<Update |info(p)| and find the offset $w_k$ such that...@>=
10828 turn_amt=mp_get_turn_amt(mp,w0,dx,dy,(mp_ab_vs_cd(mp, dy,dxin,dx,dyin)>=0));
10829 w=mp_pen_walk(mp, w0, turn_amt);
10831 info(p)=info(p)+turn_amt
10833 @ Decide how many pen offsets to go away from |w| in order to find the offset
10834 for |(dx,dy)|, going counterclockwise if |ccw| is |true|. This assumes that
10835 |w| is the offset for some direction $(x',y')$ from which the angle to |(dx,dy)|
10836 in the sense determined by |ccw| is less than or equal to $180^\circ$.
10838 If the pen polygon has only two edges, they could both be parallel
10839 to |(dx,dy)|. In this case, we must be careful to stop after crossing the first
10840 such edge in order to avoid an infinite loop.
10842 @<Declare subroutines needed by |offset_prep|@>=
10843 integer mp_get_turn_amt (MP mp,pointer w, scaled dx,
10844 scaled dy, boolean ccw) {
10845 pointer ww; /* a neighbor of knot~|w| */
10846 integer s; /* turn amount so far */
10847 integer t; /* |ab_vs_cd| result */
10852 t=mp_ab_vs_cd(mp, dy,(x_coord(ww)-x_coord(w)),
10853 dx,(y_coord(ww)-y_coord(w)));
10860 while ( mp_ab_vs_cd(mp, dy,(x_coord(w)-x_coord(ww)),
10861 dx,(y_coord(w)-y_coord(ww))) < 0) {
10869 @ When we're all done, the final offset is |w0| and the final curve direction
10870 is |(dxin,dyin)|. With this knowledge of the incoming direction at |c|, we
10871 can correct |info(c)| which was erroneously based on an incoming offset
10874 @d fix_by(A) info(c)=info(c)+(A)
10876 @<Fix the offset change in |info(c)| and set |c| to the return value of...@>=
10877 mp->spec_offset=info(c)-zero_off;
10878 if ( link(c)==c ) {
10879 info(c)=zero_off+n;
10882 while ( w0!=h ) { fix_by(1); w0=link(w0); };
10883 while ( info(c)<=zero_off-n ) fix_by(n);
10884 while ( info(c)>zero_off ) fix_by(-n);
10885 if ( (info(c)!=zero_off)&&(mp_ab_vs_cd(mp, dy0,dxin,dx0,dyin)>=0) ) fix_by(n);
10888 @ Finally we want to reduce the general problem to situations that
10889 |fin_offset_prep| can handle. We split the cubic into at most three parts
10890 with respect to $d_{k-1}$, and apply |fin_offset_prep| to each part.
10892 @<Complete the offset splitting process@>=
10894 @<Compute test coeff...@>;
10895 @<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set
10896 |t:=fraction_one+1|@>;
10897 if ( t>fraction_one ) {
10898 mp_fin_offset_prep(mp, p,w,x0,x1,x2,y0,y1,y2,1,turn_amt);
10900 mp_split_cubic(mp, p,t); r=link(p);
10901 x1a=t_of_the_way(x0,x1); x1=t_of_the_way(x1,x2);
10902 x2a=t_of_the_way(x1a,x1);
10903 y1a=t_of_the_way(y0,y1); y1=t_of_the_way(y1,y2);
10904 y2a=t_of_the_way(y1a,y1);
10905 mp_fin_offset_prep(mp, p,w,x0,x1a,x2a,y0,y1a,y2a,1,0); x0=x2a; y0=y2a;
10906 info(r)=zero_off-1;
10907 if ( turn_amt>=0 ) {
10908 t1=t_of_the_way(t1,t2);
10910 t=mp_crossing_point(mp, 0,-t1,-t2);
10911 if ( t>fraction_one ) t=fraction_one;
10912 @<Split off another rising cubic for |fin_offset_prep|@>;
10913 mp_fin_offset_prep(mp, r,ww,x0,x1,x2,y0,y1,y2,-1,0);
10915 mp_fin_offset_prep(mp, r,ww,x0,x1,x2,y0,y1,y2,-1,(-1-turn_amt));
10919 @ @<Split off another rising cubic for |fin_offset_prep|@>=
10920 mp_split_cubic(mp, r,t); info(link(r))=zero_off+1;
10921 x1a=t_of_the_way(x1,x2); x1=t_of_the_way(x0,x1);
10922 x0a=t_of_the_way(x1,x1a);
10923 y1a=t_of_the_way(y1,y2); y1=t_of_the_way(y0,y1);
10924 y0a=t_of_the_way(y1,y1a);
10925 mp_fin_offset_prep(mp, link(r),w,x0a,x1a,x2,y0a,y1a,y2,1,turn_amt);
10928 @ At this point, the direction of the incoming pen edge is |(-du,-dv)|.
10929 When the component of $d(t)$ perpendicular to |(-du,-dv)| crosses zero, we
10930 need to decide whether the directions are parallel or antiparallel. We
10931 can test this by finding the dot product of $d(t)$ and |(-du,-dv)|, but this
10932 should be avoided when the value of |turn_amt| already determines the
10933 answer. If |t2<0|, there is one crossing and it is antiparallel only if
10934 |turn_amt>=0|. If |turn_amt<0|, there should always be at least one
10935 crossing and the first crossing cannot be antiparallel.
10937 @<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set...@>=
10938 t=mp_crossing_point(mp, t0,t1,t2);
10939 if ( turn_amt>=0 ) {
10943 u0=t_of_the_way(x0,x1);
10944 u1=t_of_the_way(x1,x2);
10945 ss=mp_take_fraction(mp, -du,t_of_the_way(u0,u1));
10946 v0=t_of_the_way(y0,y1);
10947 v1=t_of_the_way(y1,y2);
10948 ss=ss+mp_take_fraction(mp, -dv,t_of_the_way(v0,v1));
10949 if ( ss<0 ) t=fraction_one+1;
10951 } else if ( t>fraction_one ) {
10955 @ @<Other local variables for |offset_prep|@>=
10956 integer u0,u1,v0,v1; /* intermediate values for $d(t)$ calculation */
10957 integer ss = 0; /* the part of the dot product computed so far */
10958 int d_sign; /* sign of overall change in direction for this cubic */
10960 @ If the cubic almost has a cusp, it is a numerically ill-conditioned
10961 problem to decide which way it loops around but that's OK as long we're
10962 consistent. To make \&{doublepath} envelopes work properly, reversing
10963 the path should always change the sign of |turn_amt|.
10965 @<Decide on the net change in pen offsets and set |turn_amt|@>=
10966 d_sign=mp_ab_vs_cd(mp, dx,dyin, dxin,dy);
10968 @<Check rotation direction based on node position@>
10972 if ( dy>0 ) d_sign=1; else d_sign=-1;
10974 if ( dx>0 ) d_sign=1; else d_sign=-1;
10977 @<Make |ss| negative if and only if the total change in direction is
10978 more than $180^\circ$@>;
10979 turn_amt=mp_get_turn_amt(mp, w, dxin, dyin, (d_sign>0));
10980 if ( ss<0 ) turn_amt=turn_amt-d_sign*n
10982 @ We check rotation direction by looking at the vector connecting the current
10983 node with the next. If its angle with incoming and outgoing tangents has the
10984 same sign, we pick this as |d_sign|, since it means we have a flex, not a cusp.
10985 Otherwise we proceed to the cusp code.
10987 @<Check rotation direction based on node position@>=
10988 u0=x_coord(q)-x_coord(p);
10989 u1=y_coord(q)-y_coord(p);
10990 d_sign = half(mp_ab_vs_cd(mp, dx, u1, u0, dy)+
10991 mp_ab_vs_cd(mp, u0, dyin, dxin, u1));
10993 @ In order to be invariant under path reversal, the result of this computation
10994 should not change when |x0|, |y0|, $\ldots$ are all negated and |(x0,y0)| is
10995 then swapped with |(x2,y2)|. We make use of the identities
10996 |take_fraction(-a,-b)=take_fraction(a,b)| and
10997 |t_of_the_way(-a,-b)=-(t_of_the_way(a,b))|.
10999 @<Make |ss| negative if and only if the total change in direction is...@>=
11000 t0=half(mp_take_fraction(mp, x0,y2))-half(mp_take_fraction(mp, x2,y0));
11001 t1=half(mp_take_fraction(mp, x1,(y0+y2)))-half(mp_take_fraction(mp, y1,(x0+x2)));
11002 if ( t0==0 ) t0=d_sign; /* path reversal always negates |d_sign| */
11004 t=mp_crossing_point(mp, t0,t1,-t0);
11005 u0=t_of_the_way(x0,x1);
11006 u1=t_of_the_way(x1,x2);
11007 v0=t_of_the_way(y0,y1);
11008 v1=t_of_the_way(y1,y2);
11010 t=mp_crossing_point(mp, -t0,t1,t0);
11011 u0=t_of_the_way(x2,x1);
11012 u1=t_of_the_way(x1,x0);
11013 v0=t_of_the_way(y2,y1);
11014 v1=t_of_the_way(y1,y0);
11016 ss=mp_take_fraction(mp, (x0+x2),t_of_the_way(u0,u1))+
11017 mp_take_fraction(mp, (y0+y2),t_of_the_way(v0,v1))
11019 @ Here's a routine that prints an envelope spec in symbolic form. It assumes
11020 that the |cur_pen| has not been walked around to the first offset.
11023 void mp_print_spec (MP mp,pointer cur_spec, pointer cur_pen, const char *s) {
11024 pointer p,q; /* list traversal */
11025 pointer w; /* the current pen offset */
11026 mp_print_diagnostic(mp, "Envelope spec",s,true);
11027 p=cur_spec; w=mp_pen_walk(mp, cur_pen,mp->spec_offset);
11029 mp_print_two(mp, x_coord(cur_spec),y_coord(cur_spec));
11030 mp_print(mp, " % beginning with offset ");
11031 mp_print_two(mp, x_coord(w),y_coord(w));
11035 @<Print the cubic between |p| and |q|@>;
11037 if ((p==cur_spec) || (info(p)!=zero_off))
11040 if ( info(p)!=zero_off ) {
11041 @<Update |w| as indicated by |info(p)| and print an explanation@>;
11043 } while (p!=cur_spec);
11044 mp_print_nl(mp, " & cycle");
11045 mp_end_diagnostic(mp, true);
11048 @ @<Update |w| as indicated by |info(p)| and print an explanation@>=
11050 w=mp_pen_walk(mp, w, (info(p)-zero_off));
11051 mp_print(mp, " % ");
11052 if ( info(p)>zero_off ) mp_print(mp, "counter");
11053 mp_print(mp, "clockwise to offset ");
11054 mp_print_two(mp, x_coord(w),y_coord(w));
11057 @ @<Print the cubic between |p| and |q|@>=
11059 mp_print_nl(mp, " ..controls ");
11060 mp_print_two(mp, right_x(p),right_y(p));
11061 mp_print(mp, " and ");
11062 mp_print_two(mp, left_x(q),left_y(q));
11063 mp_print_nl(mp, " ..");
11064 mp_print_two(mp, x_coord(q),y_coord(q));
11067 @ Once we have an envelope spec, the remaining task to construct the actual
11068 envelope by offsetting each cubic as determined by the |info| fields in
11069 the knots. First we use |offset_prep| to convert the |c| into an envelope
11070 spec. Then we add the offsets so that |c| becomes a cyclic path that represents
11073 The |ljoin| and |miterlim| parameters control the treatment of points where the
11074 pen offset changes, and |lcap| controls the endpoints of a \&{doublepath}.
11075 The endpoints are easily located because |c| is given in undoubled form
11076 and then doubled in this procedure. We use |spec_p1| and |spec_p2| to keep
11077 track of the endpoints and treat them like very sharp corners.
11078 Butt end caps are treated like beveled joins; round end caps are treated like
11079 round joins; and square end caps are achieved by setting |join_type:=3|.
11081 None of these parameters apply to inside joins where the convolution tracing
11082 has retrograde lines. In such cases we use a simple connect-the-endpoints
11083 approach that is achieved by setting |join_type:=2|.
11085 @c @<Declare a function called |insert_knot|@>
11086 pointer mp_make_envelope (MP mp,pointer c, pointer h, small_number ljoin,
11087 small_number lcap, scaled miterlim) {
11088 pointer p,q,r,q0; /* for manipulating the path */
11089 int join_type=0; /* codes |0..3| for mitered, round, beveled, or square */
11090 pointer w,w0; /* the pen knot for the current offset */
11091 scaled qx,qy; /* unshifted coordinates of |q| */
11092 halfword k,k0; /* controls pen edge insertion */
11093 @<Other local variables for |make_envelope|@>;
11094 dxin=0; dyin=0; dxout=0; dyout=0;
11095 mp->spec_p1=null; mp->spec_p2=null;
11096 @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>;
11097 @<Use |offset_prep| to compute the envelope spec then walk |h| around to
11098 the initial offset@>;
11103 qx=x_coord(q); qy=y_coord(q);
11106 if ( k!=zero_off ) {
11107 @<Set |join_type| to indicate how to handle offset changes at~|q|@>;
11109 @<Add offset |w| to the cubic from |p| to |q|@>;
11110 while ( k!=zero_off ) {
11111 @<Step |w| and move |k| one step closer to |zero_off|@>;
11112 if ( (join_type==1)||(k==zero_off) )
11113 q=mp_insert_knot(mp, q,qx+x_coord(w),qy+y_coord(w));
11115 if ( q!=link(p) ) {
11116 @<Set |p=link(p)| and add knots between |p| and |q| as
11117 required by |join_type|@>;
11124 @ @<Use |offset_prep| to compute the envelope spec then walk |h| around to...@>=
11125 c=mp_offset_prep(mp, c,h);
11126 if ( mp->internal[mp_tracing_specs]>0 )
11127 mp_print_spec(mp, c,h,"");
11128 h=mp_pen_walk(mp, h,mp->spec_offset)
11130 @ Mitered and squared-off joins depend on path directions that are difficult to
11131 compute for degenerate cubics. The envelope spec computed by |offset_prep| can
11132 have degenerate cubics only if the entire cycle collapses to a single
11133 degenerate cubic. Setting |join_type:=2| in this case makes the computed
11134 envelope degenerate as well.
11136 @<Set |join_type| to indicate how to handle offset changes at~|q|@>=
11137 if ( k<zero_off ) {
11140 if ( (q!=mp->spec_p1)&&(q!=mp->spec_p2) ) join_type=ljoin;
11141 else if ( lcap==2 ) join_type=3;
11142 else join_type=2-lcap;
11143 if ( (join_type==0)||(join_type==3) ) {
11144 @<Set the incoming and outgoing directions at |q|; in case of
11145 degeneracy set |join_type:=2|@>;
11146 if ( join_type==0 ) {
11147 @<If |miterlim| is less than the secant of half the angle at |q|
11148 then set |join_type:=2|@>;
11153 @ @<If |miterlim| is less than the secant of half the angle at |q|...@>=
11155 tmp=mp_take_fraction(mp, miterlim,fraction_half+
11156 half(mp_take_fraction(mp, dxin,dxout)+mp_take_fraction(mp, dyin,dyout)));
11158 if ( mp_take_scaled(mp, miterlim,tmp)<unity ) join_type=2;
11161 @ @<Other local variables for |make_envelope|@>=
11162 fraction dxin,dyin,dxout,dyout; /* directions at |q| when square or mitered */
11163 scaled tmp; /* a temporary value */
11165 @ The coordinates of |p| have already been shifted unless |p| is the first
11166 knot in which case they get shifted at the very end.
11168 @<Add offset |w| to the cubic from |p| to |q|@>=
11169 right_x(p)=right_x(p)+x_coord(w);
11170 right_y(p)=right_y(p)+y_coord(w);
11171 left_x(q)=left_x(q)+x_coord(w);
11172 left_y(q)=left_y(q)+y_coord(w);
11173 x_coord(q)=x_coord(q)+x_coord(w);
11174 y_coord(q)=y_coord(q)+y_coord(w);
11175 left_type(q)=mp_explicit;
11176 right_type(q)=mp_explicit
11178 @ @<Step |w| and move |k| one step closer to |zero_off|@>=
11179 if ( k>zero_off ){ w=link(w); decr(k); }
11180 else { w=knil(w); incr(k); }
11182 @ The cubic from |q| to the new knot at |(x,y)| becomes a line segment and
11183 the |right_x| and |right_y| fields of |r| are set from |q|. This is done in
11184 case the cubic containing these control points is ``yet to be examined.''
11186 @<Declare a function called |insert_knot|@>=
11187 pointer mp_insert_knot (MP mp,pointer q, scaled x, scaled y) {
11188 /* returns the inserted knot */
11189 pointer r; /* the new knot */
11190 r=mp_get_node(mp, knot_node_size);
11191 link(r)=link(q); link(q)=r;
11192 right_x(r)=right_x(q);
11193 right_y(r)=right_y(q);
11196 right_x(q)=x_coord(q);
11197 right_y(q)=y_coord(q);
11198 left_x(r)=x_coord(r);
11199 left_y(r)=y_coord(r);
11200 left_type(r)=mp_explicit;
11201 right_type(r)=mp_explicit;
11202 originator(r)=mp_program_code;
11206 @ After setting |p:=link(p)|, either |join_type=1| or |q=link(p)|.
11208 @<Set |p=link(p)| and add knots between |p| and |q| as...@>=
11211 if ( (join_type==0)||(join_type==3) ) {
11212 if ( join_type==0 ) {
11213 @<Insert a new knot |r| between |p| and |q| as required for a mitered join@>
11215 @<Make |r| the last of two knots inserted between |p| and |q| to form a
11219 right_x(r)=x_coord(r);
11220 right_y(r)=y_coord(r);
11225 @ For very small angles, adding a knot is unnecessary and would cause numerical
11226 problems, so we just set |r:=null| in that case.
11228 @<Insert a new knot |r| between |p| and |q| as required for a mitered join@>=
11230 det=mp_take_fraction(mp, dyout,dxin)-mp_take_fraction(mp, dxout,dyin);
11231 if ( abs(det)<26844 ) {
11232 r=null; /* sine $<10^{-4}$ */
11234 tmp=mp_take_fraction(mp, x_coord(q)-x_coord(p),dyout)-
11235 mp_take_fraction(mp, y_coord(q)-y_coord(p),dxout);
11236 tmp=mp_make_fraction(mp, tmp,det);
11237 r=mp_insert_knot(mp, p,x_coord(p)+mp_take_fraction(mp, tmp,dxin),
11238 y_coord(p)+mp_take_fraction(mp, tmp,dyin));
11242 @ @<Other local variables for |make_envelope|@>=
11243 fraction det; /* a determinant used for mitered join calculations */
11245 @ @<Make |r| the last of two knots inserted between |p| and |q| to form a...@>=
11247 ht_x=y_coord(w)-y_coord(w0);
11248 ht_y=x_coord(w0)-x_coord(w);
11249 while ( (abs(ht_x)<fraction_half)&&(abs(ht_y)<fraction_half) ) {
11250 ht_x+=ht_x; ht_y+=ht_y;
11252 @<Scan the pen polygon between |w0| and |w| and make |max_ht| the range dot
11253 product with |(ht_x,ht_y)|@>;
11254 tmp=mp_make_fraction(mp, max_ht,mp_take_fraction(mp, dxin,ht_x)+
11255 mp_take_fraction(mp, dyin,ht_y));
11256 r=mp_insert_knot(mp, p,x_coord(p)+mp_take_fraction(mp, tmp,dxin),
11257 y_coord(p)+mp_take_fraction(mp, tmp,dyin));
11258 tmp=mp_make_fraction(mp, max_ht,mp_take_fraction(mp, dxout,ht_x)+
11259 mp_take_fraction(mp, dyout,ht_y));
11260 r=mp_insert_knot(mp, r,x_coord(q)+mp_take_fraction(mp, tmp,dxout),
11261 y_coord(q)+mp_take_fraction(mp, tmp,dyout));
11264 @ @<Other local variables for |make_envelope|@>=
11265 fraction ht_x,ht_y; /* perpendicular to the segment from |p| to |q| */
11266 scaled max_ht; /* maximum height of the pen polygon above the |w0|-|w| line */
11267 halfword kk; /* keeps track of the pen vertices being scanned */
11268 pointer ww; /* the pen vertex being tested */
11270 @ The dot product of the vector from |w0| to |ww| with |(ht_x,ht_y)| ranges
11271 from zero to |max_ht|.
11273 @<Scan the pen polygon between |w0| and |w| and make |max_ht| the range...@>=
11278 @<Step |ww| and move |kk| one step closer to |k0|@>;
11279 if ( kk==k0 ) break;
11280 tmp=mp_take_fraction(mp, (x_coord(ww)-x_coord(w0)),ht_x)+
11281 mp_take_fraction(mp, (y_coord(ww)-y_coord(w0)),ht_y);
11282 if ( tmp>max_ht ) max_ht=tmp;
11286 @ @<Step |ww| and move |kk| one step closer to |k0|@>=
11287 if ( kk>k0 ) { ww=link(ww); decr(kk); }
11288 else { ww=knil(ww); incr(kk); }
11290 @ @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>=
11291 if ( left_type(c)==mp_endpoint ) {
11292 mp->spec_p1=mp_htap_ypoc(mp, c);
11293 mp->spec_p2=mp->path_tail;
11294 originator(mp->spec_p1)=mp_program_code;
11295 link(mp->spec_p2)=link(mp->spec_p1);
11296 link(mp->spec_p1)=c;
11297 mp_remove_cubic(mp, mp->spec_p1);
11299 if ( c!=link(c) ) {
11300 originator(mp->spec_p2)=mp_program_code;
11301 mp_remove_cubic(mp, mp->spec_p2);
11303 @<Make |c| look like a cycle of length one@>;
11307 @ @<Make |c| look like a cycle of length one@>=
11309 left_type(c)=mp_explicit; right_type(c)=mp_explicit;
11310 left_x(c)=x_coord(c); left_y(c)=y_coord(c);
11311 right_x(c)=x_coord(c); right_y(c)=y_coord(c);
11314 @ In degenerate situations we might have to look at the knot preceding~|q|.
11315 That knot is |p| but if |p<>c|, its coordinates have already been offset by |w|.
11317 @<Set the incoming and outgoing directions at |q|; in case of...@>=
11318 dxin=x_coord(q)-left_x(q);
11319 dyin=y_coord(q)-left_y(q);
11320 if ( (dxin==0)&&(dyin==0) ) {
11321 dxin=x_coord(q)-right_x(p);
11322 dyin=y_coord(q)-right_y(p);
11323 if ( (dxin==0)&&(dyin==0) ) {
11324 dxin=x_coord(q)-x_coord(p);
11325 dyin=y_coord(q)-y_coord(p);
11326 if ( p!=c ) { /* the coordinates of |p| have been offset by |w| */
11327 dxin=dxin+x_coord(w);
11328 dyin=dyin+y_coord(w);
11332 tmp=mp_pyth_add(mp, dxin,dyin);
11336 dxin=mp_make_fraction(mp, dxin,tmp);
11337 dyin=mp_make_fraction(mp, dyin,tmp);
11338 @<Set the outgoing direction at |q|@>;
11341 @ If |q=c| then the coordinates of |r| and the control points between |q|
11342 and~|r| have already been offset by |h|.
11344 @<Set the outgoing direction at |q|@>=
11345 dxout=right_x(q)-x_coord(q);
11346 dyout=right_y(q)-y_coord(q);
11347 if ( (dxout==0)&&(dyout==0) ) {
11349 dxout=left_x(r)-x_coord(q);
11350 dyout=left_y(r)-y_coord(q);
11351 if ( (dxout==0)&&(dyout==0) ) {
11352 dxout=x_coord(r)-x_coord(q);
11353 dyout=y_coord(r)-y_coord(q);
11357 dxout=dxout-x_coord(h);
11358 dyout=dyout-y_coord(h);
11360 tmp=mp_pyth_add(mp, dxout,dyout);
11361 if ( tmp==0 ) mp_confusion(mp, "degenerate spec");
11362 @:this can't happen degerate spec}{\quad degenerate spec@>
11363 dxout=mp_make_fraction(mp, dxout,tmp);
11364 dyout=mp_make_fraction(mp, dyout,tmp)
11366 @* \[23] Direction and intersection times.
11367 A path of length $n$ is defined parametrically by functions $x(t)$ and
11368 $y(t)$, for |0<=t<=n|; we can regard $t$ as the ``time'' at which the path
11369 reaches the point $\bigl(x(t),y(t)\bigr)$. In this section of the program
11370 we shall consider operations that determine special times associated with
11371 given paths: the first time that a path travels in a given direction, and
11372 a pair of times at which two paths cross each other.
11374 @ Let's start with the easier task. The function |find_direction_time| is
11375 given a direction |(x,y)| and a path starting at~|h|. If the path never
11376 travels in direction |(x,y)|, the direction time will be~|-1|; otherwise
11377 it will be nonnegative.
11379 Certain anomalous cases can arise: If |(x,y)=(0,0)|, so that the given
11380 direction is undefined, the direction time will be~0. If $\bigl(x'(t),
11381 y'(t)\bigr)=(0,0)$, so that the path direction is undefined, it will be
11382 assumed to match any given direction at time~|t|.
11384 The routine solves this problem in nondegenerate cases by rotating the path
11385 and the given direction so that |(x,y)=(1,0)|; i.e., the main task will be
11386 to find when a given path first travels ``due east.''
11389 scaled mp_find_direction_time (MP mp,scaled x, scaled y, pointer h) {
11390 scaled max; /* $\max\bigl(\vert x\vert,\vert y\vert\bigr)$ */
11391 pointer p,q; /* for list traversal */
11392 scaled n; /* the direction time at knot |p| */
11393 scaled tt; /* the direction time within a cubic */
11394 @<Other local variables for |find_direction_time|@>;
11395 @<Normalize the given direction for better accuracy;
11396 but |return| with zero result if it's zero@>;
11399 if ( right_type(p)==mp_endpoint ) break;
11401 @<Rotate the cubic between |p| and |q|; then
11402 |goto found| if the rotated cubic travels due east at some time |tt|;
11403 but |break| if an entire cyclic path has been traversed@>;
11411 @ @<Normalize the given direction for better accuracy...@>=
11412 if ( abs(x)<abs(y) ) {
11413 x=mp_make_fraction(mp, x,abs(y));
11414 if ( y>0 ) y=fraction_one; else y=-fraction_one;
11415 } else if ( x==0 ) {
11418 y=mp_make_fraction(mp, y,abs(x));
11419 if ( x>0 ) x=fraction_one; else x=-fraction_one;
11422 @ Since we're interested in the tangent directions, we work with the
11423 derivative $${1\over3}B'(x_0,x_1,x_2,x_3;t)=
11424 B(x_1-x_0,x_2-x_1,x_3-x_2;t)$$ instead of
11425 $B(x_0,x_1,x_2,x_3;t)$ itself. The derived coefficients are also scaled up
11426 in order to achieve better accuracy.
11428 The given path may turn abruptly at a knot, and it might pass the critical
11429 tangent direction at such a time. Therefore we remember the direction |phi|
11430 in which the previous rotated cubic was traveling. (The value of |phi| will be
11431 undefined on the first cubic, i.e., when |n=0|.)
11433 @<Rotate the cubic between |p| and |q|; then...@>=
11435 @<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples of the control
11436 points of the rotated derivatives@>;
11437 if ( y1==0 ) if ( x1>=0 ) goto FOUND;
11439 @<Exit to |found| if an eastward direction occurs at knot |p|@>;
11442 if ( (x3!=0)||(y3!=0) ) phi=mp_n_arg(mp, x3,y3);
11443 @<Exit to |found| if the curve whose derivatives are specified by
11444 |x1,x2,x3,y1,y2,y3| travels eastward at some time~|tt|@>
11446 @ @<Other local variables for |find_direction_time|@>=
11447 scaled x1,x2,x3,y1,y2,y3; /* multiples of rotated derivatives */
11448 angle theta,phi; /* angles of exit and entry at a knot */
11449 fraction t; /* temp storage */
11451 @ @<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples...@>=
11452 x1=right_x(p)-x_coord(p); x2=left_x(q)-right_x(p);
11453 x3=x_coord(q)-left_x(q);
11454 y1=right_y(p)-y_coord(p); y2=left_y(q)-right_y(p);
11455 y3=y_coord(q)-left_y(q);
11457 if ( abs(x2)>max ) max=abs(x2);
11458 if ( abs(x3)>max ) max=abs(x3);
11459 if ( abs(y1)>max ) max=abs(y1);
11460 if ( abs(y2)>max ) max=abs(y2);
11461 if ( abs(y3)>max ) max=abs(y3);
11462 if ( max==0 ) goto FOUND;
11463 while ( max<fraction_half ){
11464 max+=max; x1+=x1; x2+=x2; x3+=x3;
11465 y1+=y1; y2+=y2; y3+=y3;
11467 t=x1; x1=mp_take_fraction(mp, x1,x)+mp_take_fraction(mp, y1,y);
11468 y1=mp_take_fraction(mp, y1,x)-mp_take_fraction(mp, t,y);
11469 t=x2; x2=mp_take_fraction(mp, x2,x)+mp_take_fraction(mp, y2,y);
11470 y2=mp_take_fraction(mp, y2,x)-mp_take_fraction(mp, t,y);
11471 t=x3; x3=mp_take_fraction(mp, x3,x)+mp_take_fraction(mp, y3,y);
11472 y3=mp_take_fraction(mp, y3,x)-mp_take_fraction(mp, t,y)
11474 @ @<Exit to |found| if an eastward direction occurs at knot |p|@>=
11475 theta=mp_n_arg(mp, x1,y1);
11476 if ( theta>=0 ) if ( phi<=0 ) if ( phi>=theta-one_eighty_deg ) goto FOUND;
11477 if ( theta<=0 ) if ( phi>=0 ) if ( phi<=theta+one_eighty_deg ) goto FOUND
11479 @ In this step we want to use the |crossing_point| routine to find the
11480 roots of the quadratic equation $B(y_1,y_2,y_3;t)=0$.
11481 Several complications arise: If the quadratic equation has a double root,
11482 the curve never crosses zero, and |crossing_point| will find nothing;
11483 this case occurs iff $y_1y_3=y_2^2$ and $y_1y_2<0$. If the quadratic
11484 equation has simple roots, or only one root, we may have to negate it
11485 so that $B(y_1,y_2,y_3;t)$ crosses from positive to negative at its first root.
11486 And finally, we need to do special things if $B(y_1,y_2,y_3;t)$ is
11489 @ @<Exit to |found| if the curve whose derivatives are specified by...@>=
11490 if ( x1<0 ) if ( x2<0 ) if ( x3<0 ) goto DONE;
11491 if ( mp_ab_vs_cd(mp, y1,y3,y2,y2)==0 ) {
11492 @<Handle the test for eastward directions when $y_1y_3=y_2^2$;
11493 either |goto found| or |goto done|@>;
11496 if ( y1<0 ) { y1=-y1; y2=-y2; y3=-y3; }
11497 else if ( y2>0 ){ y2=-y2; y3=-y3; };
11499 @<Check the places where $B(y_1,y_2,y_3;t)=0$ to see if
11500 $B(x_1,x_2,x_3;t)\ge0$@>;
11503 @ The quadratic polynomial $B(y_1,y_2,y_3;t)$ begins |>=0| and has at most
11504 two roots, because we know that it isn't identically zero.
11506 It must be admitted that the |crossing_point| routine is not perfectly accurate;
11507 rounding errors might cause it to find a root when $y_1y_3>y_2^2$, or to
11508 miss the roots when $y_1y_3<y_2^2$. The rotation process is itself
11509 subject to rounding errors. Yet this code optimistically tries to
11510 do the right thing.
11512 @d we_found_it { tt=(t+04000) / 010000; goto FOUND; }
11514 @<Check the places where $B(y_1,y_2,y_3;t)=0$...@>=
11515 t=mp_crossing_point(mp, y1,y2,y3);
11516 if ( t>fraction_one ) goto DONE;
11517 y2=t_of_the_way(y2,y3);
11518 x1=t_of_the_way(x1,x2);
11519 x2=t_of_the_way(x2,x3);
11520 x1=t_of_the_way(x1,x2);
11521 if ( x1>=0 ) we_found_it;
11523 tt=t; t=mp_crossing_point(mp, 0,-y2,-y3);
11524 if ( t>fraction_one ) goto DONE;
11525 x1=t_of_the_way(x1,x2);
11526 x2=t_of_the_way(x2,x3);
11527 if ( t_of_the_way(x1,x2)>=0 ) {
11528 t=t_of_the_way(tt,fraction_one); we_found_it;
11531 @ @<Handle the test for eastward directions when $y_1y_3=y_2^2$;
11532 either |goto found| or |goto done|@>=
11534 if ( mp_ab_vs_cd(mp, y1,y2,0,0)<0 ) {
11535 t=mp_make_fraction(mp, y1,y1-y2);
11536 x1=t_of_the_way(x1,x2);
11537 x2=t_of_the_way(x2,x3);
11538 if ( t_of_the_way(x1,x2)>=0 ) we_found_it;
11539 } else if ( y3==0 ) {
11541 @<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|@>;
11542 } else if ( x3>=0 ) {
11543 tt=unity; goto FOUND;
11549 @ At this point we know that the derivative of |y(t)| is identically zero,
11550 and that |x1<0|; but either |x2>=0| or |x3>=0|, so there's some hope of
11553 @<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|...@>=
11555 t=mp_crossing_point(mp, -x1,-x2,-x3);
11556 if ( t<=fraction_one ) we_found_it;
11557 if ( mp_ab_vs_cd(mp, x1,x3,x2,x2)<=0 ) {
11558 t=mp_make_fraction(mp, x1,x1-x2); we_found_it;
11562 @ The intersection of two cubics can be found by an interesting variant
11563 of the general bisection scheme described in the introduction to
11565 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)$,
11566 we wish to find a pair of times $(t_1,t_2)$ such that $w(t_1)=z(t_2)$,
11567 if an intersection exists. First we find the smallest rectangle that
11568 encloses the points $\{w_0,w_1,w_2,w_3\}$ and check that it overlaps
11569 the smallest rectangle that encloses
11570 $\{z_0,z_1,z_2,z_3\}$; if not, the cubics certainly don't intersect.
11571 But if the rectangles do overlap, we bisect the intervals, getting
11572 new cubics $w'$ and~$w''$, $z'$~and~$z''$; the intersection routine first
11573 tries for an intersection between $w'$ and~$z'$, then (if unsuccessful)
11574 between $w'$ and~$z''$, then (if still unsuccessful) between $w''$ and~$z'$,
11575 finally (if thrice unsuccessful) between $w''$ and~$z''$. After $l$~successful
11576 levels of bisection we will have determined the intersection times $t_1$
11577 and~$t_2$ to $l$~bits of accuracy.
11579 \def\submin{_{\rm min}} \def\submax{_{\rm max}}
11580 As before, it is better to work with the numbers $W_k=2^l(w_k-w_{k-1})$
11581 and $Z_k=2^l(z_k-z_{k-1})$ rather than the coefficients $w_k$ and $z_k$
11582 themselves. We also need one other quantity, $\Delta=2^l(w_0-z_0)$,
11583 to determine when the enclosing rectangles overlap. Here's why:
11584 The $x$~coordinates of~$w(t)$ are between $u\submin$ and $u\submax$,
11585 and the $x$~coordinates of~$z(t)$ are between $x\submin$ and $x\submax$,
11586 if we write $w_k=(u_k,v_k)$ and $z_k=(x_k,y_k)$ and $u\submin=
11587 \min(u_0,u_1,u_2,u_3)$, etc. These intervals of $x$~coordinates
11588 overlap if and only if $u\submin\L x\submax$ and
11589 $x\submin\L u\submax$. Letting
11590 $$U\submin=\min(0,U_1,U_1+U_2,U_1+U_2+U_3),\;
11591 U\submax=\max(0,U_1,U_1+U_2,U_1+U_2+U_3),$$
11592 we have $2^lu\submin=2^lu_0+U\submin$, etc.; the condition for overlap
11594 $$X\submin-U\submax\L 2^l(u_0-x_0)\L X\submax-U\submin.$$
11595 Thus we want to maintain the quantity $2^l(u_0-x_0)$; similarly,
11596 the quantity $2^l(v_0-y_0)$ accounts for the $y$~coordinates. The
11597 coordinates of $\Delta=2^l(w_0-z_0)$ must stay bounded as $l$ increases,
11598 because of the overlap condition; i.e., we know that $X\submin$,
11599 $X\submax$, and their relatives are bounded, hence $X\submax-
11600 U\submin$ and $X\submin-U\submax$ are bounded.
11602 @ Incidentally, if the given cubics intersect more than once, the process
11603 just sketched will not necessarily find the lexicographically smallest pair
11604 $(t_1,t_2)$. The solution actually obtained will be smallest in ``shuffled
11605 order''; i.e., if $t_1=(.a_1a_2\ldots a_{16})_2$ and
11606 $t_2=(.b_1b_2\ldots b_{16})_2$, then we will minimize
11607 $a_1b_1a_2b_2\ldots a_{16}b_{16}$, not
11608 $a_1a_2\ldots a_{16}b_1b_2\ldots b_{16}$.
11609 Shuffled order agrees with lexicographic order if all pairs of solutions
11610 $(t_1,t_2)$ and $(t_1',t_2')$ have the property that $t_1<t_1'$ iff
11611 $t_2<t_2'$; but in general, lexicographic order can be quite different,
11612 and the bisection algorithm would be substantially less efficient if it were
11613 constrained by lexicographic order.
11615 For example, suppose that an overlap has been found for $l=3$ and
11616 $(t_1,t_2)= (.101,.011)$ in binary, but that no overlap is produced by
11617 either of the alternatives $(.1010,.0110)$, $(.1010,.0111)$ at level~4.
11618 Then there is probably an intersection in one of the subintervals
11619 $(.1011,.011x)$; but lexicographic order would require us to explore
11620 $(.1010,.1xxx)$ and $(.1011,.00xx)$ and $(.1011,.010x)$ first. We wouldn't
11621 want to store all of the subdivision data for the second path, so the
11622 subdivisions would have to be regenerated many times. Such inefficiencies
11623 would be associated with every `1' in the binary representation of~$t_1$.
11625 @ The subdivision process introduces rounding errors, hence we need to
11626 make a more liberal test for overlap. It is not hard to show that the
11627 computed values of $U_i$ differ from the truth by at most~$l$, on
11628 level~$l$, hence $U\submin$ and $U\submax$ will be at most $3l$ in error.
11629 If $\beta$ is an upper bound on the absolute error in the computed
11630 components of $\Delta=(|delx|,|dely|)$ on level~$l$, we will replace
11631 the test `$X\submin-U\submax\L|delx|$' by the more liberal test
11632 `$X\submin-U\submax\L|delx|+|tol|$', where $|tol|=6l+\beta$.
11634 More accuracy is obtained if we try the algorithm first with |tol=0|;
11635 the more liberal tolerance is used only if an exact approach fails.
11636 It is convenient to do this double-take by letting `3' in the preceding
11637 paragraph be a parameter, which is first 0, then 3.
11640 unsigned int tol_step; /* either 0 or 3, usually */
11642 @ We shall use an explicit stack to implement the recursive bisection
11643 method described above. The |bisect_stack| array will contain numerous 5-word
11644 packets like $(U_1,U_2,U_3,U\submin,U\submax)$, as well as 20-word packets
11645 comprising the 5-word packets for $U$, $V$, $X$, and~$Y$.
11647 The following macros define the allocation of stack positions to
11648 the quantities needed for bisection-intersection.
11650 @d stack_1(A) mp->bisect_stack[(A)] /* $U_1$, $V_1$, $X_1$, or $Y_1$ */
11651 @d stack_2(A) mp->bisect_stack[(A)+1] /* $U_2$, $V_2$, $X_2$, or $Y_2$ */
11652 @d stack_3(A) mp->bisect_stack[(A)+2] /* $U_3$, $V_3$, $X_3$, or $Y_3$ */
11653 @d stack_min(A) mp->bisect_stack[(A)+3]
11654 /* $U\submin$, $V\submin$, $X\submin$, or $Y\submin$ */
11655 @d stack_max(A) mp->bisect_stack[(A)+4]
11656 /* $U\submax$, $V\submax$, $X\submax$, or $Y\submax$ */
11657 @d int_packets 20 /* number of words to represent $U_k$, $V_k$, $X_k$, and $Y_k$ */
11659 @d u_packet(A) ((A)-5)
11660 @d v_packet(A) ((A)-10)
11661 @d x_packet(A) ((A)-15)
11662 @d y_packet(A) ((A)-20)
11663 @d l_packets (mp->bisect_ptr-int_packets)
11664 @d r_packets mp->bisect_ptr
11665 @d ul_packet u_packet(l_packets) /* base of $U'_k$ variables */
11666 @d vl_packet v_packet(l_packets) /* base of $V'_k$ variables */
11667 @d xl_packet x_packet(l_packets) /* base of $X'_k$ variables */
11668 @d yl_packet y_packet(l_packets) /* base of $Y'_k$ variables */
11669 @d ur_packet u_packet(r_packets) /* base of $U''_k$ variables */
11670 @d vr_packet v_packet(r_packets) /* base of $V''_k$ variables */
11671 @d xr_packet x_packet(r_packets) /* base of $X''_k$ variables */
11672 @d yr_packet y_packet(r_packets) /* base of $Y''_k$ variables */
11674 @d u1l stack_1(ul_packet) /* $U'_1$ */
11675 @d u2l stack_2(ul_packet) /* $U'_2$ */
11676 @d u3l stack_3(ul_packet) /* $U'_3$ */
11677 @d v1l stack_1(vl_packet) /* $V'_1$ */
11678 @d v2l stack_2(vl_packet) /* $V'_2$ */
11679 @d v3l stack_3(vl_packet) /* $V'_3$ */
11680 @d x1l stack_1(xl_packet) /* $X'_1$ */
11681 @d x2l stack_2(xl_packet) /* $X'_2$ */
11682 @d x3l stack_3(xl_packet) /* $X'_3$ */
11683 @d y1l stack_1(yl_packet) /* $Y'_1$ */
11684 @d y2l stack_2(yl_packet) /* $Y'_2$ */
11685 @d y3l stack_3(yl_packet) /* $Y'_3$ */
11686 @d u1r stack_1(ur_packet) /* $U''_1$ */
11687 @d u2r stack_2(ur_packet) /* $U''_2$ */
11688 @d u3r stack_3(ur_packet) /* $U''_3$ */
11689 @d v1r stack_1(vr_packet) /* $V''_1$ */
11690 @d v2r stack_2(vr_packet) /* $V''_2$ */
11691 @d v3r stack_3(vr_packet) /* $V''_3$ */
11692 @d x1r stack_1(xr_packet) /* $X''_1$ */
11693 @d x2r stack_2(xr_packet) /* $X''_2$ */
11694 @d x3r stack_3(xr_packet) /* $X''_3$ */
11695 @d y1r stack_1(yr_packet) /* $Y''_1$ */
11696 @d y2r stack_2(yr_packet) /* $Y''_2$ */
11697 @d y3r stack_3(yr_packet) /* $Y''_3$ */
11699 @d stack_dx mp->bisect_stack[mp->bisect_ptr] /* stacked value of |delx| */
11700 @d stack_dy mp->bisect_stack[mp->bisect_ptr+1] /* stacked value of |dely| */
11701 @d stack_tol mp->bisect_stack[mp->bisect_ptr+2] /* stacked value of |tol| */
11702 @d stack_uv mp->bisect_stack[mp->bisect_ptr+3] /* stacked value of |uv| */
11703 @d stack_xy mp->bisect_stack[mp->bisect_ptr+4] /* stacked value of |xy| */
11704 @d int_increment (int_packets+int_packets+5) /* number of stack words per level */
11707 integer *bisect_stack;
11708 unsigned int bisect_ptr;
11710 @ @<Allocate or initialize ...@>=
11711 mp->bisect_stack = xmalloc((bistack_size+1),sizeof(integer));
11713 @ @<Dealloc variables@>=
11714 xfree(mp->bisect_stack);
11716 @ @<Check the ``constant''...@>=
11717 if ( int_packets+17*int_increment>bistack_size ) mp->bad=19;
11719 @ Computation of the min and max is a tedious but fairly fast sequence of
11720 instructions; exactly four comparisons are made in each branch.
11723 if ( stack_1((A))<0 ) {
11724 if ( stack_3((A))>=0 ) {
11725 if ( stack_2((A))<0 ) stack_min((A))=stack_1((A))+stack_2((A));
11726 else stack_min((A))=stack_1((A));
11727 stack_max((A))=stack_1((A))+stack_2((A))+stack_3((A));
11728 if ( stack_max((A))<0 ) stack_max((A))=0;
11730 stack_min((A))=stack_1((A))+stack_2((A))+stack_3((A));
11731 if ( stack_min((A))>stack_1((A)) ) stack_min((A))=stack_1((A));
11732 stack_max((A))=stack_1((A))+stack_2((A));
11733 if ( stack_max((A))<0 ) stack_max((A))=0;
11735 } else if ( stack_3((A))<=0 ) {
11736 if ( stack_2((A))>0 ) stack_max((A))=stack_1((A))+stack_2((A));
11737 else stack_max((A))=stack_1((A));
11738 stack_min((A))=stack_1((A))+stack_2((A))+stack_3((A));
11739 if ( stack_min((A))>0 ) stack_min((A))=0;
11741 stack_max((A))=stack_1((A))+stack_2((A))+stack_3((A));
11742 if ( stack_max((A))<stack_1((A)) ) stack_max((A))=stack_1((A));
11743 stack_min((A))=stack_1((A))+stack_2((A));
11744 if ( stack_min((A))>0 ) stack_min((A))=0;
11747 @ It's convenient to keep the current values of $l$, $t_1$, and $t_2$ in
11748 the integer form $2^l+2^lt_1$ and $2^l+2^lt_2$. The |cubic_intersection|
11749 routine uses global variables |cur_t| and |cur_tt| for this purpose;
11750 after successful completion, |cur_t| and |cur_tt| will contain |unity|
11751 plus the |scaled| values of $t_1$ and~$t_2$.
11753 The values of |cur_t| and |cur_tt| will be set to zero if |cubic_intersection|
11754 finds no intersection. The routine gives up and gives an approximate answer
11755 if it has backtracked
11756 more than 5000 times (otherwise there are cases where several minutes
11757 of fruitless computation would be possible).
11759 @d max_patience 5000
11762 integer cur_t;integer cur_tt; /* controls and results of |cubic_intersection| */
11763 integer time_to_go; /* this many backtracks before giving up */
11764 integer max_t; /* maximum of $2^{l+1}$ so far achieved */
11766 @ The given cubics $B(w_0,w_1,w_2,w_3;t)$ and
11767 $B(z_0,z_1,z_2,z_3;t)$ are specified in adjacent knot nodes |(p,link(p))|
11768 and |(pp,link(pp))|, respectively.
11770 @c void mp_cubic_intersection (MP mp,pointer p, pointer pp) {
11771 pointer q,qq; /* |link(p)|, |link(pp)| */
11772 mp->time_to_go=max_patience; mp->max_t=2;
11773 @<Initialize for intersections at level zero@>;
11776 if ( mp->delx-mp->tol<=stack_max(x_packet(mp->xy))-stack_min(u_packet(mp->uv)))
11777 if ( mp->delx+mp->tol>=stack_min(x_packet(mp->xy))-stack_max(u_packet(mp->uv)))
11778 if ( mp->dely-mp->tol<=stack_max(y_packet(mp->xy))-stack_min(v_packet(mp->uv)))
11779 if ( mp->dely+mp->tol>=stack_min(y_packet(mp->xy))-stack_max(v_packet(mp->uv)))
11781 if ( mp->cur_t>=mp->max_t ){
11782 if ( mp->max_t==two ) { /* we've done 17 bisections */
11783 mp->cur_t=halfp(mp->cur_t+1);
11784 mp->cur_tt=halfp(mp->cur_tt+1);
11787 mp->max_t+=mp->max_t; mp->appr_t=mp->cur_t; mp->appr_tt=mp->cur_tt;
11789 @<Subdivide for a new level of intersection@>;
11792 if ( mp->time_to_go>0 ) {
11793 decr(mp->time_to_go);
11795 while ( mp->appr_t<unity ) {
11796 mp->appr_t+=mp->appr_t; mp->appr_tt+=mp->appr_tt;
11798 mp->cur_t=mp->appr_t; mp->cur_tt=mp->appr_tt; return;
11800 @<Advance to the next pair |(cur_t,cur_tt)|@>;
11804 @ The following variables are global, although they are used only by
11805 |cubic_intersection|, because it is necessary on some machines to
11806 split |cubic_intersection| up into two procedures.
11809 integer delx;integer dely; /* the components of $\Delta=2^l(w_0-z_0)$ */
11810 integer tol; /* bound on the uncertainty in the overlap test */
11812 unsigned int xy; /* pointers to the current packets of interest */
11813 integer three_l; /* |tol_step| times the bisection level */
11814 integer appr_t;integer appr_tt; /* best approximations known to the answers */
11816 @ We shall assume that the coordinates are sufficiently non-extreme that
11817 integer overflow will not occur.
11818 @^overflow in arithmetic@>
11820 @<Initialize for intersections at level zero@>=
11821 q=link(p); qq=link(pp); mp->bisect_ptr=int_packets;
11822 u1r=right_x(p)-x_coord(p); u2r=left_x(q)-right_x(p);
11823 u3r=x_coord(q)-left_x(q); set_min_max(ur_packet);
11824 v1r=right_y(p)-y_coord(p); v2r=left_y(q)-right_y(p);
11825 v3r=y_coord(q)-left_y(q); set_min_max(vr_packet);
11826 x1r=right_x(pp)-x_coord(pp); x2r=left_x(qq)-right_x(pp);
11827 x3r=x_coord(qq)-left_x(qq); set_min_max(xr_packet);
11828 y1r=right_y(pp)-y_coord(pp); y2r=left_y(qq)-right_y(pp);
11829 y3r=y_coord(qq)-left_y(qq); set_min_max(yr_packet);
11830 mp->delx=x_coord(p)-x_coord(pp); mp->dely=y_coord(p)-y_coord(pp);
11831 mp->tol=0; mp->uv=r_packets; mp->xy=r_packets;
11832 mp->three_l=0; mp->cur_t=1; mp->cur_tt=1
11834 @ @<Subdivide for a new level of intersection@>=
11835 stack_dx=mp->delx; stack_dy=mp->dely; stack_tol=mp->tol;
11836 stack_uv=mp->uv; stack_xy=mp->xy;
11837 mp->bisect_ptr=mp->bisect_ptr+int_increment;
11838 mp->cur_t+=mp->cur_t; mp->cur_tt+=mp->cur_tt;
11839 u1l=stack_1(u_packet(mp->uv)); u3r=stack_3(u_packet(mp->uv));
11840 u2l=half(u1l+stack_2(u_packet(mp->uv)));
11841 u2r=half(u3r+stack_2(u_packet(mp->uv)));
11842 u3l=half(u2l+u2r); u1r=u3l;
11843 set_min_max(ul_packet); set_min_max(ur_packet);
11844 v1l=stack_1(v_packet(mp->uv)); v3r=stack_3(v_packet(mp->uv));
11845 v2l=half(v1l+stack_2(v_packet(mp->uv)));
11846 v2r=half(v3r+stack_2(v_packet(mp->uv)));
11847 v3l=half(v2l+v2r); v1r=v3l;
11848 set_min_max(vl_packet); set_min_max(vr_packet);
11849 x1l=stack_1(x_packet(mp->xy)); x3r=stack_3(x_packet(mp->xy));
11850 x2l=half(x1l+stack_2(x_packet(mp->xy)));
11851 x2r=half(x3r+stack_2(x_packet(mp->xy)));
11852 x3l=half(x2l+x2r); x1r=x3l;
11853 set_min_max(xl_packet); set_min_max(xr_packet);
11854 y1l=stack_1(y_packet(mp->xy)); y3r=stack_3(y_packet(mp->xy));
11855 y2l=half(y1l+stack_2(y_packet(mp->xy)));
11856 y2r=half(y3r+stack_2(y_packet(mp->xy)));
11857 y3l=half(y2l+y2r); y1r=y3l;
11858 set_min_max(yl_packet); set_min_max(yr_packet);
11859 mp->uv=l_packets; mp->xy=l_packets;
11860 mp->delx+=mp->delx; mp->dely+=mp->dely;
11861 mp->tol=mp->tol-mp->three_l+mp->tol_step;
11862 mp->tol+=mp->tol; mp->three_l=mp->three_l+mp->tol_step
11864 @ @<Advance to the next pair |(cur_t,cur_tt)|@>=
11866 if ( odd(mp->cur_tt) ) {
11867 if ( odd(mp->cur_t) ) {
11868 @<Descend to the previous level and |goto not_found|@>;
11871 mp->delx=mp->delx+stack_1(u_packet(mp->uv))+stack_2(u_packet(mp->uv))
11872 +stack_3(u_packet(mp->uv));
11873 mp->dely=mp->dely+stack_1(v_packet(mp->uv))+stack_2(v_packet(mp->uv))
11874 +stack_3(v_packet(mp->uv));
11875 mp->uv=mp->uv+int_packets; /* switch from |l_packets| to |r_packets| */
11876 decr(mp->cur_tt); mp->xy=mp->xy-int_packets;
11877 /* switch from |r_packets| to |l_packets| */
11878 mp->delx=mp->delx+stack_1(x_packet(mp->xy))+stack_2(x_packet(mp->xy))
11879 +stack_3(x_packet(mp->xy));
11880 mp->dely=mp->dely+stack_1(y_packet(mp->xy))+stack_2(y_packet(mp->xy))
11881 +stack_3(y_packet(mp->xy));
11884 incr(mp->cur_tt); mp->tol=mp->tol+mp->three_l;
11885 mp->delx=mp->delx-stack_1(x_packet(mp->xy))-stack_2(x_packet(mp->xy))
11886 -stack_3(x_packet(mp->xy));
11887 mp->dely=mp->dely-stack_1(y_packet(mp->xy))-stack_2(y_packet(mp->xy))
11888 -stack_3(y_packet(mp->xy));
11889 mp->xy=mp->xy+int_packets; /* switch from |l_packets| to |r_packets| */
11892 @ @<Descend to the previous level...@>=
11894 mp->cur_t=halfp(mp->cur_t); mp->cur_tt=halfp(mp->cur_tt);
11895 if ( mp->cur_t==0 ) return;
11896 mp->bisect_ptr=mp->bisect_ptr-int_increment;
11897 mp->three_l=mp->three_l-mp->tol_step;
11898 mp->delx=stack_dx; mp->dely=stack_dy; mp->tol=stack_tol;
11899 mp->uv=stack_uv; mp->xy=stack_xy;
11903 @ The |path_intersection| procedure is much simpler.
11904 It invokes |cubic_intersection| in lexicographic order until finding a
11905 pair of cubics that intersect. The final intersection times are placed in
11906 |cur_t| and~|cur_tt|.
11908 @c void mp_path_intersection (MP mp,pointer h, pointer hh) {
11909 pointer p,pp; /* link registers that traverse the given paths */
11910 integer n,nn; /* integer parts of intersection times, minus |unity| */
11911 @<Change one-point paths into dead cycles@>;
11916 if ( right_type(p)!=mp_endpoint ) {
11919 if ( right_type(pp)!=mp_endpoint ) {
11920 mp_cubic_intersection(mp, p,pp);
11921 if ( mp->cur_t>0 ) {
11922 mp->cur_t=mp->cur_t+n; mp->cur_tt=mp->cur_tt+nn;
11926 nn=nn+unity; pp=link(pp);
11929 n=n+unity; p=link(p);
11931 mp->tol_step=mp->tol_step+3;
11932 } while (mp->tol_step<=3);
11933 mp->cur_t=-unity; mp->cur_tt=-unity;
11936 @ @<Change one-point paths...@>=
11937 if ( right_type(h)==mp_endpoint ) {
11938 right_x(h)=x_coord(h); left_x(h)=x_coord(h);
11939 right_y(h)=y_coord(h); left_y(h)=y_coord(h); right_type(h)=mp_explicit;
11941 if ( right_type(hh)==mp_endpoint ) {
11942 right_x(hh)=x_coord(hh); left_x(hh)=x_coord(hh);
11943 right_y(hh)=y_coord(hh); left_y(hh)=y_coord(hh); right_type(hh)=mp_explicit;
11946 @* \[24] Dynamic linear equations.
11947 \MP\ users define variables implicitly by stating equations that should be
11948 satisfied; the computer is supposed to be smart enough to solve those equations.
11949 And indeed, the computer tries valiantly to do so, by distinguishing five
11950 different types of numeric values:
11953 |type(p)=mp_known| is the nice case, when |value(p)| is the |scaled| value
11954 of the variable whose address is~|p|.
11957 |type(p)=mp_dependent| means that |value(p)| is not present, but |dep_list(p)|
11958 points to a {\sl dependency list\/} that expresses the value of variable~|p|
11959 as a |scaled| number plus a sum of independent variables with |fraction|
11963 |type(p)=mp_independent| means that |value(p)=64s+m|, where |s>0| is a ``serial
11964 number'' reflecting the time this variable was first used in an equation;
11965 also |0<=m<64|, and each dependent variable
11966 that refers to this one is actually referring to the future value of
11967 this variable times~$2^m$. (Usually |m=0|, but higher degrees of
11968 scaling are sometimes needed to keep the coefficients in dependency lists
11969 from getting too large. The value of~|m| will always be even.)
11972 |type(p)=mp_numeric_type| means that variable |p| hasn't appeared in an
11973 equation before, but it has been explicitly declared to be numeric.
11976 |type(p)=undefined| means that variable |p| hasn't appeared before.
11978 \smallskip\noindent
11979 We have actually discussed these five types in the reverse order of their
11980 history during a computation: Once |known|, a variable never again
11981 becomes |dependent|; once |dependent|, it almost never again becomes
11982 |mp_independent|; once |mp_independent|, it never again becomes |mp_numeric_type|;
11983 and once |mp_numeric_type|, it never again becomes |undefined| (except
11984 of course when the user specifically decides to scrap the old value
11985 and start again). A backward step may, however, take place: Sometimes
11986 a |dependent| variable becomes |mp_independent| again, when one of the
11987 independent variables it depends on is reverting to |undefined|.
11990 The next patch detects overflow of independent-variable serial
11991 numbers. Diagnosed and patched by Thorsten Dahlheimer.
11993 @d s_scale 64 /* the serial numbers are multiplied by this factor */
11994 @d new_indep(A) /* create a new independent variable */
11995 { if ( mp->serial_no>el_gordo-s_scale )
11996 mp_fatal_error(mp, "variable instance identifiers exhausted");
11997 type((A))=mp_independent; mp->serial_no=mp->serial_no+s_scale;
11998 value((A))=mp->serial_no;
12002 integer serial_no; /* the most recent serial number, times |s_scale| */
12004 @ @<Make variable |q+s| newly independent@>=new_indep(q+s)
12006 @ But how are dependency lists represented? It's simple: The linear combination
12007 $\alpha_1v_1+\cdots+\alpha_kv_k+\beta$ appears in |k+1| value nodes. If
12008 |q=dep_list(p)| points to this list, and if |k>0|, then |value(q)=
12009 @t$\alpha_1$@>| (which is a |fraction|); |info(q)| points to the location
12010 of $\alpha_1$; and |link(p)| points to the dependency list
12011 $\alpha_2v_2+\cdots+\alpha_kv_k+\beta$. On the other hand if |k=0|,
12012 then |value(q)=@t$\beta$@>| (which is |scaled|) and |info(q)=null|.
12013 The independent variables $v_1$, \dots,~$v_k$ have been sorted so that
12014 they appear in decreasing order of their |value| fields (i.e., of
12015 their serial numbers). \ (It is convenient to use decreasing order,
12016 since |value(null)=0|. If the independent variables were not sorted by
12017 serial number but by some other criterion, such as their location in |mem|,
12018 the equation-solving mechanism would be too system-dependent, because
12019 the ordering can affect the computed results.)
12021 The |link| field in the node that contains the constant term $\beta$ is
12022 called the {\sl final link\/} of the dependency list. \MP\ maintains
12023 a doubly-linked master list of all dependency lists, in terms of a permanently
12025 in |mem| called |dep_head|. If there are no dependencies, we have
12026 |link(dep_head)=dep_head| and |prev_dep(dep_head)=dep_head|;
12027 otherwise |link(dep_head)| points to the first dependent variable, say~|p|,
12028 and |prev_dep(p)=dep_head|. We have |type(p)=mp_dependent|, and |dep_list(p)|
12029 points to its dependency list. If the final link of that dependency list
12030 occurs in location~|q|, then |link(q)| points to the next dependent
12031 variable (say~|r|); and we have |prev_dep(r)=q|, etc.
12033 @d dep_list(A) link(value_loc((A)))
12034 /* half of the |value| field in a |dependent| variable */
12035 @d prev_dep(A) info(value_loc((A)))
12036 /* the other half; makes a doubly linked list */
12037 @d dep_node_size 2 /* the number of words per dependency node */
12039 @<Initialize table entries...@>= mp->serial_no=0;
12040 link(dep_head)=dep_head; prev_dep(dep_head)=dep_head;
12041 info(dep_head)=null; dep_list(dep_head)=null;
12043 @ Actually the description above contains a little white lie. There's
12044 another kind of variable called |mp_proto_dependent|, which is
12045 just like a |dependent| one except that the $\alpha$ coefficients
12046 in its dependency list are |scaled| instead of being fractions.
12047 Proto-dependency lists are mixed with dependency lists in the
12048 nodes reachable from |dep_head|.
12050 @ Here is a procedure that prints a dependency list in symbolic form.
12051 The second parameter should be either |dependent| or |mp_proto_dependent|,
12052 to indicate the scaling of the coefficients.
12054 @<Declare subroutines for printing expressions@>=
12055 void mp_print_dependency (MP mp,pointer p, small_number t) {
12056 integer v; /* a coefficient */
12057 pointer pp,q; /* for list manipulation */
12060 v=abs(value(p)); q=info(p);
12061 if ( q==null ) { /* the constant term */
12062 if ( (v!=0)||(p==pp) ) {
12063 if ( value(p)>0 ) if ( p!=pp ) mp_print_char(mp, '+');
12064 mp_print_scaled(mp, value(p));
12068 @<Print the coefficient, unless it's $\pm1.0$@>;
12069 if ( type(q)!=mp_independent ) mp_confusion(mp, "dep");
12070 @:this can't happen dep}{\quad dep@>
12071 mp_print_variable_name(mp, q); v=value(q) % s_scale;
12072 while ( v>0 ) { mp_print(mp, "*4"); v=v-2; }
12077 @ @<Print the coefficient, unless it's $\pm1.0$@>=
12078 if ( value(p)<0 ) mp_print_char(mp, '-');
12079 else if ( p!=pp ) mp_print_char(mp, '+');
12080 if ( t==mp_dependent ) v=mp_round_fraction(mp, v);
12081 if ( v!=unity ) mp_print_scaled(mp, v)
12083 @ The maximum absolute value of a coefficient in a given dependency list
12084 is returned by the following simple function.
12086 @c fraction mp_max_coef (MP mp,pointer p) {
12087 fraction x; /* the maximum so far */
12089 while ( info(p)!=null ) {
12090 if ( abs(value(p))>x ) x=abs(value(p));
12096 @ One of the main operations needed on dependency lists is to add a multiple
12097 of one list to the other; we call this |p_plus_fq|, where |p| and~|q| point
12098 to dependency lists and |f| is a fraction.
12100 If the coefficient of any independent variable becomes |coef_bound| or
12101 more, in absolute value, this procedure changes the type of that variable
12102 to `|independent_needing_fix|', and sets the global variable |fix_needed|
12103 to~|true|. The value of $|coef_bound|=\mu$ is chosen so that
12104 $\mu^2+\mu<8$; this means that the numbers we deal with won't
12105 get too large. (Instead of the ``optimum'' $\mu=(\sqrt{33}-1)/2\approx
12106 2.3723$, the safer value 7/3 is taken as the threshold.)
12108 The changes mentioned in the preceding paragraph are actually done only if
12109 the global variable |watch_coefs| is |true|. But it usually is; in fact,
12110 it is |false| only when \MP\ is making a dependency list that will soon
12111 be equated to zero.
12113 Several procedures that act on dependency lists, including |p_plus_fq|,
12114 set the global variable |dep_final| to the final (constant term) node of
12115 the dependency list that they produce.
12117 @d coef_bound 04525252525 /* |fraction| approximation to 7/3 */
12118 @d independent_needing_fix 0
12121 boolean fix_needed; /* does at least one |independent| variable need scaling? */
12122 boolean watch_coefs; /* should we scale coefficients that exceed |coef_bound|? */
12123 pointer dep_final; /* location of the constant term and final link */
12126 mp->fix_needed=false; mp->watch_coefs=true;
12128 @ The |p_plus_fq| procedure has a fourth parameter, |t|, that should be
12129 set to |mp_proto_dependent| if |p| is a proto-dependency list. In this
12130 case |f| will be |scaled|, not a |fraction|. Similarly, the fifth parameter~|tt|
12131 should be |mp_proto_dependent| if |q| is a proto-dependency list.
12133 List |q| is unchanged by the operation; but list |p| is totally destroyed.
12135 The final link of the dependency list or proto-dependency list returned
12136 by |p_plus_fq| is the same as the original final link of~|p|. Indeed, the
12137 constant term of the result will be located in the same |mem| location
12138 as the original constant term of~|p|.
12140 Coefficients of the result are assumed to be zero if they are less than
12141 a certain threshold. This compensates for inevitable rounding errors,
12142 and tends to make more variables `|known|'. The threshold is approximately
12143 $10^{-5}$ in the case of normal dependency lists, $10^{-4}$ for
12144 proto-dependencies.
12146 @d fraction_threshold 2685 /* a |fraction| coefficient less than this is zeroed */
12147 @d half_fraction_threshold 1342 /* half of |fraction_threshold| */
12148 @d scaled_threshold 8 /* a |scaled| coefficient less than this is zeroed */
12149 @d half_scaled_threshold 4 /* half of |scaled_threshold| */
12151 @<Declare basic dependency-list subroutines@>=
12152 pointer mp_p_plus_fq ( MP mp, pointer p, integer f,
12153 pointer q, small_number t, small_number tt) ;
12156 pointer mp_p_plus_fq ( MP mp, pointer p, integer f,
12157 pointer q, small_number t, small_number tt) {
12158 pointer pp,qq; /* |info(p)| and |info(q)|, respectively */
12159 pointer r,s; /* for list manipulation */
12160 integer threshold; /* defines a neighborhood of zero */
12161 integer v; /* temporary register */
12162 if ( t==mp_dependent ) threshold=fraction_threshold;
12163 else threshold=scaled_threshold;
12164 r=temp_head; pp=info(p); qq=info(q);
12170 @<Contribute a term from |p|, plus |f| times the
12171 corresponding term from |q|@>
12173 } else if ( value(pp)<value(qq) ) {
12174 @<Contribute a term from |q|, multiplied by~|f|@>
12176 link(r)=p; r=p; p=link(p); pp=info(p);
12179 if ( t==mp_dependent )
12180 value(p)=mp_slow_add(mp, value(p),mp_take_fraction(mp, value(q),f));
12182 value(p)=mp_slow_add(mp, value(p),mp_take_scaled(mp, value(q),f));
12183 link(r)=p; mp->dep_final=p;
12184 return link(temp_head);
12187 @ @<Contribute a term from |p|, plus |f|...@>=
12189 if ( tt==mp_dependent ) v=value(p)+mp_take_fraction(mp, f,value(q));
12190 else v=value(p)+mp_take_scaled(mp, f,value(q));
12191 value(p)=v; s=p; p=link(p);
12192 if ( abs(v)<threshold ) {
12193 mp_free_node(mp, s,dep_node_size);
12195 if ( (abs(v)>=coef_bound) && mp->watch_coefs ) {
12196 type(qq)=independent_needing_fix; mp->fix_needed=true;
12200 pp=info(p); q=link(q); qq=info(q);
12203 @ @<Contribute a term from |q|, multiplied by~|f|@>=
12205 if ( tt==mp_dependent ) v=mp_take_fraction(mp, f,value(q));
12206 else v=mp_take_scaled(mp, f,value(q));
12207 if ( abs(v)>halfp(threshold) ) {
12208 s=mp_get_node(mp, dep_node_size); info(s)=qq; value(s)=v;
12209 if ( (abs(v)>=coef_bound) && mp->watch_coefs ) {
12210 type(qq)=independent_needing_fix; mp->fix_needed=true;
12214 q=link(q); qq=info(q);
12217 @ It is convenient to have another subroutine for the special case
12218 of |p_plus_fq| when |f=1.0|. In this routine lists |p| and |q| are
12219 both of the same type~|t| (either |dependent| or |mp_proto_dependent|).
12221 @c pointer mp_p_plus_q (MP mp,pointer p, pointer q, small_number t) {
12222 pointer pp,qq; /* |info(p)| and |info(q)|, respectively */
12223 pointer r,s; /* for list manipulation */
12224 integer threshold; /* defines a neighborhood of zero */
12225 integer v; /* temporary register */
12226 if ( t==mp_dependent ) threshold=fraction_threshold;
12227 else threshold=scaled_threshold;
12228 r=temp_head; pp=info(p); qq=info(q);
12234 @<Contribute a term from |p|, plus the
12235 corresponding term from |q|@>
12238 if ( value(pp)<value(qq) ) {
12239 s=mp_get_node(mp, dep_node_size); info(s)=qq; value(s)=value(q);
12240 q=link(q); qq=info(q); link(r)=s; r=s;
12242 link(r)=p; r=p; p=link(p); pp=info(p);
12246 value(p)=mp_slow_add(mp, value(p),value(q));
12247 link(r)=p; mp->dep_final=p;
12248 return link(temp_head);
12251 @ @<Contribute a term from |p|, plus the...@>=
12253 v=value(p)+value(q);
12254 value(p)=v; s=p; p=link(p); pp=info(p);
12255 if ( abs(v)<threshold ) {
12256 mp_free_node(mp, s,dep_node_size);
12258 if ( (abs(v)>=coef_bound ) && mp->watch_coefs ) {
12259 type(qq)=independent_needing_fix; mp->fix_needed=true;
12263 q=link(q); qq=info(q);
12266 @ A somewhat simpler routine will multiply a dependency list
12267 by a given constant~|v|. The constant is either a |fraction| less than
12268 |fraction_one|, or it is |scaled|. In the latter case we might be forced to
12269 convert a dependency list to a proto-dependency list.
12270 Parameters |t0| and |t1| are the list types before and after;
12271 they should agree unless |t0=mp_dependent| and |t1=mp_proto_dependent|
12272 and |v_is_scaled=true|.
12274 @c pointer mp_p_times_v (MP mp,pointer p, integer v, small_number t0,
12275 small_number t1, boolean v_is_scaled) {
12276 pointer r,s; /* for list manipulation */
12277 integer w; /* tentative coefficient */
12279 boolean scaling_down;
12280 if ( t0!=t1 ) scaling_down=true; else scaling_down=(!v_is_scaled);
12281 if ( t1==mp_dependent ) threshold=half_fraction_threshold;
12282 else threshold=half_scaled_threshold;
12284 while ( info(p)!=null ) {
12285 if ( scaling_down ) w=mp_take_fraction(mp, v,value(p));
12286 else w=mp_take_scaled(mp, v,value(p));
12287 if ( abs(w)<=threshold ) {
12288 s=link(p); mp_free_node(mp, p,dep_node_size); p=s;
12290 if ( abs(w)>=coef_bound ) {
12291 mp->fix_needed=true; type(info(p))=independent_needing_fix;
12293 link(r)=p; r=p; value(p)=w; p=link(p);
12297 if ( v_is_scaled ) value(p)=mp_take_scaled(mp, value(p),v);
12298 else value(p)=mp_take_fraction(mp, value(p),v);
12299 return link(temp_head);
12302 @ Similarly, we sometimes need to divide a dependency list
12303 by a given |scaled| constant.
12305 @<Declare basic dependency-list subroutines@>=
12306 pointer mp_p_over_v (MP mp,pointer p, scaled v, small_number
12307 t0, small_number t1) ;
12310 pointer mp_p_over_v (MP mp,pointer p, scaled v, small_number
12311 t0, small_number t1) {
12312 pointer r,s; /* for list manipulation */
12313 integer w; /* tentative coefficient */
12315 boolean scaling_down;
12316 if ( t0!=t1 ) scaling_down=true; else scaling_down=false;
12317 if ( t1==mp_dependent ) threshold=half_fraction_threshold;
12318 else threshold=half_scaled_threshold;
12320 while ( info( p)!=null ) {
12321 if ( scaling_down ) {
12322 if ( abs(v)<02000000 ) w=mp_make_scaled(mp, value(p),v*010000);
12323 else w=mp_make_scaled(mp, mp_round_fraction(mp, value(p)),v);
12325 w=mp_make_scaled(mp, value(p),v);
12327 if ( abs(w)<=threshold ) {
12328 s=link(p); mp_free_node(mp, p,dep_node_size); p=s;
12330 if ( abs(w)>=coef_bound ) {
12331 mp->fix_needed=true; type(info(p))=independent_needing_fix;
12333 link(r)=p; r=p; value(p)=w; p=link(p);
12336 link(r)=p; value(p)=mp_make_scaled(mp, value(p),v);
12337 return link(temp_head);
12340 @ Here's another utility routine for dependency lists. When an independent
12341 variable becomes dependent, we want to remove it from all existing
12342 dependencies. The |p_with_x_becoming_q| function computes the
12343 dependency list of~|p| after variable~|x| has been replaced by~|q|.
12345 This procedure has basically the same calling conventions as |p_plus_fq|:
12346 List~|q| is unchanged; list~|p| is destroyed; the constant node and the
12347 final link are inherited from~|p|; and the fourth parameter tells whether
12348 or not |p| is |mp_proto_dependent|. However, the global variable |dep_final|
12349 is not altered if |x| does not occur in list~|p|.
12351 @c pointer mp_p_with_x_becoming_q (MP mp,pointer p,
12352 pointer x, pointer q, small_number t) {
12353 pointer r,s; /* for list manipulation */
12354 integer v; /* coefficient of |x| */
12355 integer sx; /* serial number of |x| */
12356 s=p; r=temp_head; sx=value(x);
12357 while ( value(info(s))>sx ) { r=s; s=link(s); };
12358 if ( info(s)!=x ) {
12361 link(temp_head)=p; link(r)=link(s); v=value(s);
12362 mp_free_node(mp, s,dep_node_size);
12363 return mp_p_plus_fq(mp, link(temp_head),v,q,t,mp_dependent);
12367 @ Here's a simple procedure that reports an error when a variable
12368 has just received a known value that's out of the required range.
12370 @<Declare basic dependency-list subroutines@>=
12371 void mp_val_too_big (MP mp,scaled x) ;
12373 @ @c void mp_val_too_big (MP mp,scaled x) {
12374 if ( mp->internal[mp_warning_check]>0 ) {
12375 print_err("Value is too large ("); mp_print_scaled(mp, x); mp_print_char(mp, ')');
12376 @.Value is too large@>
12377 help4("The equation I just processed has given some variable")
12378 ("a value of 4096 or more. Continue and I'll try to cope")
12379 ("with that big value; but it might be dangerous.")
12380 ("(Set warningcheck:=0 to suppress this message.)");
12385 @ When a dependent variable becomes known, the following routine
12386 removes its dependency list. Here |p| points to the variable, and
12387 |q| points to the dependency list (which is one node long).
12389 @<Declare basic dependency-list subroutines@>=
12390 void mp_make_known (MP mp,pointer p, pointer q) ;
12392 @ @c void mp_make_known (MP mp,pointer p, pointer q) {
12393 int t; /* the previous type */
12394 prev_dep(link(q))=prev_dep(p);
12395 link(prev_dep(p))=link(q); t=type(p);
12396 type(p)=mp_known; value(p)=value(q); mp_free_node(mp, q,dep_node_size);
12397 if ( abs(value(p))>=fraction_one ) mp_val_too_big(mp, value(p));
12398 if (( mp->internal[mp_tracing_equations]>0) && mp_interesting(mp, p) ) {
12399 mp_begin_diagnostic(mp); mp_print_nl(mp, "#### ");
12400 @:]]]\#\#\#\#_}{\.{\#\#\#\#}@>
12401 mp_print_variable_name(mp, p);
12402 mp_print_char(mp, '='); mp_print_scaled(mp, value(p));
12403 mp_end_diagnostic(mp, false);
12405 if (( mp->cur_exp==p ) && mp->cur_type==t ) {
12406 mp->cur_type=mp_known; mp->cur_exp=value(p);
12407 mp_free_node(mp, p,value_node_size);
12411 @ The |fix_dependencies| routine is called into action when |fix_needed|
12412 has been triggered. The program keeps a list~|s| of independent variables
12413 whose coefficients must be divided by~4.
12415 In unusual cases, this fixup process might reduce one or more coefficients
12416 to zero, so that a variable will become known more or less by default.
12418 @<Declare basic dependency-list subroutines@>=
12419 void mp_fix_dependencies (MP mp);
12421 @ @c void mp_fix_dependencies (MP mp) {
12422 pointer p,q,r,s,t; /* list manipulation registers */
12423 pointer x; /* an independent variable */
12424 r=link(dep_head); s=null;
12425 while ( r!=dep_head ){
12427 @<Run through the dependency list for variable |t|, fixing
12428 all nodes, and ending with final link~|q|@>;
12430 if ( q==dep_list(t) ) mp_make_known(mp, t,q);
12432 while ( s!=null ) {
12433 p=link(s); x=info(s); free_avail(s); s=p;
12434 type(x)=mp_independent; value(x)=value(x)+2;
12436 mp->fix_needed=false;
12439 @ @d independent_being_fixed 1 /* this variable already appears in |s| */
12441 @<Run through the dependency list for variable |t|...@>=
12442 r=value_loc(t); /* |link(r)=dep_list(t)| */
12444 q=link(r); x=info(q);
12445 if ( x==null ) break;
12446 if ( type(x)<=independent_being_fixed ) {
12447 if ( type(x)<independent_being_fixed ) {
12448 p=mp_get_avail(mp); link(p)=s; s=p;
12449 info(s)=x; type(x)=independent_being_fixed;
12451 value(q)=value(q) / 4;
12452 if ( value(q)==0 ) {
12453 link(r)=link(q); mp_free_node(mp, q,dep_node_size); q=r;
12460 @ The |new_dep| routine installs a dependency list~|p| into the value node~|q|,
12461 linking it into the list of all known dependencies. We assume that
12462 |dep_final| points to the final node of list~|p|.
12464 @c void mp_new_dep (MP mp,pointer q, pointer p) {
12465 pointer r; /* what used to be the first dependency */
12466 dep_list(q)=p; prev_dep(q)=dep_head;
12467 r=link(dep_head); link(mp->dep_final)=r; prev_dep(r)=mp->dep_final;
12471 @ Here is one of the ways a dependency list gets started.
12472 The |const_dependency| routine produces a list that has nothing but
12475 @c pointer mp_const_dependency (MP mp, scaled v) {
12476 mp->dep_final=mp_get_node(mp, dep_node_size);
12477 value(mp->dep_final)=v; info(mp->dep_final)=null;
12478 return mp->dep_final;
12481 @ And here's a more interesting way to start a dependency list from scratch:
12482 The parameter to |single_dependency| is the location of an
12483 independent variable~|x|, and the result is the simple dependency list
12486 In the unlikely event that the given independent variable has been doubled so
12487 often that we can't refer to it with a nonzero coefficient,
12488 |single_dependency| returns the simple list `0'. This case can be
12489 recognized by testing that the returned list pointer is equal to
12492 @c pointer mp_single_dependency (MP mp,pointer p) {
12493 pointer q; /* the new dependency list */
12494 integer m; /* the number of doublings */
12495 m=value(p) % s_scale;
12497 return mp_const_dependency(mp, 0);
12499 q=mp_get_node(mp, dep_node_size);
12500 value(q)=two_to_the(28-m); info(q)=p;
12501 link(q)=mp_const_dependency(mp, 0);
12506 @ We sometimes need to make an exact copy of a dependency list.
12508 @c pointer mp_copy_dep_list (MP mp,pointer p) {
12509 pointer q; /* the new dependency list */
12510 q=mp_get_node(mp, dep_node_size); mp->dep_final=q;
12512 info(mp->dep_final)=info(p); value(mp->dep_final)=value(p);
12513 if ( info(mp->dep_final)==null ) break;
12514 link(mp->dep_final)=mp_get_node(mp, dep_node_size);
12515 mp->dep_final=link(mp->dep_final); p=link(p);
12520 @ But how do variables normally become known? Ah, now we get to the heart of the
12521 equation-solving mechanism. The |linear_eq| procedure is given a |dependent|
12522 or |mp_proto_dependent| list,~|p|, in which at least one independent variable
12523 appears. It equates this list to zero, by choosing an independent variable
12524 with the largest coefficient and making it dependent on the others. The
12525 newly dependent variable is eliminated from all current dependencies,
12526 thereby possibly making other dependent variables known.
12528 The given list |p| is, of course, totally destroyed by all this processing.
12530 @c void mp_linear_eq (MP mp, pointer p, small_number t) {
12531 pointer q,r,s; /* for link manipulation */
12532 pointer x; /* the variable that loses its independence */
12533 integer n; /* the number of times |x| had been halved */
12534 integer v; /* the coefficient of |x| in list |p| */
12535 pointer prev_r; /* lags one step behind |r| */
12536 pointer final_node; /* the constant term of the new dependency list */
12537 integer w; /* a tentative coefficient */
12538 @<Find a node |q| in list |p| whose coefficient |v| is largest@>;
12539 x=info(q); n=value(x) % s_scale;
12540 @<Divide list |p| by |-v|, removing node |q|@>;
12541 if ( mp->internal[mp_tracing_equations]>0 ) {
12542 @<Display the new dependency@>;
12544 @<Simplify all existing dependencies by substituting for |x|@>;
12545 @<Change variable |x| from |independent| to |dependent| or |known|@>;
12546 if ( mp->fix_needed ) mp_fix_dependencies(mp);
12549 @ @<Find a node |q| in list |p| whose coefficient |v| is largest@>=
12550 q=p; r=link(p); v=value(q);
12551 while ( info(r)!=null ) {
12552 if ( abs(value(r))>abs(v) ) { q=r; v=value(r); };
12556 @ Here we want to change the coefficients from |scaled| to |fraction|,
12557 except in the constant term. In the common case of a trivial equation
12558 like `\.{x=3.14}', we will have |v=-fraction_one|, |q=p|, and |t=mp_dependent|.
12560 @<Divide list |p| by |-v|, removing node |q|@>=
12561 s=temp_head; link(s)=p; r=p;
12564 link(s)=link(r); mp_free_node(mp, r,dep_node_size);
12566 w=mp_make_fraction(mp, value(r),v);
12567 if ( abs(w)<=half_fraction_threshold ) {
12568 link(s)=link(r); mp_free_node(mp, r,dep_node_size);
12574 } while (info(r)!=null);
12575 if ( t==mp_proto_dependent ) {
12576 value(r)=-mp_make_scaled(mp, value(r),v);
12577 } else if ( v!=-fraction_one ) {
12578 value(r)=-mp_make_fraction(mp, value(r),v);
12580 final_node=r; p=link(temp_head)
12582 @ @<Display the new dependency@>=
12583 if ( mp_interesting(mp, x) ) {
12584 mp_begin_diagnostic(mp); mp_print_nl(mp, "## ");
12585 mp_print_variable_name(mp, x);
12586 @:]]]\#\#_}{\.{\#\#}@>
12588 while ( w>0 ) { mp_print(mp, "*4"); w=w-2; };
12589 mp_print_char(mp, '='); mp_print_dependency(mp, p,mp_dependent);
12590 mp_end_diagnostic(mp, false);
12593 @ @<Simplify all existing dependencies by substituting for |x|@>=
12594 prev_r=dep_head; r=link(dep_head);
12595 while ( r!=dep_head ) {
12596 s=dep_list(r); q=mp_p_with_x_becoming_q(mp, s,x,p,type(r));
12597 if ( info(q)==null ) {
12598 mp_make_known(mp, r,q);
12601 do { q=link(q); } while (info(q)!=null);
12607 @ @<Change variable |x| from |independent| to |dependent| or |known|@>=
12608 if ( n>0 ) @<Divide list |p| by $2^n$@>;
12609 if ( info(p)==null ) {
12612 if ( abs(value(x))>=fraction_one ) mp_val_too_big(mp, value(x));
12613 mp_free_node(mp, p,dep_node_size);
12614 if ( mp->cur_exp==x ) if ( mp->cur_type==mp_independent ) {
12615 mp->cur_exp=value(x); mp->cur_type=mp_known;
12616 mp_free_node(mp, x,value_node_size);
12619 type(x)=mp_dependent; mp->dep_final=final_node; mp_new_dep(mp, x,p);
12620 if ( mp->cur_exp==x ) if ( mp->cur_type==mp_independent ) mp->cur_type=mp_dependent;
12623 @ @<Divide list |p| by $2^n$@>=
12625 s=temp_head; link(temp_head)=p; r=p;
12628 else w=value(r) / two_to_the(n);
12629 if ( (abs(w)<=half_fraction_threshold)&&(info(r)!=null) ) {
12631 mp_free_node(mp, r,dep_node_size);
12636 } while (info(s)!=null);
12640 @ The |check_mem| procedure, which is used only when \MP\ is being
12641 debugged, makes sure that the current dependency lists are well formed.
12643 @<Check the list of linear dependencies@>=
12644 q=dep_head; p=link(q);
12645 while ( p!=dep_head ) {
12646 if ( prev_dep(p)!=q ) {
12647 mp_print_nl(mp, "Bad PREVDEP at "); mp_print_int(mp, p);
12652 r=info(p); q=p; p=link(q);
12653 if ( r==null ) break;
12654 if ( value(info(p))>=value(r) ) {
12655 mp_print_nl(mp, "Out of order at "); mp_print_int(mp, p);
12656 @.Out of order...@>
12661 @* \[25] Dynamic nonlinear equations.
12662 Variables of numeric type are maintained by the general scheme of
12663 independent, dependent, and known values that we have just studied;
12664 and the components of pair and transform variables are handled in the
12665 same way. But \MP\ also has five other types of values: \&{boolean},
12666 \&{string}, \&{pen}, \&{path}, and \&{picture}; what about them?
12668 Equations are allowed between nonlinear quantities, but only in a
12669 simple form. Two variables that haven't yet been assigned values are
12670 either equal to each other, or they're not.
12672 Before a boolean variable has received a value, its type is |mp_unknown_boolean|;
12673 similarly, there are variables whose type is |mp_unknown_string|, |mp_unknown_pen|,
12674 |mp_unknown_path|, and |mp_unknown_picture|. In such cases the value is either
12675 |null| (which means that no other variables are equivalent to this one), or
12676 it points to another variable of the same undefined type. The pointers in the
12677 latter case form a cycle of nodes, which we shall call a ``ring.''
12678 Rings of undefined variables may include capsules, which arise as
12679 intermediate results within expressions or as \&{expr} parameters to macros.
12681 When one member of a ring receives a value, the same value is given to
12682 all the other members. In the case of paths and pictures, this implies
12683 making separate copies of a potentially large data structure; users should
12684 restrain their enthusiasm for such generality, unless they have lots and
12685 lots of memory space.
12687 @ The following procedure is called when a capsule node is being
12688 added to a ring (e.g., when an unknown variable is mentioned in an expression).
12690 @c pointer mp_new_ring_entry (MP mp,pointer p) {
12691 pointer q; /* the new capsule node */
12692 q=mp_get_node(mp, value_node_size); name_type(q)=mp_capsule;
12694 if ( value(p)==null ) value(q)=p; else value(q)=value(p);
12699 @ Conversely, we might delete a capsule or a variable before it becomes known.
12700 The following procedure simply detaches a quantity from its ring,
12701 without recycling the storage.
12703 @<Declare the recycling subroutines@>=
12704 void mp_ring_delete (MP mp,pointer p) {
12707 if ( q!=null ) if ( q!=p ){
12708 while ( value(q)!=p ) q=value(q);
12713 @ Eventually there might be an equation that assigns values to all of the
12714 variables in a ring. The |nonlinear_eq| subroutine does the necessary
12715 propagation of values.
12717 If the parameter |flush_p| is |true|, node |p| itself needn't receive a
12718 value, it will soon be recycled.
12720 @c void mp_nonlinear_eq (MP mp,integer v, pointer p, boolean flush_p) {
12721 small_number t; /* the type of ring |p| */
12722 pointer q,r; /* link manipulation registers */
12723 t=type(p)-unknown_tag; q=value(p);
12724 if ( flush_p ) type(p)=mp_vacuous; else p=q;
12726 r=value(q); type(q)=t;
12728 case mp_boolean_type: value(q)=v; break;
12729 case mp_string_type: value(q)=v; add_str_ref(v); break;
12730 case mp_pen_type: value(q)=copy_pen(v); break;
12731 case mp_path_type: value(q)=mp_copy_path(mp, v); break;
12732 case mp_picture_type: value(q)=v; add_edge_ref(v); break;
12733 } /* there ain't no more cases */
12738 @ If two members of rings are equated, and if they have the same type,
12739 the |ring_merge| procedure is called on to make them equivalent.
12741 @c void mp_ring_merge (MP mp,pointer p, pointer q) {
12742 pointer r; /* traverses one list */
12746 @<Exclaim about a redundant equation@>;
12751 r=value(p); value(p)=value(q); value(q)=r;
12754 @ @<Exclaim about a redundant equation@>=
12756 print_err("Redundant equation");
12757 @.Redundant equation@>
12758 help2("I already knew that this equation was true.")
12759 ("But perhaps no harm has been done; let's continue.");
12760 mp_put_get_error(mp);
12763 @* \[26] Introduction to the syntactic routines.
12764 Let's pause a moment now and try to look at the Big Picture.
12765 The \MP\ program consists of three main parts: syntactic routines,
12766 semantic routines, and output routines. The chief purpose of the
12767 syntactic routines is to deliver the user's input to the semantic routines,
12768 while parsing expressions and locating operators and operands. The
12769 semantic routines act as an interpreter responding to these operators,
12770 which may be regarded as commands. And the output routines are
12771 periodically called on to produce compact font descriptions that can be
12772 used for typesetting or for making interim proof drawings. We have
12773 discussed the basic data structures and many of the details of semantic
12774 operations, so we are good and ready to plunge into the part of \MP\ that
12775 actually controls the activities.
12777 Our current goal is to come to grips with the |get_next| procedure,
12778 which is the keystone of \MP's input mechanism. Each call of |get_next|
12779 sets the value of three variables |cur_cmd|, |cur_mod|, and |cur_sym|,
12780 representing the next input token.
12781 $$\vbox{\halign{#\hfil\cr
12782 \hbox{|cur_cmd| denotes a command code from the long list of codes
12784 \hbox{|cur_mod| denotes a modifier of the command code;}\cr
12785 \hbox{|cur_sym| is the hash address of the symbolic token that was
12787 \hbox{\qquad or zero in the case of a numeric or string
12788 or capsule token.}\cr}}$$
12789 Underlying this external behavior of |get_next| is all the machinery
12790 necessary to convert from character files to tokens. At a given time we
12791 may be only partially finished with the reading of several files (for
12792 which \&{input} was specified), and partially finished with the expansion
12793 of some user-defined macros and/or some macro parameters, and partially
12794 finished reading some text that the user has inserted online,
12795 and so on. When reading a character file, the characters must be
12796 converted to tokens; comments and blank spaces must
12797 be removed, numeric and string tokens must be evaluated.
12799 To handle these situations, which might all be present simultaneously,
12800 \MP\ uses various stacks that hold information about the incomplete
12801 activities, and there is a finite state control for each level of the
12802 input mechanism. These stacks record the current state of an implicitly
12803 recursive process, but the |get_next| procedure is not recursive.
12806 eight_bits cur_cmd; /* current command set by |get_next| */
12807 integer cur_mod; /* operand of current command */
12808 halfword cur_sym; /* hash address of current symbol */
12810 @ The |print_cmd_mod| routine prints a symbolic interpretation of a
12811 command code and its modifier.
12812 It consists of a rather tedious sequence of print
12813 commands, and most of it is essentially an inverse to the |primitive|
12814 routine that enters a \MP\ primitive into |hash| and |eqtb|. Therefore almost
12815 all of this procedure appears elsewhere in the program, together with the
12816 corresponding |primitive| calls.
12818 @<Declare the procedure called |print_cmd_mod|@>=
12819 void mp_print_cmd_mod (MP mp,integer c, integer m) {
12821 @<Cases of |print_cmd_mod| for symbolic printing of primitives@>
12822 default: mp_print(mp, "[unknown command code!]"); break;
12826 @ Here is a procedure that displays a given command in braces, in the
12827 user's transcript file.
12829 @d show_cur_cmd_mod mp_show_cmd_mod(mp, mp->cur_cmd,mp->cur_mod)
12832 void mp_show_cmd_mod (MP mp,integer c, integer m) {
12833 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
12834 mp_print_cmd_mod(mp, c,m); mp_print_char(mp, '}');
12835 mp_end_diagnostic(mp, false);
12838 @* \[27] Input stacks and states.
12839 The state of \MP's input mechanism appears in the input stack, whose
12840 entries are records with five fields, called |index|, |start|, |loc|,
12841 |limit|, and |name|. The top element of this stack is maintained in a
12842 global variable for which no subscripting needs to be done; the other
12843 elements of the stack appear in an array. Hence the stack is declared thus:
12847 quarterword index_field;
12848 halfword start_field, loc_field, limit_field, name_field;
12852 in_state_record *input_stack;
12853 integer input_ptr; /* first unused location of |input_stack| */
12854 integer max_in_stack; /* largest value of |input_ptr| when pushing */
12855 in_state_record cur_input; /* the ``top'' input state */
12856 int stack_size; /* maximum number of simultaneous input sources */
12858 @ @<Allocate or initialize ...@>=
12859 mp->stack_size = 300;
12860 mp->input_stack = xmalloc((mp->stack_size+1),sizeof(in_state_record));
12862 @ @<Dealloc variables@>=
12863 xfree(mp->input_stack);
12865 @ We've already defined the special variable |loc==cur_input.loc_field|
12866 in our discussion of basic input-output routines. The other components of
12867 |cur_input| are defined in the same way:
12869 @d index mp->cur_input.index_field /* reference for buffer information */
12870 @d start mp->cur_input.start_field /* starting position in |buffer| */
12871 @d limit mp->cur_input.limit_field /* end of current line in |buffer| */
12872 @d name mp->cur_input.name_field /* name of the current file */
12874 @ Let's look more closely now at the five control variables
12875 (|index|,~|start|,~|loc|,~|limit|,~|name|),
12876 assuming that \MP\ is reading a line of characters that have been input
12877 from some file or from the user's terminal. There is an array called
12878 |buffer| that acts as a stack of all lines of characters that are
12879 currently being read from files, including all lines on subsidiary
12880 levels of the input stack that are not yet completed. \MP\ will return to
12881 the other lines when it is finished with the present input file.
12883 (Incidentally, on a machine with byte-oriented addressing, it would be
12884 appropriate to combine |buffer| with the |str_pool| array,
12885 letting the buffer entries grow downward from the top of the string pool
12886 and checking that these two tables don't bump into each other.)
12888 The line we are currently working on begins in position |start| of the
12889 buffer; the next character we are about to read is |buffer[loc]|; and
12890 |limit| is the location of the last character present. We always have
12891 |loc<=limit|. For convenience, |buffer[limit]| has been set to |"%"|, so
12892 that the end of a line is easily sensed.
12894 The |name| variable is a string number that designates the name of
12895 the current file, if we are reading an ordinary text file. Special codes
12896 |is_term..max_spec_src| indicate other sources of input text.
12898 @d is_term 0 /* |name| value when reading from the terminal for normal input */
12899 @d is_read 1 /* |name| value when executing a \&{readstring} or \&{readfrom} */
12900 @d is_scantok 2 /* |name| value when reading text generated by \&{scantokens} */
12901 @d max_spec_src is_scantok
12903 @ Additional information about the current line is available via the
12904 |index| variable, which counts how many lines of characters are present
12905 in the buffer below the current level. We have |index=0| when reading
12906 from the terminal and prompting the user for each line; then if the user types,
12907 e.g., `\.{input figs}', we will have |index=1| while reading
12908 the file \.{figs.mp}. However, it does not follow that |index| is the
12909 same as the input stack pointer, since many of the levels on the input
12910 stack may come from token lists and some |index| values may correspond
12911 to \.{MPX} files that are not currently on the stack.
12913 The global variable |in_open| is equal to the highest |index| value counting
12914 \.{MPX} files but excluding token-list input levels. Thus, the number of
12915 partially read lines in the buffer is |in_open+1| and we have |in_open>=index|
12916 when we are not reading a token list.
12918 If we are not currently reading from the terminal,
12919 we are reading from the file variable |input_file[index]|. We use
12920 the notation |terminal_input| as a convenient abbreviation for |name=is_term|,
12921 and |cur_file| as an abbreviation for |input_file[index]|.
12923 When \MP\ is not reading from the terminal, the global variable |line| contains
12924 the line number in the current file, for use in error messages. More precisely,
12925 |line| is a macro for |line_stack[index]| and the |line_stack| array gives
12926 the line number for each file in the |input_file| array.
12928 When an \.{MPX} file is opened the file name is stored in the |mpx_name|
12929 array so that the name doesn't get lost when the file is temporarily removed
12930 from the input stack.
12931 Thus when |input_file[k]| is an \.{MPX} file, its name is |mpx_name[k]|
12932 and it contains translated \TeX\ pictures for |input_file[k-1]|.
12933 Since this is not an \.{MPX} file, we have
12934 $$ \hbox{|mpx_name[k-1]<=absent|}. $$
12935 This |name| field is set to |finished| when |input_file[k]| is completely
12938 If more information about the input state is needed, it can be
12939 included in small arrays like those shown here. For example,
12940 the current page or segment number in the input file might be put
12941 into a variable |page|, that is really a macro for the current entry
12942 in `\ignorespaces|page_stack:array[0..max_in_open] of integer|\unskip'
12943 by analogy with |line_stack|.
12944 @^system dependencies@>
12946 @d terminal_input (name==is_term) /* are we reading from the terminal? */
12947 @d cur_file mp->input_file[index] /* the current |void *| variable */
12948 @d line mp->line_stack[index] /* current line number in the current source file */
12949 @d in_name mp->iname_stack[index] /* a string used to construct \.{MPX} file names */
12950 @d in_area mp->iarea_stack[index] /* another string for naming \.{MPX} files */
12951 @d absent 1 /* |name_field| value for unused |mpx_in_stack| entries */
12952 @d mpx_reading (mp->mpx_name[index]>absent)
12953 /* when reading a file, is it an \.{MPX} file? */
12955 /* |name_field| value when the corresponding \.{MPX} file is finished */
12958 integer in_open; /* the number of lines in the buffer, less one */
12959 unsigned int open_parens; /* the number of open text files */
12960 void * *input_file ;
12961 integer *line_stack ; /* the line number for each file */
12962 char * *iname_stack; /* used for naming \.{MPX} files */
12963 char * *iarea_stack; /* used for naming \.{MPX} files */
12964 halfword*mpx_name ;
12966 @ @<Allocate or ...@>=
12967 mp->input_file = xmalloc((mp->max_in_open+1),sizeof(void *));
12968 mp->line_stack = xmalloc((mp->max_in_open+1),sizeof(integer));
12969 mp->iname_stack = xmalloc((mp->max_in_open+1),sizeof(char *));
12970 mp->iarea_stack = xmalloc((mp->max_in_open+1),sizeof(char *));
12971 mp->mpx_name = xmalloc((mp->max_in_open+1),sizeof(halfword));
12974 for (k=0;k<=mp->max_in_open;k++) {
12975 mp->iname_stack[k] =NULL;
12976 mp->iarea_stack[k] =NULL;
12980 @ @<Dealloc variables@>=
12983 for (l=0;l<=mp->max_in_open;l++) {
12984 xfree(mp->iname_stack[l]);
12985 xfree(mp->iarea_stack[l]);
12988 xfree(mp->input_file);
12989 xfree(mp->line_stack);
12990 xfree(mp->iname_stack);
12991 xfree(mp->iarea_stack);
12992 xfree(mp->mpx_name);
12995 @ However, all this discussion about input state really applies only to the
12996 case that we are inputting from a file. There is another important case,
12997 namely when we are currently getting input from a token list. In this case
12998 |index>max_in_open|, and the conventions about the other state variables
13001 \yskip\hang|loc| is a pointer to the current node in the token list, i.e.,
13002 the node that will be read next. If |loc=null|, the token list has been
13005 \yskip\hang|start| points to the first node of the token list; this node
13006 may or may not contain a reference count, depending on the type of token
13009 \yskip\hang|token_type|, which takes the place of |index| in the
13010 discussion above, is a code number that explains what kind of token list
13013 \yskip\hang|name| points to the |eqtb| address of the control sequence
13014 being expanded, if the current token list is a macro not defined by
13015 \&{vardef}. Macros defined by \&{vardef} have |name=null|; their name
13016 can be deduced by looking at their first two parameters.
13018 \yskip\hang|param_start|, which takes the place of |limit|, tells where
13019 the parameters of the current macro or loop text begin in the |param_stack|.
13021 \yskip\noindent The |token_type| can take several values, depending on
13022 where the current token list came from:
13025 \indent|forever_text|, if the token list being scanned is the body of
13026 a \&{forever} loop;
13028 \indent|loop_text|, if the token list being scanned is the body of
13029 a \&{for} or \&{forsuffixes} loop;
13031 \indent|parameter|, if a \&{text} or \&{suffix} parameter is being scanned;
13033 \indent|backed_up|, if the token list being scanned has been inserted as
13034 `to be read again'.
13036 \indent|inserted|, if the token list being scanned has been inserted as
13037 part of error recovery;
13039 \indent|macro|, if the expansion of a user-defined symbolic token is being
13043 The token list begins with a reference count if and only if |token_type=
13045 @^reference counts@>
13047 @d token_type index /* type of current token list */
13048 @d token_state (index>(int)mp->max_in_open) /* are we scanning a token list? */
13049 @d file_state (index<=(int)mp->max_in_open) /* are we scanning a file line? */
13050 @d param_start limit /* base of macro parameters in |param_stack| */
13051 @d forever_text (mp->max_in_open+1) /* |token_type| code for loop texts */
13052 @d loop_text (mp->max_in_open+2) /* |token_type| code for loop texts */
13053 @d parameter (mp->max_in_open+3) /* |token_type| code for parameter texts */
13054 @d backed_up (mp->max_in_open+4) /* |token_type| code for texts to be reread */
13055 @d inserted (mp->max_in_open+5) /* |token_type| code for inserted texts */
13056 @d macro (mp->max_in_open+6) /* |token_type| code for macro replacement texts */
13058 @ The |param_stack| is an auxiliary array used to hold pointers to the token
13059 lists for parameters at the current level and subsidiary levels of input.
13060 This stack grows at a different rate from the others.
13063 pointer *param_stack; /* token list pointers for parameters */
13064 integer param_ptr; /* first unused entry in |param_stack| */
13065 integer max_param_stack; /* largest value of |param_ptr| */
13067 @ @<Allocate or initialize ...@>=
13068 mp->param_stack = xmalloc((mp->param_size+1),sizeof(pointer));
13070 @ @<Dealloc variables@>=
13071 xfree(mp->param_stack);
13073 @ Notice that the |line| isn't valid when |token_state| is true because it
13074 depends on |index|. If we really need to know the line number for the
13075 topmost file in the index stack we use the following function. If a page
13076 number or other information is needed, this routine should be modified to
13077 compute it as well.
13078 @^system dependencies@>
13080 @<Declare a function called |true_line|@>=
13081 integer mp_true_line (MP mp) {
13082 int k; /* an index into the input stack */
13083 if ( file_state && (name>max_spec_src) ) {
13088 ((mp->input_stack[(k-1)].index_field>mp->max_in_open)||
13089 (mp->input_stack[(k-1)].name_field<=max_spec_src))) {
13092 return (k>0 ? mp->line_stack[(k-1)] : 0 );
13096 @ Thus, the ``current input state'' can be very complicated indeed; there
13097 can be many levels and each level can arise in a variety of ways. The
13098 |show_context| procedure, which is used by \MP's error-reporting routine to
13099 print out the current input state on all levels down to the most recent
13100 line of characters from an input file, illustrates most of these conventions.
13101 The global variable |file_ptr| contains the lowest level that was
13102 displayed by this procedure.
13105 integer file_ptr; /* shallowest level shown by |show_context| */
13107 @ The status at each level is indicated by printing two lines, where the first
13108 line indicates what was read so far and the second line shows what remains
13109 to be read. The context is cropped, if necessary, so that the first line
13110 contains at most |half_error_line| characters, and the second contains
13111 at most |error_line|. Non-current input levels whose |token_type| is
13112 `|backed_up|' are shown only if they have not been fully read.
13114 @c void mp_show_context (MP mp) { /* prints where the scanner is */
13115 int old_setting; /* saved |selector| setting */
13116 @<Local variables for formatting calculations@>
13117 mp->file_ptr=mp->input_ptr; mp->input_stack[mp->file_ptr]=mp->cur_input;
13118 /* store current state */
13120 mp->cur_input=mp->input_stack[mp->file_ptr]; /* enter into the context */
13121 @<Display the current context@>;
13123 if ( (name>max_spec_src) || (mp->file_ptr==0) ) break;
13124 decr(mp->file_ptr);
13126 mp->cur_input=mp->input_stack[mp->input_ptr]; /* restore original state */
13129 @ @<Display the current context@>=
13130 if ( (mp->file_ptr==mp->input_ptr) || file_state ||
13131 (token_type!=backed_up) || (loc!=null) ) {
13132 /* we omit backed-up token lists that have already been read */
13133 mp->tally=0; /* get ready to count characters */
13134 old_setting=mp->selector;
13135 if ( file_state ) {
13136 @<Print location of current line@>;
13137 @<Pseudoprint the line@>;
13139 @<Print type of token list@>;
13140 @<Pseudoprint the token list@>;
13142 mp->selector=old_setting; /* stop pseudoprinting */
13143 @<Print two lines using the tricky pseudoprinted information@>;
13146 @ This routine should be changed, if necessary, to give the best possible
13147 indication of where the current line resides in the input file.
13148 For example, on some systems it is best to print both a page and line number.
13149 @^system dependencies@>
13151 @<Print location of current line@>=
13152 if ( name>max_spec_src ) {
13153 mp_print_nl(mp, "l."); mp_print_int(mp, mp_true_line(mp));
13154 } else if ( terminal_input ) {
13155 if ( mp->file_ptr==0 ) mp_print_nl(mp, "<*>");
13156 else mp_print_nl(mp, "<insert>");
13157 } else if ( name==is_scantok ) {
13158 mp_print_nl(mp, "<scantokens>");
13160 mp_print_nl(mp, "<read>");
13162 mp_print_char(mp, ' ')
13164 @ Can't use case statement here because the |token_type| is not
13165 a constant expression.
13167 @<Print type of token list@>=
13169 if(token_type==forever_text) {
13170 mp_print_nl(mp, "<forever> ");
13171 } else if (token_type==loop_text) {
13172 @<Print the current loop value@>;
13173 } else if (token_type==parameter) {
13174 mp_print_nl(mp, "<argument> ");
13175 } else if (token_type==backed_up) {
13176 if ( loc==null ) mp_print_nl(mp, "<recently read> ");
13177 else mp_print_nl(mp, "<to be read again> ");
13178 } else if (token_type==inserted) {
13179 mp_print_nl(mp, "<inserted text> ");
13180 } else if (token_type==macro) {
13182 if ( name!=null ) mp_print_text(name);
13183 else @<Print the name of a \&{vardef}'d macro@>;
13184 mp_print(mp, "->");
13186 mp_print_nl(mp, "?");/* this should never happen */
13191 @ The parameter that corresponds to a loop text is either a token list
13192 (in the case of \&{forsuffixes}) or a ``capsule'' (in the case of \&{for}).
13193 We'll discuss capsules later; for now, all we need to know is that
13194 the |link| field in a capsule parameter is |void| and that
13195 |print_exp(p,0)| displays the value of capsule~|p| in abbreviated form.
13197 @<Print the current loop value@>=
13198 { mp_print_nl(mp, "<for("); p=mp->param_stack[param_start];
13200 if ( link(p)==mp_void ) mp_print_exp(mp, p,0); /* we're in a \&{for} loop */
13201 else mp_show_token_list(mp, p,null,20,mp->tally);
13203 mp_print(mp, ")> ");
13206 @ The first two parameters of a macro defined by \&{vardef} will be token
13207 lists representing the macro's prefix and ``at point.'' By putting these
13208 together, we get the macro's full name.
13210 @<Print the name of a \&{vardef}'d macro@>=
13211 { p=mp->param_stack[param_start];
13213 mp_show_token_list(mp, mp->param_stack[param_start+1],null,20,mp->tally);
13216 while ( link(q)!=null ) q=link(q);
13217 link(q)=mp->param_stack[param_start+1];
13218 mp_show_token_list(mp, p,null,20,mp->tally);
13223 @ Now it is necessary to explain a little trick. We don't want to store a long
13224 string that corresponds to a token list, because that string might take up
13225 lots of memory; and we are printing during a time when an error message is
13226 being given, so we dare not do anything that might overflow one of \MP's
13227 tables. So `pseudoprinting' is the answer: We enter a mode of printing
13228 that stores characters into a buffer of length |error_line|, where character
13229 $k+1$ is placed into \hbox{|trick_buf[k mod error_line]|} if
13230 |k<trick_count|, otherwise character |k| is dropped. Initially we set
13231 |tally:=0| and |trick_count:=1000000|; then when we reach the
13232 point where transition from line 1 to line 2 should occur, we
13233 set |first_count:=tally| and |trick_count:=@tmax@>(error_line,
13234 tally+1+error_line-half_error_line)|. At the end of the
13235 pseudoprinting, the values of |first_count|, |tally|, and
13236 |trick_count| give us all the information we need to print the two lines,
13237 and all of the necessary text is in |trick_buf|.
13239 Namely, let |l| be the length of the descriptive information that appears
13240 on the first line. The length of the context information gathered for that
13241 line is |k=first_count|, and the length of the context information
13242 gathered for line~2 is $m=\min(|tally|, |trick_count|)-k$. If |l+k<=h|,
13243 where |h=half_error_line|, we print |trick_buf[0..k-1]| after the
13244 descriptive information on line~1, and set |n:=l+k|; here |n| is the
13245 length of line~1. If $l+k>h$, some cropping is necessary, so we set |n:=h|
13246 and print `\.{...}' followed by
13247 $$\hbox{|trick_buf[(l+k-h+3)..k-1]|,}$$
13248 where subscripts of |trick_buf| are circular modulo |error_line|. The
13249 second line consists of |n|~spaces followed by |trick_buf[k..(k+m-1)]|,
13250 unless |n+m>error_line|; in the latter case, further cropping is done.
13251 This is easier to program than to explain.
13253 @<Local variables for formatting...@>=
13254 int i; /* index into |buffer| */
13255 integer l; /* length of descriptive information on line 1 */
13256 integer m; /* context information gathered for line 2 */
13257 int n; /* length of line 1 */
13258 integer p; /* starting or ending place in |trick_buf| */
13259 integer q; /* temporary index */
13261 @ The following code tells the print routines to gather
13262 the desired information.
13264 @d begin_pseudoprint {
13265 l=mp->tally; mp->tally=0; mp->selector=pseudo;
13266 mp->trick_count=1000000;
13268 @d set_trick_count {
13269 mp->first_count=mp->tally;
13270 mp->trick_count=mp->tally+1+mp->error_line-mp->half_error_line;
13271 if ( mp->trick_count<mp->error_line ) mp->trick_count=mp->error_line;
13274 @ And the following code uses the information after it has been gathered.
13276 @<Print two lines using the tricky pseudoprinted information@>=
13277 if ( mp->trick_count==1000000 ) set_trick_count;
13278 /* |set_trick_count| must be performed */
13279 if ( mp->tally<mp->trick_count ) m=mp->tally-mp->first_count;
13280 else m=mp->trick_count-mp->first_count; /* context on line 2 */
13281 if ( l+mp->first_count<=mp->half_error_line ) {
13282 p=0; n=l+mp->first_count;
13284 mp_print(mp, "..."); p=l+mp->first_count-mp->half_error_line+3;
13285 n=mp->half_error_line;
13287 for (q=p;q<=mp->first_count-1;q++) {
13288 mp_print_char(mp, mp->trick_buf[q % mp->error_line]);
13291 for (q=1;q<=n;q++) {
13292 mp_print_char(mp, ' '); /* print |n| spaces to begin line~2 */
13294 if ( m+n<=mp->error_line ) p=mp->first_count+m;
13295 else p=mp->first_count+(mp->error_line-n-3);
13296 for (q=mp->first_count;q<=p-1;q++) {
13297 mp_print_char(mp, mp->trick_buf[q % mp->error_line]);
13299 if ( m+n>mp->error_line ) mp_print(mp, "...")
13301 @ But the trick is distracting us from our current goal, which is to
13302 understand the input state. So let's concentrate on the data structures that
13303 are being pseudoprinted as we finish up the |show_context| procedure.
13305 @<Pseudoprint the line@>=
13308 for (i=start;i<=limit-1;i++) {
13309 if ( i==loc ) set_trick_count;
13310 mp_print_str(mp, mp->buffer[i]);
13314 @ @<Pseudoprint the token list@>=
13316 if ( token_type!=macro ) mp_show_token_list(mp, start,loc,100000,0);
13317 else mp_show_macro(mp, start,loc,100000)
13319 @ Here is the missing piece of |show_token_list| that is activated when the
13320 token beginning line~2 is about to be shown:
13322 @<Do magic computation@>=set_trick_count
13324 @* \[28] Maintaining the input stacks.
13325 The following subroutines change the input status in commonly needed ways.
13327 First comes |push_input|, which stores the current state and creates a
13328 new level (having, initially, the same properties as the old).
13330 @d push_input { /* enter a new input level, save the old */
13331 if ( mp->input_ptr>mp->max_in_stack ) {
13332 mp->max_in_stack=mp->input_ptr;
13333 if ( mp->input_ptr==mp->stack_size ) {
13334 int l = (mp->stack_size+(mp->stack_size>>2));
13335 XREALLOC(mp->input_stack, l, in_state_record);
13336 mp->stack_size = l;
13339 mp->input_stack[mp->input_ptr]=mp->cur_input; /* stack the record */
13340 incr(mp->input_ptr);
13343 @ And of course what goes up must come down.
13345 @d pop_input { /* leave an input level, re-enter the old */
13346 decr(mp->input_ptr); mp->cur_input=mp->input_stack[mp->input_ptr];
13349 @ Here is a procedure that starts a new level of token-list input, given
13350 a token list |p| and its type |t|. If |t=macro|, the calling routine should
13351 set |name|, reset~|loc|, and increase the macro's reference count.
13353 @d back_list(A) mp_begin_token_list(mp, (A),backed_up) /* backs up a simple token list */
13355 @c void mp_begin_token_list (MP mp,pointer p, quarterword t) {
13356 push_input; start=p; token_type=t;
13357 param_start=mp->param_ptr; loc=p;
13360 @ When a token list has been fully scanned, the following computations
13361 should be done as we leave that level of input.
13364 @c void mp_end_token_list (MP mp) { /* leave a token-list input level */
13365 pointer p; /* temporary register */
13366 if ( token_type>=backed_up ) { /* token list to be deleted */
13367 if ( token_type<=inserted ) {
13368 mp_flush_token_list(mp, start); goto DONE;
13370 mp_delete_mac_ref(mp, start); /* update reference count */
13373 while ( mp->param_ptr>param_start ) { /* parameters must be flushed */
13374 decr(mp->param_ptr);
13375 p=mp->param_stack[mp->param_ptr];
13377 if ( link(p)==mp_void ) { /* it's an \&{expr} parameter */
13378 mp_recycle_value(mp, p); mp_free_node(mp, p,value_node_size);
13380 mp_flush_token_list(mp, p); /* it's a \&{suffix} or \&{text} parameter */
13385 pop_input; check_interrupt;
13388 @ The contents of |cur_cmd,cur_mod,cur_sym| are placed into an equivalent
13389 token by the |cur_tok| routine.
13392 @c @<Declare the procedure called |make_exp_copy|@>
13393 pointer mp_cur_tok (MP mp) {
13394 pointer p; /* a new token node */
13395 small_number save_type; /* |cur_type| to be restored */
13396 integer save_exp; /* |cur_exp| to be restored */
13397 if ( mp->cur_sym==0 ) {
13398 if ( mp->cur_cmd==capsule_token ) {
13399 save_type=mp->cur_type; save_exp=mp->cur_exp;
13400 mp_make_exp_copy(mp, mp->cur_mod); p=mp_stash_cur_exp(mp); link(p)=null;
13401 mp->cur_type=save_type; mp->cur_exp=save_exp;
13403 p=mp_get_node(mp, token_node_size);
13404 value(p)=mp->cur_mod; name_type(p)=mp_token;
13405 if ( mp->cur_cmd==numeric_token ) type(p)=mp_known;
13406 else type(p)=mp_string_type;
13409 fast_get_avail(p); info(p)=mp->cur_sym;
13414 @ Sometimes \MP\ has read too far and wants to ``unscan'' what it has
13415 seen. The |back_input| procedure takes care of this by putting the token
13416 just scanned back into the input stream, ready to be read again.
13417 If |cur_sym<>0|, the values of |cur_cmd| and |cur_mod| are irrelevant.
13420 void mp_back_input (MP mp);
13422 @ @c void mp_back_input (MP mp) {/* undoes one token of input */
13423 pointer p; /* a token list of length one */
13425 while ( token_state &&(loc==null) )
13426 mp_end_token_list(mp); /* conserve stack space */
13430 @ The |back_error| routine is used when we want to restore or replace an
13431 offending token just before issuing an error message. We disable interrupts
13432 during the call of |back_input| so that the help message won't be lost.
13435 void mp_error (MP mp);
13436 void mp_back_error (MP mp);
13438 @ @c void mp_back_error (MP mp) { /* back up one token and call |error| */
13439 mp->OK_to_interrupt=false;
13441 mp->OK_to_interrupt=true; mp_error(mp);
13443 void mp_ins_error (MP mp) { /* back up one inserted token and call |error| */
13444 mp->OK_to_interrupt=false;
13445 mp_back_input(mp); token_type=inserted;
13446 mp->OK_to_interrupt=true; mp_error(mp);
13449 @ The |begin_file_reading| procedure starts a new level of input for lines
13450 of characters to be read from a file, or as an insertion from the
13451 terminal. It does not take care of opening the file, nor does it set |loc|
13452 or |limit| or |line|.
13453 @^system dependencies@>
13455 @c void mp_begin_file_reading (MP mp) {
13456 if ( mp->in_open==mp->max_in_open )
13457 mp_overflow(mp, "text input levels",mp->max_in_open);
13458 @:MetaPost capacity exceeded text input levels}{\quad text input levels@>
13459 if ( mp->first==mp->buf_size )
13460 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
13461 incr(mp->in_open); push_input; index=mp->in_open;
13462 mp->mpx_name[index]=absent;
13464 name=is_term; /* |terminal_input| is now |true| */
13467 @ Conversely, the variables must be downdated when such a level of input
13468 is finished. Any associated \.{MPX} file must also be closed and popped
13469 off the file stack.
13471 @c void mp_end_file_reading (MP mp) {
13472 if ( mp->in_open>index ) {
13473 if ( (mp->mpx_name[mp->in_open]==absent)||(name<=max_spec_src) ) {
13474 mp_confusion(mp, "endinput");
13475 @:this can't happen endinput}{\quad endinput@>
13477 (mp->close_file)(mp,mp->input_file[mp->in_open]); /* close an \.{MPX} file */
13478 delete_str_ref(mp->mpx_name[mp->in_open]);
13483 if ( index!=mp->in_open ) mp_confusion(mp, "endinput");
13484 if ( name>max_spec_src ) {
13485 (mp->close_file)(mp,cur_file);
13486 delete_str_ref(name);
13490 pop_input; decr(mp->in_open);
13493 @ Here is a function that tries to resume input from an \.{MPX} file already
13494 associated with the current input file. It returns |false| if this doesn't
13497 @c boolean mp_begin_mpx_reading (MP mp) {
13498 if ( mp->in_open!=index+1 ) {
13501 if ( mp->mpx_name[mp->in_open]<=absent ) mp_confusion(mp, "mpx");
13502 @:this can't happen mpx}{\quad mpx@>
13503 if ( mp->first==mp->buf_size )
13504 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
13505 push_input; index=mp->in_open;
13507 name=mp->mpx_name[mp->in_open]; add_str_ref(name);
13508 @<Put an empty line in the input buffer@>;
13513 @ This procedure temporarily stops reading an \.{MPX} file.
13515 @c void mp_end_mpx_reading (MP mp) {
13516 if ( mp->in_open!=index ) mp_confusion(mp, "mpx");
13517 @:this can't happen mpx}{\quad mpx@>
13519 @<Complain that we are not at the end of a line in the \.{MPX} file@>;
13525 @ Here we enforce a restriction that simplifies the input stacks considerably.
13526 This should not inconvenience the user because \.{MPX} files are generated
13527 by an auxiliary program called \.{DVItoMP}.
13529 @ @<Complain that we are not at the end of a line in the \.{MPX} file@>=
13531 print_err("`mpxbreak' must be at the end of a line");
13532 help4("This file contains picture expressions for btex...etex")
13533 ("blocks. Such files are normally generated automatically")
13534 ("but this one seems to be messed up. I'm going to ignore")
13535 ("the rest of this line.");
13539 @ In order to keep the stack from overflowing during a long sequence of
13540 inserted `\.{show}' commands, the following routine removes completed
13541 error-inserted lines from memory.
13543 @c void mp_clear_for_error_prompt (MP mp) {
13544 while ( file_state && terminal_input &&
13545 (mp->input_ptr>0)&&(loc==limit) ) mp_end_file_reading(mp);
13546 mp_print_ln(mp); clear_terminal;
13549 @ To get \MP's whole input mechanism going, we perform the following
13552 @<Initialize the input routines@>=
13553 { mp->input_ptr=0; mp->max_in_stack=0;
13554 mp->in_open=0; mp->open_parens=0; mp->max_buf_stack=0;
13555 mp->param_ptr=0; mp->max_param_stack=0;
13557 start=1; index=0; line=0; name=is_term;
13558 mp->mpx_name[0]=absent;
13559 mp->force_eof=false;
13560 if ( ! mp_init_terminal(mp) ) mp_jump_out(mp);
13561 limit=mp->last; mp->first=mp->last+1;
13562 /* |init_terminal| has set |loc| and |last| */
13565 @* \[29] Getting the next token.
13566 The heart of \MP's input mechanism is the |get_next| procedure, which
13567 we shall develop in the next few sections of the program. Perhaps we
13568 shouldn't actually call it the ``heart,'' however; it really acts as \MP's
13569 eyes and mouth, reading the source files and gobbling them up. And it also
13570 helps \MP\ to regurgitate stored token lists that are to be processed again.
13572 The main duty of |get_next| is to input one token and to set |cur_cmd|
13573 and |cur_mod| to that token's command code and modifier. Furthermore, if
13574 the input token is a symbolic token, that token's |hash| address
13575 is stored in |cur_sym|; otherwise |cur_sym| is set to zero.
13577 Underlying this simple description is a certain amount of complexity
13578 because of all the cases that need to be handled.
13579 However, the inner loop of |get_next| is reasonably short and fast.
13581 @ Before getting into |get_next|, we need to consider a mechanism by which
13582 \MP\ helps keep errors from propagating too far. Whenever the program goes
13583 into a mode where it keeps calling |get_next| repeatedly until a certain
13584 condition is met, it sets |scanner_status| to some value other than |normal|.
13585 Then if an input file ends, or if an `\&{outer}' symbol appears,
13586 an appropriate error recovery will be possible.
13588 The global variable |warning_info| helps in this error recovery by providing
13589 additional information. For example, |warning_info| might indicate the
13590 name of a macro whose replacement text is being scanned.
13592 @d normal 0 /* |scanner_status| at ``quiet times'' */
13593 @d skipping 1 /* |scanner_status| when false conditional text is being skipped */
13594 @d flushing 2 /* |scanner_status| when junk after a statement is being ignored */
13595 @d absorbing 3 /* |scanner_status| when a \&{text} parameter is being scanned */
13596 @d var_defining 4 /* |scanner_status| when a \&{vardef} is being scanned */
13597 @d op_defining 5 /* |scanner_status| when a macro \&{def} is being scanned */
13598 @d loop_defining 6 /* |scanner_status| when a \&{for} loop is being scanned */
13599 @d tex_flushing 7 /* |scanner_status| when skipping \TeX\ material */
13602 integer scanner_status; /* are we scanning at high speed? */
13603 integer warning_info; /* if so, what else do we need to know,
13604 in case an error occurs? */
13606 @ @<Initialize the input routines@>=
13607 mp->scanner_status=normal;
13609 @ The following subroutine
13610 is called when an `\&{outer}' symbolic token has been scanned or
13611 when the end of a file has been reached. These two cases are distinguished
13612 by |cur_sym|, which is zero at the end of a file.
13614 @c boolean mp_check_outer_validity (MP mp) {
13615 pointer p; /* points to inserted token list */
13616 if ( mp->scanner_status==normal ) {
13618 } else if ( mp->scanner_status==tex_flushing ) {
13619 @<Check if the file has ended while flushing \TeX\ material and set the
13620 result value for |check_outer_validity|@>;
13622 mp->deletions_allowed=false;
13623 @<Back up an outer symbolic token so that it can be reread@>;
13624 if ( mp->scanner_status>skipping ) {
13625 @<Tell the user what has run away and try to recover@>;
13627 print_err("Incomplete if; all text was ignored after line ");
13628 @.Incomplete if...@>
13629 mp_print_int(mp, mp->warning_info);
13630 help3("A forbidden `outer' token occurred in skipped text.")
13631 ("This kind of error happens when you say `if...' and forget")
13632 ("the matching `fi'. I've inserted a `fi'; this might work.");
13633 if ( mp->cur_sym==0 )
13634 mp->help_line[2]="The file ended while I was skipping conditional text.";
13635 mp->cur_sym=frozen_fi; mp_ins_error(mp);
13637 mp->deletions_allowed=true;
13642 @ @<Check if the file has ended while flushing \TeX\ material and set...@>=
13643 if ( mp->cur_sym!=0 ) {
13646 mp->deletions_allowed=false;
13647 print_err("TeX mode didn't end; all text was ignored after line ");
13648 mp_print_int(mp, mp->warning_info);
13649 help2("The file ended while I was looking for the `etex' to")
13650 ("finish this TeX material. I've inserted `etex' now.");
13651 mp->cur_sym = frozen_etex;
13653 mp->deletions_allowed=true;
13657 @ @<Back up an outer symbolic token so that it can be reread@>=
13658 if ( mp->cur_sym!=0 ) {
13659 p=mp_get_avail(mp); info(p)=mp->cur_sym;
13660 back_list(p); /* prepare to read the symbolic token again */
13663 @ @<Tell the user what has run away...@>=
13665 mp_runaway(mp); /* print the definition-so-far */
13666 if ( mp->cur_sym==0 ) {
13667 print_err("File ended");
13668 @.File ended while scanning...@>
13670 print_err("Forbidden token found");
13671 @.Forbidden token found...@>
13673 mp_print(mp, " while scanning ");
13674 help4("I suspect you have forgotten an `enddef',")
13675 ("causing me to read past where you wanted me to stop.")
13676 ("I'll try to recover; but if the error is serious,")
13677 ("you'd better type `E' or `X' now and fix your file.");
13678 switch (mp->scanner_status) {
13679 @<Complete the error message,
13680 and set |cur_sym| to a token that might help recover from the error@>
13681 } /* there are no other cases */
13685 @ As we consider various kinds of errors, it is also appropriate to
13686 change the first line of the help message just given; |help_line[3]|
13687 points to the string that might be changed.
13689 @<Complete the error message,...@>=
13691 mp_print(mp, "to the end of the statement");
13692 mp->help_line[3]="A previous error seems to have propagated,";
13693 mp->cur_sym=frozen_semicolon;
13696 mp_print(mp, "a text argument");
13697 mp->help_line[3]="It seems that a right delimiter was left out,";
13698 if ( mp->warning_info==0 ) {
13699 mp->cur_sym=frozen_end_group;
13701 mp->cur_sym=frozen_right_delimiter;
13702 equiv(frozen_right_delimiter)=mp->warning_info;
13707 mp_print(mp, "the definition of ");
13708 if ( mp->scanner_status==op_defining )
13709 mp_print_text(mp->warning_info);
13711 mp_print_variable_name(mp, mp->warning_info);
13712 mp->cur_sym=frozen_end_def;
13714 case loop_defining:
13715 mp_print(mp, "the text of a ");
13716 mp_print_text(mp->warning_info);
13717 mp_print(mp, " loop");
13718 mp->help_line[3]="I suspect you have forgotten an `endfor',";
13719 mp->cur_sym=frozen_end_for;
13722 @ The |runaway| procedure displays the first part of the text that occurred
13723 when \MP\ began its special |scanner_status|, if that text has been saved.
13725 @<Declare the procedure called |runaway|@>=
13726 void mp_runaway (MP mp) {
13727 if ( mp->scanner_status>flushing ) {
13728 mp_print_nl(mp, "Runaway ");
13729 switch (mp->scanner_status) {
13730 case absorbing: mp_print(mp, "text?"); break;
13732 case op_defining: mp_print(mp,"definition?"); break;
13733 case loop_defining: mp_print(mp, "loop?"); break;
13734 } /* there are no other cases */
13736 mp_show_token_list(mp, link(hold_head),null,mp->error_line-10,0);
13740 @ We need to mention a procedure that may be called by |get_next|.
13743 void mp_firm_up_the_line (MP mp);
13745 @ And now we're ready to take the plunge into |get_next| itself.
13746 Note that the behavior depends on the |scanner_status| because percent signs
13747 and double quotes need to be passed over when skipping TeX material.
13750 void mp_get_next (MP mp) {
13751 /* sets |cur_cmd|, |cur_mod|, |cur_sym| to next token */
13753 /*restart*/ /* go here to get the next input token */
13754 /*exit*/ /* go here when the next input token has been got */
13755 /*|common_ending|*/ /* go here to finish getting a symbolic token */
13756 /*found*/ /* go here when the end of a symbolic token has been found */
13757 /*switch*/ /* go here to branch on the class of an input character */
13758 /*|start_numeric_token|,|start_decimal_token|,|fin_numeric_token|,|done|*/
13759 /* go here at crucial stages when scanning a number */
13760 int k; /* an index into |buffer| */
13761 ASCII_code c; /* the current character in the buffer */
13762 ASCII_code class; /* its class number */
13763 integer n,f; /* registers for decimal-to-binary conversion */
13766 if ( file_state ) {
13767 @<Input from external file; |goto restart| if no input found,
13768 or |return| if a non-symbolic token is found@>;
13770 @<Input from token list; |goto restart| if end of list or
13771 if a parameter needs to be expanded,
13772 or |return| if a non-symbolic token is found@>;
13775 @<Finish getting the symbolic token in |cur_sym|;
13776 |goto restart| if it is illegal@>;
13779 @ When a symbolic token is declared to be `\&{outer}', its command code
13780 is increased by |outer_tag|.
13783 @<Finish getting the symbolic token in |cur_sym|...@>=
13784 mp->cur_cmd=eq_type(mp->cur_sym); mp->cur_mod=equiv(mp->cur_sym);
13785 if ( mp->cur_cmd>=outer_tag ) {
13786 if ( mp_check_outer_validity(mp) )
13787 mp->cur_cmd=mp->cur_cmd-outer_tag;
13792 @ A percent sign appears in |buffer[limit]|; this makes it unnecessary
13793 to have a special test for end-of-line.
13796 @<Input from external file;...@>=
13799 c=mp->buffer[loc]; incr(loc); class=mp->char_class[c];
13801 case digit_class: goto START_NUMERIC_TOKEN; break;
13803 class=mp->char_class[mp->buffer[loc]];
13804 if ( class>period_class ) {
13806 } else if ( class<period_class ) { /* |class=digit_class| */
13807 n=0; goto START_DECIMAL_TOKEN;
13811 case space_class: goto SWITCH; break;
13812 case percent_class:
13813 if ( mp->scanner_status==tex_flushing ) {
13814 if ( loc<limit ) goto SWITCH;
13816 @<Move to next line of file, or |goto restart| if there is no next line@>;
13821 if ( mp->scanner_status==tex_flushing ) goto SWITCH;
13822 else @<Get a string token and |return|@>;
13824 case isolated_classes:
13825 k=loc-1; goto FOUND; break;
13826 case invalid_class:
13827 if ( mp->scanner_status==tex_flushing ) goto SWITCH;
13828 else @<Decry the invalid character and |goto restart|@>;
13830 default: break; /* letters, etc. */
13833 while ( mp->char_class[mp->buffer[loc]]==class ) incr(loc);
13835 START_NUMERIC_TOKEN:
13836 @<Get the integer part |n| of a numeric token;
13837 set |f:=0| and |goto fin_numeric_token| if there is no decimal point@>;
13838 START_DECIMAL_TOKEN:
13839 @<Get the fraction part |f| of a numeric token@>;
13841 @<Pack the numeric and fraction parts of a numeric token
13844 mp->cur_sym=mp_id_lookup(mp, k,loc-k);
13847 @ We go to |restart| instead of to |SWITCH|, because we might enter
13848 |token_state| after the error has been dealt with
13849 (cf.\ |clear_for_error_prompt|).
13851 @<Decry the invalid...@>=
13853 print_err("Text line contains an invalid character");
13854 @.Text line contains...@>
13855 help2("A funny symbol that I can\'t read has just been input.")
13856 ("Continue, and I'll forget that it ever happened.");
13857 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
13861 @ @<Get a string token and |return|@>=
13863 if ( mp->buffer[loc]=='"' ) {
13864 mp->cur_mod=rts("");
13866 k=loc; mp->buffer[limit+1]='"';
13869 } while (mp->buffer[loc]!='"');
13871 @<Decry the missing string delimiter and |goto restart|@>;
13874 mp->cur_mod=mp->buffer[k];
13878 append_char(mp->buffer[k]); incr(k);
13880 mp->cur_mod=mp_make_string(mp);
13883 incr(loc); mp->cur_cmd=string_token;
13887 @ We go to |restart| after this error message, not to |SWITCH|,
13888 because the |clear_for_error_prompt| routine might have reinstated
13889 |token_state| after |error| has finished.
13891 @<Decry the missing string delimiter and |goto restart|@>=
13893 loc=limit; /* the next character to be read on this line will be |"%"| */
13894 print_err("Incomplete string token has been flushed");
13895 @.Incomplete string token...@>
13896 help3("Strings should finish on the same line as they began.")
13897 ("I've deleted the partial string; you might want to")
13898 ("insert another by typing, e.g., `I\"new string\"'.");
13899 mp->deletions_allowed=false; mp_error(mp);
13900 mp->deletions_allowed=true;
13904 @ @<Get the integer part |n| of a numeric token...@>=
13906 while ( mp->char_class[mp->buffer[loc]]==digit_class ) {
13907 if ( n<32768 ) n=10*n+mp->buffer[loc]-'0';
13910 if ( mp->buffer[loc]=='.' )
13911 if ( mp->char_class[mp->buffer[loc+1]]==digit_class )
13914 goto FIN_NUMERIC_TOKEN;
13917 @ @<Get the fraction part |f| of a numeric token@>=
13920 if ( k<17 ) { /* digits for |k>=17| cannot affect the result */
13921 mp->dig[k]=mp->buffer[loc]-'0'; incr(k);
13924 } while (mp->char_class[mp->buffer[loc]]==digit_class);
13925 f=mp_round_decimals(mp, k);
13930 @ @<Pack the numeric and fraction parts of a numeric token and |return|@>=
13932 @<Set |cur_mod:=n*unity+f| and check if it is uncomfortably large@>;
13933 } else if ( mp->scanner_status!=tex_flushing ) {
13934 print_err("Enormous number has been reduced");
13935 @.Enormous number...@>
13936 help2("I can\'t handle numbers bigger than 32767.99998;")
13937 ("so I've changed your constant to that maximum amount.");
13938 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
13939 mp->cur_mod=el_gordo;
13941 mp->cur_cmd=numeric_token; return
13943 @ @<Set |cur_mod:=n*unity+f| and check if it is uncomfortably large@>=
13945 mp->cur_mod=n*unity+f;
13946 if ( mp->cur_mod>=fraction_one ) {
13947 if ( (mp->internal[mp_warning_check]>0) &&
13948 (mp->scanner_status!=tex_flushing) ) {
13949 print_err("Number is too large (");
13950 mp_print_scaled(mp, mp->cur_mod);
13951 mp_print_char(mp, ')');
13952 help3("It is at least 4096. Continue and I'll try to cope")
13953 ("with that big value; but it might be dangerous.")
13954 ("(Set warningcheck:=0 to suppress this message.)");
13960 @ Let's consider now what happens when |get_next| is looking at a token list.
13963 @<Input from token list;...@>=
13964 if ( loc>=mp->hi_mem_min ) { /* one-word token */
13965 mp->cur_sym=info(loc); loc=link(loc); /* move to next */
13966 if ( mp->cur_sym>=expr_base ) {
13967 if ( mp->cur_sym>=suffix_base ) {
13968 @<Insert a suffix or text parameter and |goto restart|@>;
13970 mp->cur_cmd=capsule_token;
13971 mp->cur_mod=mp->param_stack[param_start+mp->cur_sym-(expr_base)];
13972 mp->cur_sym=0; return;
13975 } else if ( loc>null ) {
13976 @<Get a stored numeric or string or capsule token and |return|@>
13977 } else { /* we are done with this token list */
13978 mp_end_token_list(mp); goto RESTART; /* resume previous level */
13981 @ @<Insert a suffix or text parameter...@>=
13983 if ( mp->cur_sym>=text_base ) mp->cur_sym=mp->cur_sym-mp->param_size;
13984 /* |param_size=text_base-suffix_base| */
13985 mp_begin_token_list(mp,
13986 mp->param_stack[param_start+mp->cur_sym-(suffix_base)],
13991 @ @<Get a stored numeric or string or capsule token...@>=
13993 if ( name_type(loc)==mp_token ) {
13994 mp->cur_mod=value(loc);
13995 if ( type(loc)==mp_known ) {
13996 mp->cur_cmd=numeric_token;
13998 mp->cur_cmd=string_token; add_str_ref(mp->cur_mod);
14001 mp->cur_mod=loc; mp->cur_cmd=capsule_token;
14003 loc=link(loc); return;
14006 @ All of the easy branches of |get_next| have now been taken care of.
14007 There is one more branch.
14009 @<Move to next line of file, or |goto restart|...@>=
14010 if ( name>max_spec_src ) {
14011 @<Read next line of file into |buffer|, or
14012 |goto restart| if the file has ended@>;
14014 if ( mp->input_ptr>0 ) {
14015 /* text was inserted during error recovery or by \&{scantokens} */
14016 mp_end_file_reading(mp); goto RESTART; /* resume previous level */
14018 if ( mp->selector<log_only || mp->selector>=write_file) mp_open_log_file(mp);
14019 if ( mp->interaction>mp_nonstop_mode ) {
14020 if ( limit==start ) /* previous line was empty */
14021 mp_print_nl(mp, "(Please type a command or say `end')");
14023 mp_print_ln(mp); mp->first=start;
14024 prompt_input("*"); /* input on-line into |buffer| */
14026 limit=mp->last; mp->buffer[limit]='%';
14027 mp->first=limit+1; loc=start;
14029 mp_fatal_error(mp, "*** (job aborted, no legal end found)");
14031 /* nonstop mode, which is intended for overnight batch processing,
14032 never waits for on-line input */
14036 @ The global variable |force_eof| is normally |false|; it is set |true|
14037 by an \&{endinput} command.
14040 boolean force_eof; /* should the next \&{input} be aborted early? */
14042 @ We must decrement |loc| in order to leave the buffer in a valid state
14043 when an error condition causes us to |goto restart| without calling
14044 |end_file_reading|.
14046 @<Read next line of file into |buffer|, or
14047 |goto restart| if the file has ended@>=
14049 incr(line); mp->first=start;
14050 if ( ! mp->force_eof ) {
14051 if ( mp_input_ln(mp, cur_file ) ) /* not end of file */
14052 mp_firm_up_the_line(mp); /* this sets |limit| */
14054 mp->force_eof=true;
14056 if ( mp->force_eof ) {
14057 mp->force_eof=false;
14059 if ( mpx_reading ) {
14060 @<Complain that the \.{MPX} file ended unexpectly; then set
14061 |cur_sym:=frozen_mpx_break| and |goto comon_ending|@>;
14063 mp_print_char(mp, ')'); decr(mp->open_parens);
14064 update_terminal; /* show user that file has been read */
14065 mp_end_file_reading(mp); /* resume previous level */
14066 if ( mp_check_outer_validity(mp) ) goto RESTART;
14070 mp->buffer[limit]='%'; mp->first=limit+1; loc=start; /* ready to read */
14073 @ We should never actually come to the end of an \.{MPX} file because such
14074 files should have an \&{mpxbreak} after the translation of the last
14075 \&{btex}$\,\ldots\,$\&{etex} block.
14077 @<Complain that the \.{MPX} file ended unexpectly; then set...@>=
14079 mp->mpx_name[index]=finished;
14080 print_err("mpx file ended unexpectedly");
14081 help4("The file had too few picture expressions for btex...etex")
14082 ("blocks. Such files are normally generated automatically")
14083 ("but this one got messed up. You might want to insert a")
14084 ("picture expression now.");
14085 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
14086 mp->cur_sym=frozen_mpx_break; goto COMMON_ENDING;
14089 @ Sometimes we want to make it look as though we have just read a blank line
14090 without really doing so.
14092 @<Put an empty line in the input buffer@>=
14093 mp->last=mp->first; limit=mp->last; /* simulate |input_ln| and |firm_up_the_line| */
14094 mp->buffer[limit]='%'; mp->first=limit+1; loc=start
14096 @ If the user has set the |mp_pausing| parameter to some positive value,
14097 and if nonstop mode has not been selected, each line of input is displayed
14098 on the terminal and the transcript file, followed by `\.{=>}'.
14099 \MP\ waits for a response. If the response is null (i.e., if nothing is
14100 typed except perhaps a few blank spaces), the original
14101 line is accepted as it stands; otherwise the line typed is
14102 used instead of the line in the file.
14104 @c void mp_firm_up_the_line (MP mp) {
14105 size_t k; /* an index into |buffer| */
14107 if ( mp->internal[mp_pausing]>0) if ( mp->interaction>mp_nonstop_mode ) {
14108 wake_up_terminal; mp_print_ln(mp);
14109 if ( start<limit ) {
14110 for (k=(size_t)start;k<=(size_t)(limit-1);k++) {
14111 mp_print_str(mp, mp->buffer[k]);
14114 mp->first=limit; prompt_input("=>"); /* wait for user response */
14116 if ( mp->last>mp->first ) {
14117 for (k=mp->first;k<=mp->last-1;k++) { /* move line down in buffer */
14118 mp->buffer[k+start-mp->first]=mp->buffer[k];
14120 limit=start+mp->last-mp->first;
14125 @* \[30] Dealing with \TeX\ material.
14126 The \&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}$\,\ldots\,$\&{etex}
14127 features need to be implemented at a low level in the scanning process
14128 so that \MP\ can stay in synch with the a preprocessor that treats
14129 blocks of \TeX\ material as they occur in the input file without trying
14130 to expand \MP\ macros. Thus we need a special version of |get_next|
14131 that does not expand macros and such but does handle \&{btex},
14132 \&{verbatimtex}, etc.
14134 The special version of |get_next| is called |get_t_next|. It works by flushing
14135 \&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}\allowbreak
14136 $\,\ldots\,$\&{etex} blocks, switching to the \.{MPX} file when it sees
14137 \&{btex}, and switching back when it sees \&{mpxbreak}.
14143 mp_primitive(mp, "btex",start_tex,btex_code);
14144 @:btex_}{\&{btex} primitive@>
14145 mp_primitive(mp, "verbatimtex",start_tex,verbatim_code);
14146 @:verbatimtex_}{\&{verbatimtex} primitive@>
14147 mp_primitive(mp, "etex",etex_marker,0); mp->eqtb[frozen_etex]=mp->eqtb[mp->cur_sym];
14148 @:etex_}{\&{etex} primitive@>
14149 mp_primitive(mp, "mpxbreak",mpx_break,0); mp->eqtb[frozen_mpx_break]=mp->eqtb[mp->cur_sym];
14150 @:mpx_break_}{\&{mpxbreak} primitive@>
14152 @ @<Cases of |print_cmd...@>=
14153 case start_tex: if ( m==btex_code ) mp_print(mp, "btex");
14154 else mp_print(mp, "verbatimtex"); break;
14155 case etex_marker: mp_print(mp, "etex"); break;
14156 case mpx_break: mp_print(mp, "mpxbreak"); break;
14158 @ Actually, |get_t_next| is a macro that avoids procedure overhead except
14159 in the unusual case where \&{btex}, \&{verbatimtex}, \&{etex}, or \&{mpxbreak}
14162 @d get_t_next {mp_get_next(mp); if ( mp->cur_cmd<=max_pre_command ) mp_t_next(mp); }
14165 void mp_start_mpx_input (MP mp);
14168 void mp_t_next (MP mp) {
14169 int old_status; /* saves the |scanner_status| */
14170 integer old_info; /* saves the |warning_info| */
14171 while ( mp->cur_cmd<=max_pre_command ) {
14172 if ( mp->cur_cmd==mpx_break ) {
14173 if ( ! file_state || (mp->mpx_name[index]==absent) ) {
14174 @<Complain about a misplaced \&{mpxbreak}@>;
14176 mp_end_mpx_reading(mp);
14179 } else if ( mp->cur_cmd==start_tex ) {
14180 if ( token_state || (name<=max_spec_src) ) {
14181 @<Complain that we are not reading a file@>;
14182 } else if ( mpx_reading ) {
14183 @<Complain that \.{MPX} files cannot contain \TeX\ material@>;
14184 } else if ( (mp->cur_mod!=verbatim_code)&&
14185 (mp->mpx_name[index]!=finished) ) {
14186 if ( ! mp_begin_mpx_reading(mp) ) mp_start_mpx_input(mp);
14191 @<Complain about a misplaced \&{etex}@>;
14193 goto COMMON_ENDING;
14195 @<Flush the \TeX\ material@>;
14201 @ We could be in the middle of an operation such as skipping false conditional
14202 text when \TeX\ material is encountered, so we must be careful to save the
14205 @<Flush the \TeX\ material@>=
14206 old_status=mp->scanner_status;
14207 old_info=mp->warning_info;
14208 mp->scanner_status=tex_flushing;
14209 mp->warning_info=line;
14210 do { mp_get_next(mp); } while (mp->cur_cmd!=etex_marker);
14211 mp->scanner_status=old_status;
14212 mp->warning_info=old_info
14214 @ @<Complain that \.{MPX} files cannot contain \TeX\ material@>=
14215 { print_err("An mpx file cannot contain btex or verbatimtex blocks");
14216 help4("This file contains picture expressions for btex...etex")
14217 ("blocks. Such files are normally generated automatically")
14218 ("but this one seems to be messed up. I'll just keep going")
14219 ("and hope for the best.");
14223 @ @<Complain that we are not reading a file@>=
14224 { print_err("You can only use `btex' or `verbatimtex' in a file");
14225 help3("I'll have to ignore this preprocessor command because it")
14226 ("only works when there is a file to preprocess. You might")
14227 ("want to delete everything up to the next `etex`.");
14231 @ @<Complain about a misplaced \&{mpxbreak}@>=
14232 { print_err("Misplaced mpxbreak");
14233 help2("I'll ignore this preprocessor command because it")
14234 ("doesn't belong here");
14238 @ @<Complain about a misplaced \&{etex}@>=
14239 { print_err("Extra etex will be ignored");
14240 help1("There is no btex or verbatimtex for this to match");
14244 @* \[31] Scanning macro definitions.
14245 \MP\ has a variety of ways to tuck tokens away into token lists for later
14246 use: Macros can be defined with \&{def}, \&{vardef}, \&{primarydef}, etc.;
14247 repeatable code can be defined with \&{for}, \&{forever}, \&{forsuffixes}.
14248 All such operations are handled by the routines in this part of the program.
14250 The modifier part of each command code is zero for the ``ending delimiters''
14251 like \&{enddef} and \&{endfor}.
14253 @d start_def 1 /* command modifier for \&{def} */
14254 @d var_def 2 /* command modifier for \&{vardef} */
14255 @d end_def 0 /* command modifier for \&{enddef} */
14256 @d start_forever 1 /* command modifier for \&{forever} */
14257 @d end_for 0 /* command modifier for \&{endfor} */
14260 mp_primitive(mp, "def",macro_def,start_def);
14261 @:def_}{\&{def} primitive@>
14262 mp_primitive(mp, "vardef",macro_def,var_def);
14263 @:var_def_}{\&{vardef} primitive@>
14264 mp_primitive(mp, "primarydef",macro_def,secondary_primary_macro);
14265 @:primary_def_}{\&{primarydef} primitive@>
14266 mp_primitive(mp, "secondarydef",macro_def,tertiary_secondary_macro);
14267 @:secondary_def_}{\&{secondarydef} primitive@>
14268 mp_primitive(mp, "tertiarydef",macro_def,expression_tertiary_macro);
14269 @:tertiary_def_}{\&{tertiarydef} primitive@>
14270 mp_primitive(mp, "enddef",macro_def,end_def); mp->eqtb[frozen_end_def]=mp->eqtb[mp->cur_sym];
14271 @:end_def_}{\&{enddef} primitive@>
14273 mp_primitive(mp, "for",iteration,expr_base);
14274 @:for_}{\&{for} primitive@>
14275 mp_primitive(mp, "forsuffixes",iteration,suffix_base);
14276 @:for_suffixes_}{\&{forsuffixes} primitive@>
14277 mp_primitive(mp, "forever",iteration,start_forever);
14278 @:forever_}{\&{forever} primitive@>
14279 mp_primitive(mp, "endfor",iteration,end_for); mp->eqtb[frozen_end_for]=mp->eqtb[mp->cur_sym];
14280 @:end_for_}{\&{endfor} primitive@>
14282 @ @<Cases of |print_cmd...@>=
14284 if ( m<=var_def ) {
14285 if ( m==start_def ) mp_print(mp, "def");
14286 else if ( m<start_def ) mp_print(mp, "enddef");
14287 else mp_print(mp, "vardef");
14288 } else if ( m==secondary_primary_macro ) {
14289 mp_print(mp, "primarydef");
14290 } else if ( m==tertiary_secondary_macro ) {
14291 mp_print(mp, "secondarydef");
14293 mp_print(mp, "tertiarydef");
14297 if ( m<=start_forever ) {
14298 if ( m==start_forever ) mp_print(mp, "forever");
14299 else mp_print(mp, "endfor");
14300 } else if ( m==expr_base ) {
14301 mp_print(mp, "for");
14303 mp_print(mp, "forsuffixes");
14307 @ Different macro-absorbing operations have different syntaxes, but they
14308 also have a lot in common. There is a list of special symbols that are to
14309 be replaced by parameter tokens; there is a special command code that
14310 ends the definition; the quotation conventions are identical. Therefore
14311 it makes sense to have most of the work done by a single subroutine. That
14312 subroutine is called |scan_toks|.
14314 The first parameter to |scan_toks| is the command code that will
14315 terminate scanning (either |macro_def| or |iteration|).
14317 The second parameter, |subst_list|, points to a (possibly empty) list
14318 of two-word nodes whose |info| and |value| fields specify symbol tokens
14319 before and after replacement. The list will be returned to free storage
14322 The third parameter is simply appended to the token list that is built.
14323 And the final parameter tells how many of the special operations
14324 \.{\#\AT!}, \.{\AT!}, and \.{\AT!\#} are to be replaced by suffix parameters.
14325 When such parameters are present, they are called \.{(SUFFIX0)},
14326 \.{(SUFFIX1)}, and \.{(SUFFIX2)}.
14328 @c pointer mp_scan_toks (MP mp,command_code terminator, pointer
14329 subst_list, pointer tail_end, small_number suffix_count) {
14330 pointer p; /* tail of the token list being built */
14331 pointer q; /* temporary for link management */
14332 integer balance; /* left delimiters minus right delimiters */
14333 p=hold_head; balance=1; link(hold_head)=null;
14336 if ( mp->cur_sym>0 ) {
14337 @<Substitute for |cur_sym|, if it's on the |subst_list|@>;
14338 if ( mp->cur_cmd==terminator ) {
14339 @<Adjust the balance; |break| if it's zero@>;
14340 } else if ( mp->cur_cmd==macro_special ) {
14341 @<Handle quoted symbols, \.{\#\AT!}, \.{\AT!}, or \.{\AT!\#}@>;
14344 link(p)=mp_cur_tok(mp); p=link(p);
14346 link(p)=tail_end; mp_flush_node_list(mp, subst_list);
14347 return link(hold_head);
14350 @ @<Substitute for |cur_sym|...@>=
14353 while ( q!=null ) {
14354 if ( info(q)==mp->cur_sym ) {
14355 mp->cur_sym=value(q); mp->cur_cmd=relax; break;
14361 @ @<Adjust the balance; |break| if it's zero@>=
14362 if ( mp->cur_mod>0 ) {
14370 @ Four commands are intended to be used only within macro texts: \&{quote},
14371 \.{\#\AT!}, \.{\AT!}, and \.{\AT!\#}. They are variants of a single command
14372 code called |macro_special|.
14374 @d quote 0 /* |macro_special| modifier for \&{quote} */
14375 @d macro_prefix 1 /* |macro_special| modifier for \.{\#\AT!} */
14376 @d macro_at 2 /* |macro_special| modifier for \.{\AT!} */
14377 @d macro_suffix 3 /* |macro_special| modifier for \.{\AT!\#} */
14380 mp_primitive(mp, "quote",macro_special,quote);
14381 @:quote_}{\&{quote} primitive@>
14382 mp_primitive(mp, "#@@",macro_special,macro_prefix);
14383 @:]]]\#\AT!_}{\.{\#\AT!} primitive@>
14384 mp_primitive(mp, "@@",macro_special,macro_at);
14385 @:]]]\AT!_}{\.{\AT!} primitive@>
14386 mp_primitive(mp, "@@#",macro_special,macro_suffix);
14387 @:]]]\AT!\#_}{\.{\AT!\#} primitive@>
14389 @ @<Cases of |print_cmd...@>=
14390 case macro_special:
14392 case macro_prefix: mp_print(mp, "#@@"); break;
14393 case macro_at: mp_print_char(mp, '@@'); break;
14394 case macro_suffix: mp_print(mp, "@@#"); break;
14395 default: mp_print(mp, "quote"); break;
14399 @ @<Handle quoted...@>=
14401 if ( mp->cur_mod==quote ) { get_t_next; }
14402 else if ( mp->cur_mod<=suffix_count )
14403 mp->cur_sym=suffix_base-1+mp->cur_mod;
14406 @ Here is a routine that's used whenever a token will be redefined. If
14407 the user's token is unredefinable, the `|frozen_inaccessible|' token is
14408 substituted; the latter is redefinable but essentially impossible to use,
14409 hence \MP's tables won't get fouled up.
14411 @c void mp_get_symbol (MP mp) { /* sets |cur_sym| to a safe symbol */
14414 if ( (mp->cur_sym==0)||(mp->cur_sym>frozen_inaccessible) ) {
14415 print_err("Missing symbolic token inserted");
14416 @.Missing symbolic token...@>
14417 help3("Sorry: You can\'t redefine a number, string, or expr.")
14418 ("I've inserted an inaccessible symbol so that your")
14419 ("definition will be completed without mixing me up too badly.");
14420 if ( mp->cur_sym>0 )
14421 mp->help_line[2]="Sorry: You can\'t redefine my error-recovery tokens.";
14422 else if ( mp->cur_cmd==string_token )
14423 delete_str_ref(mp->cur_mod);
14424 mp->cur_sym=frozen_inaccessible; mp_ins_error(mp); goto RESTART;
14428 @ Before we actually redefine a symbolic token, we need to clear away its
14429 former value, if it was a variable. The following stronger version of
14430 |get_symbol| does that.
14432 @c void mp_get_clear_symbol (MP mp) {
14433 mp_get_symbol(mp); mp_clear_symbol(mp, mp->cur_sym,false);
14436 @ Here's another little subroutine; it checks that an equals sign
14437 or assignment sign comes along at the proper place in a macro definition.
14439 @c void mp_check_equals (MP mp) {
14440 if ( mp->cur_cmd!=equals ) if ( mp->cur_cmd!=assignment ) {
14441 mp_missing_err(mp, "=");
14443 help5("The next thing in this `def' should have been `=',")
14444 ("because I've already looked at the definition heading.")
14445 ("But don't worry; I'll pretend that an equals sign")
14446 ("was present. Everything from here to `enddef'")
14447 ("will be the replacement text of this macro.");
14452 @ A \&{primarydef}, \&{secondarydef}, or \&{tertiarydef} is rather easily
14453 handled now that we have |scan_toks|. In this case there are
14454 two parameters, which will be \.{EXPR0} and \.{EXPR1} (i.e.,
14455 |expr_base| and |expr_base+1|).
14457 @c void mp_make_op_def (MP mp) {
14458 command_code m; /* the type of definition */
14459 pointer p,q,r; /* for list manipulation */
14461 mp_get_symbol(mp); q=mp_get_node(mp, token_node_size);
14462 info(q)=mp->cur_sym; value(q)=expr_base;
14463 mp_get_clear_symbol(mp); mp->warning_info=mp->cur_sym;
14464 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
14465 info(p)=mp->cur_sym; value(p)=expr_base+1; link(p)=q;
14466 get_t_next; mp_check_equals(mp);
14467 mp->scanner_status=op_defining; q=mp_get_avail(mp); ref_count(q)=null;
14468 r=mp_get_avail(mp); link(q)=r; info(r)=general_macro;
14469 link(r)=mp_scan_toks(mp, macro_def,p,null,0);
14470 mp->scanner_status=normal; eq_type(mp->warning_info)=m;
14471 equiv(mp->warning_info)=q; mp_get_x_next(mp);
14474 @ Parameters to macros are introduced by the keywords \&{expr},
14475 \&{suffix}, \&{text}, \&{primary}, \&{secondary}, and \&{tertiary}.
14478 mp_primitive(mp, "expr",param_type,expr_base);
14479 @:expr_}{\&{expr} primitive@>
14480 mp_primitive(mp, "suffix",param_type,suffix_base);
14481 @:suffix_}{\&{suffix} primitive@>
14482 mp_primitive(mp, "text",param_type,text_base);
14483 @:text_}{\&{text} primitive@>
14484 mp_primitive(mp, "primary",param_type,primary_macro);
14485 @:primary_}{\&{primary} primitive@>
14486 mp_primitive(mp, "secondary",param_type,secondary_macro);
14487 @:secondary_}{\&{secondary} primitive@>
14488 mp_primitive(mp, "tertiary",param_type,tertiary_macro);
14489 @:tertiary_}{\&{tertiary} primitive@>
14491 @ @<Cases of |print_cmd...@>=
14493 if ( m>=expr_base ) {
14494 if ( m==expr_base ) mp_print(mp, "expr");
14495 else if ( m==suffix_base ) mp_print(mp, "suffix");
14496 else mp_print(mp, "text");
14497 } else if ( m<secondary_macro ) {
14498 mp_print(mp, "primary");
14499 } else if ( m==secondary_macro ) {
14500 mp_print(mp, "secondary");
14502 mp_print(mp, "tertiary");
14506 @ Let's turn next to the more complex processing associated with \&{def}
14507 and \&{vardef}. When the following procedure is called, |cur_mod|
14508 should be either |start_def| or |var_def|.
14510 @c @<Declare the procedure called |check_delimiter|@>
14511 @<Declare the function called |scan_declared_variable|@>
14512 void mp_scan_def (MP mp) {
14513 int m; /* the type of definition */
14514 int n; /* the number of special suffix parameters */
14515 int k; /* the total number of parameters */
14516 int c; /* the kind of macro we're defining */
14517 pointer r; /* parameter-substitution list */
14518 pointer q; /* tail of the macro token list */
14519 pointer p; /* temporary storage */
14520 halfword base; /* |expr_base|, |suffix_base|, or |text_base| */
14521 pointer l_delim,r_delim; /* matching delimiters */
14522 m=mp->cur_mod; c=general_macro; link(hold_head)=null;
14523 q=mp_get_avail(mp); ref_count(q)=null; r=null;
14524 @<Scan the token or variable to be defined;
14525 set |n|, |scanner_status|, and |warning_info|@>;
14527 if ( mp->cur_cmd==left_delimiter ) {
14528 @<Absorb delimited parameters, putting them into lists |q| and |r|@>;
14530 if ( mp->cur_cmd==param_type ) {
14531 @<Absorb undelimited parameters, putting them into list |r|@>;
14533 mp_check_equals(mp);
14534 p=mp_get_avail(mp); info(p)=c; link(q)=p;
14535 @<Attach the replacement text to the tail of node |p|@>;
14536 mp->scanner_status=normal; mp_get_x_next(mp);
14539 @ We don't put `|frozen_end_group|' into the replacement text of
14540 a \&{vardef}, because the user may want to redefine `\.{endgroup}'.
14542 @<Attach the replacement text to the tail of node |p|@>=
14543 if ( m==start_def ) {
14544 link(p)=mp_scan_toks(mp, macro_def,r,null,n);
14546 q=mp_get_avail(mp); info(q)=mp->bg_loc; link(p)=q;
14547 p=mp_get_avail(mp); info(p)=mp->eg_loc;
14548 link(q)=mp_scan_toks(mp, macro_def,r,p,n);
14550 if ( mp->warning_info==bad_vardef )
14551 mp_flush_token_list(mp, value(bad_vardef))
14555 int eg_loc; /* hash addresses of `\.{begingroup}' and `\.{endgroup}' */
14557 @ @<Scan the token or variable to be defined;...@>=
14558 if ( m==start_def ) {
14559 mp_get_clear_symbol(mp); mp->warning_info=mp->cur_sym; get_t_next;
14560 mp->scanner_status=op_defining; n=0;
14561 eq_type(mp->warning_info)=defined_macro; equiv(mp->warning_info)=q;
14563 p=mp_scan_declared_variable(mp);
14564 mp_flush_variable(mp, equiv(info(p)),link(p),true);
14565 mp->warning_info=mp_find_variable(mp, p); mp_flush_list(mp, p);
14566 if ( mp->warning_info==null ) @<Change to `\.{a bad variable}'@>;
14567 mp->scanner_status=var_defining; n=2;
14568 if ( mp->cur_cmd==macro_special ) if ( mp->cur_mod==macro_suffix ) {/* \.{\AT!\#} */
14571 type(mp->warning_info)=mp_unsuffixed_macro-2+n; value(mp->warning_info)=q;
14572 } /* |mp_suffixed_macro=mp_unsuffixed_macro+1| */
14574 @ @<Change to `\.{a bad variable}'@>=
14576 print_err("This variable already starts with a macro");
14577 @.This variable already...@>
14578 help2("After `vardef a' you can\'t say `vardef a.b'.")
14579 ("So I'll have to discard this definition.");
14580 mp_error(mp); mp->warning_info=bad_vardef;
14583 @ @<Initialize table entries...@>=
14584 name_type(bad_vardef)=mp_root; link(bad_vardef)=frozen_bad_vardef;
14585 equiv(frozen_bad_vardef)=bad_vardef; eq_type(frozen_bad_vardef)=tag_token;
14587 @ @<Absorb delimited parameters, putting them into lists |q| and |r|@>=
14589 l_delim=mp->cur_sym; r_delim=mp->cur_mod; get_t_next;
14590 if ( (mp->cur_cmd==param_type)&&(mp->cur_mod>=expr_base) ) {
14593 print_err("Missing parameter type; `expr' will be assumed");
14594 @.Missing parameter type@>
14595 help1("You should've had `expr' or `suffix' or `text' here.");
14596 mp_back_error(mp); base=expr_base;
14598 @<Absorb parameter tokens for type |base|@>;
14599 mp_check_delimiter(mp, l_delim,r_delim);
14601 } while (mp->cur_cmd==left_delimiter)
14603 @ @<Absorb parameter tokens for type |base|@>=
14605 link(q)=mp_get_avail(mp); q=link(q); info(q)=base+k;
14606 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
14607 value(p)=base+k; info(p)=mp->cur_sym;
14608 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14609 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
14610 incr(k); link(p)=r; r=p; get_t_next;
14611 } while (mp->cur_cmd==comma)
14613 @ @<Absorb undelimited parameters, putting them into list |r|@>=
14615 p=mp_get_node(mp, token_node_size);
14616 if ( mp->cur_mod<expr_base ) {
14617 c=mp->cur_mod; value(p)=expr_base+k;
14619 value(p)=mp->cur_mod+k;
14620 if ( mp->cur_mod==expr_base ) c=expr_macro;
14621 else if ( mp->cur_mod==suffix_base ) c=suffix_macro;
14624 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14625 incr(k); mp_get_symbol(mp); info(p)=mp->cur_sym; link(p)=r; r=p; get_t_next;
14626 if ( c==expr_macro ) if ( mp->cur_cmd==of_token ) {
14627 c=of_macro; p=mp_get_node(mp, token_node_size);
14628 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14629 value(p)=expr_base+k; mp_get_symbol(mp); info(p)=mp->cur_sym;
14630 link(p)=r; r=p; get_t_next;
14634 @* \[32] Expanding the next token.
14635 Only a few command codes |<min_command| can possibly be returned by
14636 |get_t_next|; in increasing order, they are
14637 |if_test|, |fi_or_else|, |input|, |iteration|, |repeat_loop|,
14638 |exit_test|, |relax|, |scan_tokens|, |expand_after|, and |defined_macro|.
14640 \MP\ usually gets the next token of input by saying |get_x_next|. This is
14641 like |get_t_next| except that it keeps getting more tokens until
14642 finding |cur_cmd>=min_command|. In other words, |get_x_next| expands
14643 macros and removes conditionals or iterations or input instructions that
14646 It follows that |get_x_next| might invoke itself recursively. In fact,
14647 there is massive recursion, since macro expansion can involve the
14648 scanning of arbitrarily complex expressions, which in turn involve
14649 macro expansion and conditionals, etc.
14652 Therefore it's necessary to declare a whole bunch of |forward|
14653 procedures at this point, and to insert some other procedures
14654 that will be invoked by |get_x_next|.
14657 void mp_scan_primary (MP mp);
14658 void mp_scan_secondary (MP mp);
14659 void mp_scan_tertiary (MP mp);
14660 void mp_scan_expression (MP mp);
14661 void mp_scan_suffix (MP mp);
14662 @<Declare the procedure called |macro_call|@>
14663 void mp_get_boolean (MP mp);
14664 void mp_pass_text (MP mp);
14665 void mp_conditional (MP mp);
14666 void mp_start_input (MP mp);
14667 void mp_begin_iteration (MP mp);
14668 void mp_resume_iteration (MP mp);
14669 void mp_stop_iteration (MP mp);
14671 @ An auxiliary subroutine called |expand| is used by |get_x_next|
14672 when it has to do exotic expansion commands.
14674 @c void mp_expand (MP mp) {
14675 pointer p; /* for list manipulation */
14676 size_t k; /* something that we hope is |<=buf_size| */
14677 pool_pointer j; /* index into |str_pool| */
14678 if ( mp->internal[mp_tracing_commands]>unity )
14679 if ( mp->cur_cmd!=defined_macro )
14681 switch (mp->cur_cmd) {
14683 mp_conditional(mp); /* this procedure is discussed in Part 36 below */
14686 @<Terminate the current conditional and skip to \&{fi}@>;
14689 @<Initiate or terminate input from a file@>;
14692 if ( mp->cur_mod==end_for ) {
14693 @<Scold the user for having an extra \&{endfor}@>;
14695 mp_begin_iteration(mp); /* this procedure is discussed in Part 37 below */
14702 @<Exit a loop if the proper time has come@>;
14707 @<Expand the token after the next token@>;
14710 @<Put a string into the input buffer@>;
14712 case defined_macro:
14713 mp_macro_call(mp, mp->cur_mod,null,mp->cur_sym);
14715 }; /* there are no other cases */
14718 @ @<Scold the user...@>=
14720 print_err("Extra `endfor'");
14722 help2("I'm not currently working on a for loop,")
14723 ("so I had better not try to end anything.");
14727 @ The processing of \&{input} involves the |start_input| subroutine,
14728 which will be declared later; the processing of \&{endinput} is trivial.
14731 mp_primitive(mp, "input",input,0);
14732 @:input_}{\&{input} primitive@>
14733 mp_primitive(mp, "endinput",input,1);
14734 @:end_input_}{\&{endinput} primitive@>
14736 @ @<Cases of |print_cmd_mod|...@>=
14738 if ( m==0 ) mp_print(mp, "input");
14739 else mp_print(mp, "endinput");
14742 @ @<Initiate or terminate input...@>=
14743 if ( mp->cur_mod>0 ) mp->force_eof=true;
14744 else mp_start_input(mp)
14746 @ We'll discuss the complicated parts of loop operations later. For now
14747 it suffices to know that there's a global variable called |loop_ptr|
14748 that will be |null| if no loop is in progress.
14751 { while ( token_state &&(loc==null) )
14752 mp_end_token_list(mp); /* conserve stack space */
14753 if ( mp->loop_ptr==null ) {
14754 print_err("Lost loop");
14756 help2("I'm confused; after exiting from a loop, I still seem")
14757 ("to want to repeat it. I'll try to forget the problem.");
14760 mp_resume_iteration(mp); /* this procedure is in Part 37 below */
14764 @ @<Exit a loop if the proper time has come@>=
14765 { mp_get_boolean(mp);
14766 if ( mp->internal[mp_tracing_commands]>unity )
14767 mp_show_cmd_mod(mp, nullary,mp->cur_exp);
14768 if ( mp->cur_exp==true_code ) {
14769 if ( mp->loop_ptr==null ) {
14770 print_err("No loop is in progress");
14771 @.No loop is in progress@>
14772 help1("Why say `exitif' when there's nothing to exit from?");
14773 if ( mp->cur_cmd==semicolon ) mp_error(mp); else mp_back_error(mp);
14775 @<Exit prematurely from an iteration@>;
14777 } else if ( mp->cur_cmd!=semicolon ) {
14778 mp_missing_err(mp, ";");
14780 help2("After `exitif <boolean exp>' I expect to see a semicolon.")
14781 ("I shall pretend that one was there."); mp_back_error(mp);
14785 @ Here we use the fact that |forever_text| is the only |token_type| that
14786 is less than |loop_text|.
14788 @<Exit prematurely...@>=
14791 if ( file_state ) {
14792 mp_end_file_reading(mp);
14794 if ( token_type<=loop_text ) p=start;
14795 mp_end_token_list(mp);
14798 if ( p!=info(mp->loop_ptr) ) mp_fatal_error(mp, "*** (loop confusion)");
14800 mp_stop_iteration(mp); /* this procedure is in Part 34 below */
14803 @ @<Expand the token after the next token@>=
14805 p=mp_cur_tok(mp); get_t_next;
14806 if ( mp->cur_cmd<min_command ) mp_expand(mp);
14807 else mp_back_input(mp);
14811 @ @<Put a string into the input buffer@>=
14812 { mp_get_x_next(mp); mp_scan_primary(mp);
14813 if ( mp->cur_type!=mp_string_type ) {
14814 mp_disp_err(mp, null,"Not a string");
14816 help2("I'm going to flush this expression, since")
14817 ("scantokens should be followed by a known string.");
14818 mp_put_get_flush_error(mp, 0);
14821 if ( length(mp->cur_exp)>0 )
14822 @<Pretend we're reading a new one-line file@>;
14826 @ @<Pretend we're reading a new one-line file@>=
14827 { mp_begin_file_reading(mp); name=is_scantok;
14828 k=mp->first+length(mp->cur_exp);
14829 if ( k>=mp->max_buf_stack ) {
14830 while ( k>=mp->buf_size ) {
14831 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
14833 mp->max_buf_stack=k+1;
14835 j=mp->str_start[mp->cur_exp]; limit=k;
14836 while ( mp->first<(size_t)limit ) {
14837 mp->buffer[mp->first]=mp->str_pool[j]; incr(j); incr(mp->first);
14839 mp->buffer[limit]='%'; mp->first=limit+1; loc=start;
14840 mp_flush_cur_exp(mp, 0);
14843 @ Here finally is |get_x_next|.
14845 The expression scanning routines to be considered later
14846 communicate via the global quantities |cur_type| and |cur_exp|;
14847 we must be very careful to save and restore these quantities while
14848 macros are being expanded.
14852 void mp_get_x_next (MP mp);
14854 @ @c void mp_get_x_next (MP mp) {
14855 pointer save_exp; /* a capsule to save |cur_type| and |cur_exp| */
14857 if ( mp->cur_cmd<min_command ) {
14858 save_exp=mp_stash_cur_exp(mp);
14860 if ( mp->cur_cmd==defined_macro )
14861 mp_macro_call(mp, mp->cur_mod,null,mp->cur_sym);
14865 } while (mp->cur_cmd<min_command);
14866 mp_unstash_cur_exp(mp, save_exp); /* that restores |cur_type| and |cur_exp| */
14870 @ Now let's consider the |macro_call| procedure, which is used to start up
14871 all user-defined macros. Since the arguments to a macro might be expressions,
14872 |macro_call| is recursive.
14875 The first parameter to |macro_call| points to the reference count of the
14876 token list that defines the macro. The second parameter contains any
14877 arguments that have already been parsed (see below). The third parameter
14878 points to the symbolic token that names the macro. If the third parameter
14879 is |null|, the macro was defined by \&{vardef}, so its name can be
14880 reconstructed from the prefix and ``at'' arguments found within the
14883 What is this second parameter? It's simply a linked list of one-word items,
14884 whose |info| fields point to the arguments. In other words, if |arg_list=null|,
14885 no arguments have been scanned yet; otherwise |info(arg_list)| points to
14886 the first scanned argument, and |link(arg_list)| points to the list of
14887 further arguments (if any).
14889 Arguments of type \&{expr} are so-called capsules, which we will
14890 discuss later when we concentrate on expressions; they can be
14891 recognized easily because their |link| field is |void|. Arguments of type
14892 \&{suffix} and \&{text} are token lists without reference counts.
14894 @ After argument scanning is complete, the arguments are moved to the
14895 |param_stack|. (They can't be put on that stack any sooner, because
14896 the stack is growing and shrinking in unpredictable ways as more arguments
14897 are being acquired.) Then the macro body is fed to the scanner; i.e.,
14898 the replacement text of the macro is placed at the top of the \MP's
14899 input stack, so that |get_t_next| will proceed to read it next.
14901 @<Declare the procedure called |macro_call|@>=
14902 @<Declare the procedure called |print_macro_name|@>
14903 @<Declare the procedure called |print_arg|@>
14904 @<Declare the procedure called |scan_text_arg|@>
14905 void mp_macro_call (MP mp,pointer def_ref, pointer arg_list,
14906 pointer macro_name) ;
14909 void mp_macro_call (MP mp,pointer def_ref, pointer arg_list,
14910 pointer macro_name) {
14911 /* invokes a user-defined control sequence */
14912 pointer r; /* current node in the macro's token list */
14913 pointer p,q; /* for list manipulation */
14914 integer n; /* the number of arguments */
14915 pointer tail = 0; /* tail of the argument list */
14916 pointer l_delim=0,r_delim=0; /* a delimiter pair */
14917 r=link(def_ref); add_mac_ref(def_ref);
14918 if ( arg_list==null ) {
14921 @<Determine the number |n| of arguments already supplied,
14922 and set |tail| to the tail of |arg_list|@>;
14924 if ( mp->internal[mp_tracing_macros]>0 ) {
14925 @<Show the text of the macro being expanded, and the existing arguments@>;
14927 @<Scan the remaining arguments, if any; set |r| to the first token
14928 of the replacement text@>;
14929 @<Feed the arguments and replacement text to the scanner@>;
14932 @ @<Show the text of the macro...@>=
14933 mp_begin_diagnostic(mp); mp_print_ln(mp);
14934 mp_print_macro_name(mp, arg_list,macro_name);
14935 if ( n==3 ) mp_print(mp, "@@#"); /* indicate a suffixed macro */
14936 mp_show_macro(mp, def_ref,null,100000);
14937 if ( arg_list!=null ) {
14941 mp_print_arg(mp, q,n,0);
14942 incr(n); p=link(p);
14945 mp_end_diagnostic(mp, false)
14948 @ @<Declare the procedure called |print_macro_name|@>=
14949 void mp_print_macro_name (MP mp,pointer a, pointer n);
14952 void mp_print_macro_name (MP mp,pointer a, pointer n) {
14953 pointer p,q; /* they traverse the first part of |a| */
14959 mp_print_text(info(info(link(a))));
14962 while ( link(q)!=null ) q=link(q);
14963 link(q)=info(link(a));
14964 mp_show_token_list(mp, p,null,1000,0);
14970 @ @<Declare the procedure called |print_arg|@>=
14971 void mp_print_arg (MP mp,pointer q, integer n, pointer b) ;
14974 void mp_print_arg (MP mp,pointer q, integer n, pointer b) {
14975 if ( link(q)==mp_void ) mp_print_nl(mp, "(EXPR");
14976 else if ( (b<text_base)&&(b!=text_macro) ) mp_print_nl(mp, "(SUFFIX");
14977 else mp_print_nl(mp, "(TEXT");
14978 mp_print_int(mp, n); mp_print(mp, ")<-");
14979 if ( link(q)==mp_void ) mp_print_exp(mp, q,1);
14980 else mp_show_token_list(mp, q,null,1000,0);
14983 @ @<Determine the number |n| of arguments already supplied...@>=
14985 n=1; tail=arg_list;
14986 while ( link(tail)!=null ) {
14987 incr(n); tail=link(tail);
14991 @ @<Scan the remaining arguments, if any; set |r|...@>=
14992 mp->cur_cmd=comma+1; /* anything |<>comma| will do */
14993 while ( info(r)>=expr_base ) {
14994 @<Scan the delimited argument represented by |info(r)|@>;
14997 if ( mp->cur_cmd==comma ) {
14998 print_err("Too many arguments to ");
14999 @.Too many arguments...@>
15000 mp_print_macro_name(mp, arg_list,macro_name); mp_print_char(mp, ';');
15001 mp_print_nl(mp, " Missing `"); mp_print_text(r_delim);
15003 mp_print(mp, "' has been inserted");
15004 help3("I'm going to assume that the comma I just read was a")
15005 ("right delimiter, and then I'll begin expanding the macro.")
15006 ("You might want to delete some tokens before continuing.");
15009 if ( info(r)!=general_macro ) {
15010 @<Scan undelimited argument(s)@>;
15014 @ At this point, the reader will find it advisable to review the explanation
15015 of token list format that was presented earlier, paying special attention to
15016 the conventions that apply only at the beginning of a macro's token list.
15018 On the other hand, the reader will have to take the expression-parsing
15019 aspects of the following program on faith; we will explain |cur_type|
15020 and |cur_exp| later. (Several things in this program depend on each other,
15021 and it's necessary to jump into the circle somewhere.)
15023 @<Scan the delimited argument represented by |info(r)|@>=
15024 if ( mp->cur_cmd!=comma ) {
15026 if ( mp->cur_cmd!=left_delimiter ) {
15027 print_err("Missing argument to ");
15028 @.Missing argument...@>
15029 mp_print_macro_name(mp, arg_list,macro_name);
15030 help3("That macro has more parameters than you thought.")
15031 ("I'll continue by pretending that each missing argument")
15032 ("is either zero or null.");
15033 if ( info(r)>=suffix_base ) {
15034 mp->cur_exp=null; mp->cur_type=mp_token_list;
15036 mp->cur_exp=0; mp->cur_type=mp_known;
15038 mp_back_error(mp); mp->cur_cmd=right_delimiter;
15041 l_delim=mp->cur_sym; r_delim=mp->cur_mod;
15043 @<Scan the argument represented by |info(r)|@>;
15044 if ( mp->cur_cmd!=comma )
15045 @<Check that the proper right delimiter was present@>;
15047 @<Append the current expression to |arg_list|@>
15049 @ @<Check that the proper right delim...@>=
15050 if ( (mp->cur_cmd!=right_delimiter)||(mp->cur_mod!=l_delim) ) {
15051 if ( info(link(r))>=expr_base ) {
15052 mp_missing_err(mp, ",");
15054 help3("I've finished reading a macro argument and am about to")
15055 ("read another; the arguments weren't delimited correctly.")
15056 ("You might want to delete some tokens before continuing.");
15057 mp_back_error(mp); mp->cur_cmd=comma;
15059 mp_missing_err(mp, str(text(r_delim)));
15061 help2("I've gotten to the end of the macro parameter list.")
15062 ("You might want to delete some tokens before continuing.");
15067 @ A \&{suffix} or \&{text} parameter will have been scanned as
15068 a token list pointed to by |cur_exp|, in which case we will have
15069 |cur_type=token_list|.
15071 @<Append the current expression to |arg_list|@>=
15073 p=mp_get_avail(mp);
15074 if ( mp->cur_type==mp_token_list ) info(p)=mp->cur_exp;
15075 else info(p)=mp_stash_cur_exp(mp);
15076 if ( mp->internal[mp_tracing_macros]>0 ) {
15077 mp_begin_diagnostic(mp); mp_print_arg(mp, info(p),n,info(r));
15078 mp_end_diagnostic(mp, false);
15080 if ( arg_list==null ) arg_list=p;
15085 @ @<Scan the argument represented by |info(r)|@>=
15086 if ( info(r)>=text_base ) {
15087 mp_scan_text_arg(mp, l_delim,r_delim);
15090 if ( info(r)>=suffix_base ) mp_scan_suffix(mp);
15091 else mp_scan_expression(mp);
15094 @ The parameters to |scan_text_arg| are either a pair of delimiters
15095 or zero; the latter case is for undelimited text arguments, which
15096 end with the first semicolon or \&{endgroup} or \&{end} that is not
15097 contained in a group.
15099 @<Declare the procedure called |scan_text_arg|@>=
15100 void mp_scan_text_arg (MP mp,pointer l_delim, pointer r_delim) ;
15103 void mp_scan_text_arg (MP mp,pointer l_delim, pointer r_delim) {
15104 integer balance; /* excess of |l_delim| over |r_delim| */
15105 pointer p; /* list tail */
15106 mp->warning_info=l_delim; mp->scanner_status=absorbing;
15107 p=hold_head; balance=1; link(hold_head)=null;
15110 if ( l_delim==0 ) {
15111 @<Adjust the balance for an undelimited argument; |break| if done@>;
15113 @<Adjust the balance for a delimited argument; |break| if done@>;
15115 link(p)=mp_cur_tok(mp); p=link(p);
15117 mp->cur_exp=link(hold_head); mp->cur_type=mp_token_list;
15118 mp->scanner_status=normal;
15121 @ @<Adjust the balance for a delimited argument...@>=
15122 if ( mp->cur_cmd==right_delimiter ) {
15123 if ( mp->cur_mod==l_delim ) {
15125 if ( balance==0 ) break;
15127 } else if ( mp->cur_cmd==left_delimiter ) {
15128 if ( mp->cur_mod==r_delim ) incr(balance);
15131 @ @<Adjust the balance for an undelimited...@>=
15132 if ( end_of_statement ) { /* |cur_cmd=semicolon|, |end_group|, or |stop| */
15133 if ( balance==1 ) { break; }
15134 else { if ( mp->cur_cmd==end_group ) decr(balance); }
15135 } else if ( mp->cur_cmd==begin_group ) {
15139 @ @<Scan undelimited argument(s)@>=
15141 if ( info(r)<text_macro ) {
15143 if ( info(r)!=suffix_macro ) {
15144 if ( (mp->cur_cmd==equals)||(mp->cur_cmd==assignment) ) mp_get_x_next(mp);
15148 case primary_macro:mp_scan_primary(mp); break;
15149 case secondary_macro:mp_scan_secondary(mp); break;
15150 case tertiary_macro:mp_scan_tertiary(mp); break;
15151 case expr_macro:mp_scan_expression(mp); break;
15153 @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>;
15156 @<Scan a suffix with optional delimiters@>;
15158 case text_macro:mp_scan_text_arg(mp, 0,0); break;
15159 } /* there are no other cases */
15161 @<Append the current expression to |arg_list|@>;
15164 @ @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>=
15166 mp_scan_expression(mp); p=mp_get_avail(mp); info(p)=mp_stash_cur_exp(mp);
15167 if ( mp->internal[mp_tracing_macros]>0 ) {
15168 mp_begin_diagnostic(mp); mp_print_arg(mp, info(p),n,0);
15169 mp_end_diagnostic(mp, false);
15171 if ( arg_list==null ) arg_list=p; else link(tail)=p;
15173 if ( mp->cur_cmd!=of_token ) {
15174 mp_missing_err(mp, "of"); mp_print(mp, " for ");
15176 mp_print_macro_name(mp, arg_list,macro_name);
15177 help1("I've got the first argument; will look now for the other.");
15180 mp_get_x_next(mp); mp_scan_primary(mp);
15183 @ @<Scan a suffix with optional delimiters@>=
15185 if ( mp->cur_cmd!=left_delimiter ) {
15188 l_delim=mp->cur_sym; r_delim=mp->cur_mod; mp_get_x_next(mp);
15190 mp_scan_suffix(mp);
15191 if ( l_delim!=null ) {
15192 if ((mp->cur_cmd!=right_delimiter)||(mp->cur_mod!=l_delim) ) {
15193 mp_missing_err(mp, str(text(r_delim)));
15195 help2("I've gotten to the end of the macro parameter list.")
15196 ("You might want to delete some tokens before continuing.");
15203 @ Before we put a new token list on the input stack, it is wise to clean off
15204 all token lists that have recently been depleted. Then a user macro that ends
15205 with a call to itself will not require unbounded stack space.
15207 @<Feed the arguments and replacement text to the scanner@>=
15208 while ( token_state &&(loc==null) ) mp_end_token_list(mp); /* conserve stack space */
15209 if ( mp->param_ptr+n>mp->max_param_stack ) {
15210 mp->max_param_stack=mp->param_ptr+n;
15211 if ( mp->max_param_stack>mp->param_size )
15212 mp_overflow(mp, "parameter stack size",mp->param_size);
15213 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
15215 mp_begin_token_list(mp, def_ref,macro); name=macro_name; loc=r;
15219 mp->param_stack[mp->param_ptr]=info(p); incr(mp->param_ptr); p=link(p);
15221 mp_flush_list(mp, arg_list);
15224 @ It's sometimes necessary to put a single argument onto |param_stack|.
15225 The |stack_argument| subroutine does this.
15227 @c void mp_stack_argument (MP mp,pointer p) {
15228 if ( mp->param_ptr==mp->max_param_stack ) {
15229 incr(mp->max_param_stack);
15230 if ( mp->max_param_stack>mp->param_size )
15231 mp_overflow(mp, "parameter stack size",mp->param_size);
15232 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
15234 mp->param_stack[mp->param_ptr]=p; incr(mp->param_ptr);
15237 @* \[33] Conditional processing.
15238 Let's consider now the way \&{if} commands are handled.
15240 Conditions can be inside conditions, and this nesting has a stack
15241 that is independent of other stacks.
15242 Four global variables represent the top of the condition stack:
15243 |cond_ptr| points to pushed-down entries, if~any; |cur_if| tells whether
15244 we are processing \&{if} or \&{elseif}; |if_limit| specifies
15245 the largest code of a |fi_or_else| command that is syntactically legal;
15246 and |if_line| is the line number at which the current conditional began.
15248 If no conditions are currently in progress, the condition stack has the
15249 special state |cond_ptr=null|, |if_limit=normal|, |cur_if=0|, |if_line=0|.
15250 Otherwise |cond_ptr| points to a two-word node; the |type|, |name_type|, and
15251 |link| fields of the first word contain |if_limit|, |cur_if|, and
15252 |cond_ptr| at the next level, and the second word contains the
15253 corresponding |if_line|.
15255 @d if_node_size 2 /* number of words in stack entry for conditionals */
15256 @d if_line_field(A) mp->mem[(A)+1].cint
15257 @d if_code 1 /* code for \&{if} being evaluated */
15258 @d fi_code 2 /* code for \&{fi} */
15259 @d else_code 3 /* code for \&{else} */
15260 @d else_if_code 4 /* code for \&{elseif} */
15263 pointer cond_ptr; /* top of the condition stack */
15264 integer if_limit; /* upper bound on |fi_or_else| codes */
15265 small_number cur_if; /* type of conditional being worked on */
15266 integer if_line; /* line where that conditional began */
15269 mp->cond_ptr=null; mp->if_limit=normal; mp->cur_if=0; mp->if_line=0;
15272 mp_primitive(mp, "if",if_test,if_code);
15273 @:if_}{\&{if} primitive@>
15274 mp_primitive(mp, "fi",fi_or_else,fi_code); mp->eqtb[frozen_fi]=mp->eqtb[mp->cur_sym];
15275 @:fi_}{\&{fi} primitive@>
15276 mp_primitive(mp, "else",fi_or_else,else_code);
15277 @:else_}{\&{else} primitive@>
15278 mp_primitive(mp, "elseif",fi_or_else,else_if_code);
15279 @:else_if_}{\&{elseif} primitive@>
15281 @ @<Cases of |print_cmd_mod|...@>=
15285 case if_code:mp_print(mp, "if"); break;
15286 case fi_code:mp_print(mp, "fi"); break;
15287 case else_code:mp_print(mp, "else"); break;
15288 default: mp_print(mp, "elseif"); break;
15292 @ Here is a procedure that ignores text until coming to an \&{elseif},
15293 \&{else}, or \&{fi} at level zero of $\&{if}\ldots\&{fi}$
15294 nesting. After it has acted, |cur_mod| will indicate the token that
15297 \MP's smallest two command codes are |if_test| and |fi_or_else|; this
15298 makes the skipping process a bit simpler.
15301 void mp_pass_text (MP mp) {
15303 mp->scanner_status=skipping;
15304 mp->warning_info=mp_true_line(mp);
15307 if ( mp->cur_cmd<=fi_or_else ) {
15308 if ( mp->cur_cmd<fi_or_else ) {
15312 if ( mp->cur_mod==fi_code ) decr(l);
15315 @<Decrease the string reference count,
15316 if the current token is a string@>;
15319 mp->scanner_status=normal;
15322 @ @<Decrease the string reference count...@>=
15323 if ( mp->cur_cmd==string_token ) { delete_str_ref(mp->cur_mod); }
15325 @ When we begin to process a new \&{if}, we set |if_limit:=if_code|; then
15326 if \&{elseif} or \&{else} or \&{fi} occurs before the current \&{if}
15327 condition has been evaluated, a colon will be inserted.
15328 A construction like `\.{if fi}' would otherwise get \MP\ confused.
15330 @<Push the condition stack@>=
15331 { p=mp_get_node(mp, if_node_size); link(p)=mp->cond_ptr; type(p)=mp->if_limit;
15332 name_type(p)=mp->cur_if; if_line_field(p)=mp->if_line;
15333 mp->cond_ptr=p; mp->if_limit=if_code; mp->if_line=mp_true_line(mp);
15334 mp->cur_if=if_code;
15337 @ @<Pop the condition stack@>=
15338 { p=mp->cond_ptr; mp->if_line=if_line_field(p);
15339 mp->cur_if=name_type(p); mp->if_limit=type(p); mp->cond_ptr=link(p);
15340 mp_free_node(mp, p,if_node_size);
15343 @ Here's a procedure that changes the |if_limit| code corresponding to
15344 a given value of |cond_ptr|.
15346 @c void mp_change_if_limit (MP mp,small_number l, pointer p) {
15348 if ( p==mp->cond_ptr ) {
15349 mp->if_limit=l; /* that's the easy case */
15353 if ( q==null ) mp_confusion(mp, "if");
15354 @:this can't happen if}{\quad if@>
15355 if ( link(q)==p ) {
15363 @ The user is supposed to put colons into the proper parts of conditional
15364 statements. Therefore, \MP\ has to check for their presence.
15367 void mp_check_colon (MP mp) {
15368 if ( mp->cur_cmd!=colon ) {
15369 mp_missing_err(mp, ":");
15371 help2("There should've been a colon after the condition.")
15372 ("I shall pretend that one was there.");;
15377 @ A condition is started when the |get_x_next| procedure encounters
15378 an |if_test| command; in that case |get_x_next| calls |conditional|,
15379 which is a recursive procedure.
15382 @c void mp_conditional (MP mp) {
15383 pointer save_cond_ptr; /* |cond_ptr| corresponding to this conditional */
15384 int new_if_limit; /* future value of |if_limit| */
15385 pointer p; /* temporary register */
15386 @<Push the condition stack@>;
15387 save_cond_ptr=mp->cond_ptr;
15389 mp_get_boolean(mp); new_if_limit=else_if_code;
15390 if ( mp->internal[mp_tracing_commands]>unity ) {
15391 @<Display the boolean value of |cur_exp|@>;
15394 mp_check_colon(mp);
15395 if ( mp->cur_exp==true_code ) {
15396 mp_change_if_limit(mp, new_if_limit,save_cond_ptr);
15397 return; /* wait for \&{elseif}, \&{else}, or \&{fi} */
15399 @<Skip to \&{elseif} or \&{else} or \&{fi}, then |goto done|@>;
15401 mp->cur_if=mp->cur_mod; mp->if_line=mp_true_line(mp);
15402 if ( mp->cur_mod==fi_code ) {
15403 @<Pop the condition stack@>
15404 } else if ( mp->cur_mod==else_if_code ) {
15407 mp->cur_exp=true_code; new_if_limit=fi_code; mp_get_x_next(mp);
15412 @ In a construction like `\&{if} \&{if} \&{true}: $0=1$: \\{foo}
15413 \&{else}: \\{bar} \&{fi}', the first \&{else}
15414 that we come to after learning that the \&{if} is false is not the
15415 \&{else} we're looking for. Hence the following curious logic is needed.
15417 @<Skip to \&{elseif}...@>=
15420 if ( mp->cond_ptr==save_cond_ptr ) goto DONE;
15421 else if ( mp->cur_mod==fi_code ) @<Pop the condition stack@>;
15425 @ @<Display the boolean value...@>=
15426 { mp_begin_diagnostic(mp);
15427 if ( mp->cur_exp==true_code ) mp_print(mp, "{true}");
15428 else mp_print(mp, "{false}");
15429 mp_end_diagnostic(mp, false);
15432 @ The processing of conditionals is complete except for the following
15433 code, which is actually part of |get_x_next|. It comes into play when
15434 \&{elseif}, \&{else}, or \&{fi} is scanned.
15436 @<Terminate the current conditional and skip to \&{fi}@>=
15437 if ( mp->cur_mod>mp->if_limit ) {
15438 if ( mp->if_limit==if_code ) { /* condition not yet evaluated */
15439 mp_missing_err(mp, ":");
15441 mp_back_input(mp); mp->cur_sym=frozen_colon; mp_ins_error(mp);
15443 print_err("Extra "); mp_print_cmd_mod(mp, fi_or_else,mp->cur_mod);
15447 help1("I'm ignoring this; it doesn't match any if.");
15451 while ( mp->cur_mod!=fi_code ) mp_pass_text(mp); /* skip to \&{fi} */
15452 @<Pop the condition stack@>;
15455 @* \[34] Iterations.
15456 To bring our treatment of |get_x_next| to a close, we need to consider what
15457 \MP\ does when it sees \&{for}, \&{forsuffixes}, and \&{forever}.
15459 There's a global variable |loop_ptr| that keeps track of the \&{for} loops
15460 that are currently active. If |loop_ptr=null|, no loops are in progress;
15461 otherwise |info(loop_ptr)| points to the iterative text of the current
15462 (innermost) loop, and |link(loop_ptr)| points to the data for any other
15463 loops that enclose the current one.
15465 A loop-control node also has two other fields, called |loop_type| and
15466 |loop_list|, whose contents depend on the type of loop:
15468 \yskip\indent|loop_type(loop_ptr)=null| means that |loop_list(loop_ptr)|
15469 points to a list of one-word nodes whose |info| fields point to the
15470 remaining argument values of a suffix list and expression list.
15472 \yskip\indent|loop_type(loop_ptr)=mp_void| means that the current loop is
15475 \yskip\indent|loop_type(loop_ptr)=progression_flag| means that
15476 |p=loop_list(loop_ptr)| points to a ``progression node'' and |value(p)|,
15477 |step_size(p)|, and |final_value(p)| contain the data for an arithmetic
15480 \yskip\indent|loop_type(loop_ptr)=p>mp_void| means that |p| points to an edge
15481 header and |loop_list(loop_ptr)| points into the graphical object list for
15484 \yskip\noindent In the case of a progression node, the first word is not used
15485 because the link field of words in the dynamic memory area cannot be arbitrary.
15487 @d loop_list_loc(A) ((A)+1) /* where the |loop_list| field resides */
15488 @d loop_type(A) info(loop_list_loc((A))) /* the type of \&{for} loop */
15489 @d loop_list(A) link(loop_list_loc((A))) /* the remaining list elements */
15490 @d loop_node_size 2 /* the number of words in a loop control node */
15491 @d progression_node_size 4 /* the number of words in a progression node */
15492 @d step_size(A) mp->mem[(A)+2].sc /* the step size in an arithmetic progression */
15493 @d final_value(A) mp->mem[(A)+3].sc /* the final value in an arithmetic progression */
15494 @d progression_flag (null+2)
15495 /* |loop_type| value when |loop_list| points to a progression node */
15498 pointer loop_ptr; /* top of the loop-control-node stack */
15503 @ If the expressions that define an arithmetic progression in
15504 a \&{for} loop don't have known numeric values, the |bad_for|
15505 subroutine screams at the user.
15507 @c void mp_bad_for (MP mp, const char * s) {
15508 mp_disp_err(mp, null,"Improper "); /* show the bad expression above the message */
15509 @.Improper...replaced by 0@>
15510 mp_print(mp, s); mp_print(mp, " has been replaced by 0");
15511 help4("When you say `for x=a step b until c',")
15512 ("the initial value `a' and the step size `b'")
15513 ("and the final value `c' must have known numeric values.")
15514 ("I'm zeroing this one. Proceed, with fingers crossed.");
15515 mp_put_get_flush_error(mp, 0);
15518 @ Here's what \MP\ does when \&{for}, \&{forsuffixes}, or \&{forever}
15519 has just been scanned. (This code requires slight familiarity with
15520 expression-parsing routines that we have not yet discussed; but it seems
15521 to belong in the present part of the program, even though the original author
15522 didn't write it until later. The reader may wish to come back to it.)
15524 @c void mp_begin_iteration (MP mp) {
15525 halfword m; /* |expr_base| (\&{for}) or |suffix_base| (\&{forsuffixes}) */
15526 halfword n; /* hash address of the current symbol */
15527 pointer s; /* the new loop-control node */
15528 pointer p; /* substitution list for |scan_toks| */
15529 pointer q; /* link manipulation register */
15530 pointer pp; /* a new progression node */
15531 m=mp->cur_mod; n=mp->cur_sym; s=mp_get_node(mp, loop_node_size);
15532 if ( m==start_forever ){
15533 loop_type(s)=mp_void; p=null; mp_get_x_next(mp);
15535 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
15536 info(p)=mp->cur_sym; value(p)=m;
15538 if ( mp->cur_cmd==within_token ) {
15539 @<Set up a picture iteration@>;
15541 @<Check for the |"="| or |":="| in a loop header@>;
15542 @<Scan the values to be used in the loop@>;
15545 @<Check for the presence of a colon@>;
15546 @<Scan the loop text and put it on the loop control stack@>;
15547 mp_resume_iteration(mp);
15550 @ @<Check for the |"="| or |":="| in a loop header@>=
15551 if ( (mp->cur_cmd!=equals)&&(mp->cur_cmd!=assignment) ) {
15552 mp_missing_err(mp, "=");
15554 help3("The next thing in this loop should have been `=' or `:='.")
15555 ("But don't worry; I'll pretend that an equals sign")
15556 ("was present, and I'll look for the values next.");
15560 @ @<Check for the presence of a colon@>=
15561 if ( mp->cur_cmd!=colon ) {
15562 mp_missing_err(mp, ":");
15564 help3("The next thing in this loop should have been a `:'.")
15565 ("So I'll pretend that a colon was present;")
15566 ("everything from here to `endfor' will be iterated.");
15570 @ We append a special |frozen_repeat_loop| token in place of the
15571 `\&{endfor}' at the end of the loop. This will come through \MP's scanner
15572 at the proper time to cause the loop to be repeated.
15574 (If the user tries some shenanigan like `\&{for} $\ldots$ \&{let} \&{endfor}',
15575 he will be foiled by the |get_symbol| routine, which keeps frozen
15576 tokens unchanged. Furthermore the |frozen_repeat_loop| is an \&{outer}
15577 token, so it won't be lost accidentally.)
15579 @ @<Scan the loop text...@>=
15580 q=mp_get_avail(mp); info(q)=frozen_repeat_loop;
15581 mp->scanner_status=loop_defining; mp->warning_info=n;
15582 info(s)=mp_scan_toks(mp, iteration,p,q,0); mp->scanner_status=normal;
15583 link(s)=mp->loop_ptr; mp->loop_ptr=s
15585 @ @<Initialize table...@>=
15586 eq_type(frozen_repeat_loop)=repeat_loop+outer_tag;
15587 text(frozen_repeat_loop)=intern(" ENDFOR");
15589 @ The loop text is inserted into \MP's scanning apparatus by the
15590 |resume_iteration| routine.
15592 @c void mp_resume_iteration (MP mp) {
15593 pointer p,q; /* link registers */
15594 p=loop_type(mp->loop_ptr);
15595 if ( p==progression_flag ) {
15596 p=loop_list(mp->loop_ptr); /* now |p| points to a progression node */
15597 mp->cur_exp=value(p);
15598 if ( @<The arithmetic progression has ended@> ) {
15599 mp_stop_iteration(mp);
15602 mp->cur_type=mp_known; q=mp_stash_cur_exp(mp); /* make |q| an \&{expr} argument */
15603 value(p)=mp->cur_exp+step_size(p); /* set |value(p)| for the next iteration */
15604 } else if ( p==null ) {
15605 p=loop_list(mp->loop_ptr);
15607 mp_stop_iteration(mp);
15610 loop_list(mp->loop_ptr)=link(p); q=info(p); free_avail(p);
15611 } else if ( p==mp_void ) {
15612 mp_begin_token_list(mp, info(mp->loop_ptr),forever_text); return;
15614 @<Make |q| a capsule containing the next picture component from
15615 |loop_list(loop_ptr)| or |goto not_found|@>;
15617 mp_begin_token_list(mp, info(mp->loop_ptr),loop_text);
15618 mp_stack_argument(mp, q);
15619 if ( mp->internal[mp_tracing_commands]>unity ) {
15620 @<Trace the start of a loop@>;
15624 mp_stop_iteration(mp);
15627 @ @<The arithmetic progression has ended@>=
15628 ((step_size(p)>0)&&(mp->cur_exp>final_value(p)))||
15629 ((step_size(p)<0)&&(mp->cur_exp<final_value(p)))
15631 @ @<Trace the start of a loop@>=
15633 mp_begin_diagnostic(mp); mp_print_nl(mp, "{loop value=");
15635 if ( (q!=null)&&(link(q)==mp_void) ) mp_print_exp(mp, q,1);
15636 else mp_show_token_list(mp, q,null,50,0);
15637 mp_print_char(mp, '}'); mp_end_diagnostic(mp, false);
15640 @ @<Make |q| a capsule containing the next picture component from...@>=
15641 { q=loop_list(mp->loop_ptr);
15642 if ( q==null ) goto NOT_FOUND;
15643 skip_component(q) goto NOT_FOUND;
15644 mp->cur_exp=mp_copy_objects(mp, loop_list(mp->loop_ptr),q);
15645 mp_init_bbox(mp, mp->cur_exp);
15646 mp->cur_type=mp_picture_type;
15647 loop_list(mp->loop_ptr)=q;
15648 q=mp_stash_cur_exp(mp);
15651 @ A level of loop control disappears when |resume_iteration| has decided
15652 not to resume, or when an \&{exitif} construction has removed the loop text
15653 from the input stack.
15655 @c void mp_stop_iteration (MP mp) {
15656 pointer p,q; /* the usual */
15657 p=loop_type(mp->loop_ptr);
15658 if ( p==progression_flag ) {
15659 mp_free_node(mp, loop_list(mp->loop_ptr),progression_node_size);
15660 } else if ( p==null ){
15661 q=loop_list(mp->loop_ptr);
15662 while ( q!=null ) {
15665 if ( link(p)==mp_void ) { /* it's an \&{expr} parameter */
15666 mp_recycle_value(mp, p); mp_free_node(mp, p,value_node_size);
15668 mp_flush_token_list(mp, p); /* it's a \&{suffix} or \&{text} parameter */
15671 p=q; q=link(q); free_avail(p);
15673 } else if ( p>progression_flag ) {
15674 delete_edge_ref(p);
15676 p=mp->loop_ptr; mp->loop_ptr=link(p); mp_flush_token_list(mp, info(p));
15677 mp_free_node(mp, p,loop_node_size);
15680 @ Now that we know all about loop control, we can finish up
15681 the missing portion of |begin_iteration| and we'll be done.
15683 The following code is performed after the `\.=' has been scanned in
15684 a \&{for} construction (if |m=expr_base|) or a \&{forsuffixes} construction
15685 (if |m=suffix_base|).
15687 @<Scan the values to be used in the loop@>=
15688 loop_type(s)=null; q=loop_list_loc(s); link(q)=null; /* |link(q)=loop_list(s)| */
15691 if ( m!=expr_base ) {
15692 mp_scan_suffix(mp);
15694 if ( mp->cur_cmd>=colon ) if ( mp->cur_cmd<=comma )
15696 mp_scan_expression(mp);
15697 if ( mp->cur_cmd==step_token ) if ( q==loop_list_loc(s) ) {
15698 @<Prepare for step-until construction and |break|@>;
15700 mp->cur_exp=mp_stash_cur_exp(mp);
15702 link(q)=mp_get_avail(mp); q=link(q);
15703 info(q)=mp->cur_exp; mp->cur_type=mp_vacuous;
15706 } while (mp->cur_cmd==comma)
15708 @ @<Prepare for step-until construction and |break|@>=
15710 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "initial value");
15711 pp=mp_get_node(mp, progression_node_size); value(pp)=mp->cur_exp;
15712 mp_get_x_next(mp); mp_scan_expression(mp);
15713 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "step size");
15714 step_size(pp)=mp->cur_exp;
15715 if ( mp->cur_cmd!=until_token ) {
15716 mp_missing_err(mp, "until");
15717 @.Missing `until'@>
15718 help2("I assume you meant to say `until' after `step'.")
15719 ("So I'll look for the final value and colon next.");
15722 mp_get_x_next(mp); mp_scan_expression(mp);
15723 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "final value");
15724 final_value(pp)=mp->cur_exp; loop_list(s)=pp;
15725 loop_type(s)=progression_flag;
15729 @ The last case is when we have just seen ``\&{within}'', and we need to
15730 parse a picture expression and prepare to iterate over it.
15732 @<Set up a picture iteration@>=
15733 { mp_get_x_next(mp);
15734 mp_scan_expression(mp);
15735 @<Make sure the current expression is a known picture@>;
15736 loop_type(s)=mp->cur_exp; mp->cur_type=mp_vacuous;
15737 q=link(dummy_loc(mp->cur_exp));
15739 if ( is_start_or_stop(q) )
15740 if ( mp_skip_1component(mp, q)==null ) q=link(q);
15744 @ @<Make sure the current expression is a known picture@>=
15745 if ( mp->cur_type!=mp_picture_type ) {
15746 mp_disp_err(mp, null,"Improper iteration spec has been replaced by nullpicture");
15747 help1("When you say `for x in p', p must be a known picture.");
15748 mp_put_get_flush_error(mp, mp_get_node(mp, edge_header_size));
15749 mp_init_edges(mp, mp->cur_exp); mp->cur_type=mp_picture_type;
15752 @* \[35] File names.
15753 It's time now to fret about file names. Besides the fact that different
15754 operating systems treat files in different ways, we must cope with the
15755 fact that completely different naming conventions are used by different
15756 groups of people. The following programs show what is required for one
15757 particular operating system; similar routines for other systems are not
15758 difficult to devise.
15759 @^system dependencies@>
15761 \MP\ assumes that a file name has three parts: the name proper; its
15762 ``extension''; and a ``file area'' where it is found in an external file
15763 system. The extension of an input file is assumed to be
15764 `\.{.mp}' unless otherwise specified; it is `\.{.log}' on the
15765 transcript file that records each run of \MP; it is `\.{.tfm}' on the font
15766 metric files that describe characters in any fonts created by \MP; it is
15767 `\.{.ps}' or `.{\it nnn}' for some number {\it nnn} on the \ps\ output files;
15768 and it is `\.{.mem}' on the mem files written by \.{INIMP} to initialize \MP.
15769 The file area can be arbitrary on input files, but files are usually
15770 output to the user's current area. If an input file cannot be
15771 found on the specified area, \MP\ will look for it on a special system
15772 area; this special area is intended for commonly used input files.
15774 Simple uses of \MP\ refer only to file names that have no explicit
15775 extension or area. For example, a person usually says `\.{input} \.{cmr10}'
15776 instead of `\.{input} \.{cmr10.new}'. Simple file
15777 names are best, because they make the \MP\ source files portable;
15778 whenever a file name consists entirely of letters and digits, it should be
15779 treated in the same way by all implementations of \MP. However, users
15780 need the ability to refer to other files in their environment, especially
15781 when responding to error messages concerning unopenable files; therefore
15782 we want to let them use the syntax that appears in their favorite
15785 @ \MP\ uses the same conventions that have proved to be satisfactory for
15786 \TeX\ and \MF. In order to isolate the system-dependent aspects of file names,
15787 @^system dependencies@>
15788 the system-independent parts of \MP\ are expressed in terms
15789 of three system-dependent
15790 procedures called |begin_name|, |more_name|, and |end_name|. In
15791 essence, if the user-specified characters of the file name are $c_1\ldots c_n$,
15792 the system-independent driver program does the operations
15793 $$|begin_name|;\,|more_name|(c_1);\,\ldots\,;\,|more_name|(c_n);
15795 These three procedures communicate with each other via global variables.
15796 Afterwards the file name will appear in the string pool as three strings
15797 called |cur_name|\penalty10000\hskip-.05em,
15798 |cur_area|, and |cur_ext|; the latter two are null (i.e.,
15799 |""|), unless they were explicitly specified by the user.
15801 Actually the situation is slightly more complicated, because \MP\ needs
15802 to know when the file name ends. The |more_name| routine is a function
15803 (with side effects) that returns |true| on the calls |more_name|$(c_1)$,
15804 \dots, |more_name|$(c_{n-1})$. The final call |more_name|$(c_n)$
15805 returns |false|; or, it returns |true| and $c_n$ is the last character
15806 on the current input line. In other words,
15807 |more_name| is supposed to return |true| unless it is sure that the
15808 file name has been completely scanned; and |end_name| is supposed to be able
15809 to finish the assembly of |cur_name|, |cur_area|, and |cur_ext| regardless of
15810 whether $|more_name|(c_n)$ returned |true| or |false|.
15813 char * cur_name; /* name of file just scanned */
15814 char * cur_area; /* file area just scanned, or \.{""} */
15815 char * cur_ext; /* file extension just scanned, or \.{""} */
15817 @ It is easier to maintain reference counts if we assign initial values.
15820 mp->cur_name=xstrdup("");
15821 mp->cur_area=xstrdup("");
15822 mp->cur_ext=xstrdup("");
15824 @ @<Dealloc variables@>=
15825 xfree(mp->cur_area);
15826 xfree(mp->cur_name);
15827 xfree(mp->cur_ext);
15829 @ The file names we shall deal with for illustrative purposes have the
15830 following structure: If the name contains `\.>' or `\.:', the file area
15831 consists of all characters up to and including the final such character;
15832 otherwise the file area is null. If the remaining file name contains
15833 `\..', the file extension consists of all such characters from the first
15834 remaining `\..' to the end, otherwise the file extension is null.
15835 @^system dependencies@>
15837 We can scan such file names easily by using two global variables that keep track
15838 of the occurrences of area and extension delimiters. Note that these variables
15839 cannot be of type |pool_pointer| because a string pool compaction could occur
15840 while scanning a file name.
15843 integer area_delimiter;
15844 /* most recent `\.>' or `\.:' relative to |str_start[str_ptr]| */
15845 integer ext_delimiter; /* the relevant `\..', if any */
15847 @ Here now is the first of the system-dependent routines for file name scanning.
15848 @^system dependencies@>
15850 The file name length is limited to |file_name_size|. That is good, because
15851 in the current configuration we cannot call |mp_do_compaction| while a name
15852 is being scanned, |mp->area_delimiter| and |mp->ext_delimiter| are direct
15853 offsets into |mp->str_pool|. I am not in a great hurry to fix this, because
15854 calling |str_room()| just once is more efficient anyway. TODO.
15856 @<Declare subroutines for parsing file names@>=
15857 void mp_begin_name (MP mp) {
15858 xfree(mp->cur_name);
15859 xfree(mp->cur_area);
15860 xfree(mp->cur_ext);
15861 mp->area_delimiter=-1;
15862 mp->ext_delimiter=-1;
15863 str_room(file_name_size);
15866 @ And here's the second.
15867 @^system dependencies@>
15869 @<Declare subroutines for parsing file names@>=
15870 boolean mp_more_name (MP mp, ASCII_code c) {
15874 if ( (c=='>')||(c==':') ) {
15875 mp->area_delimiter=mp->pool_ptr;
15876 mp->ext_delimiter=-1;
15877 } else if ( (c=='.')&&(mp->ext_delimiter<0) ) {
15878 mp->ext_delimiter=mp->pool_ptr;
15880 append_char(c); /* contribute |c| to the current string */
15886 @^system dependencies@>
15888 @d copy_pool_segment(A,B,C) {
15889 A = xmalloc(C+1,sizeof(char));
15890 strncpy(A,(char *)(mp->str_pool+B),C);
15893 @<Declare subroutines for parsing file names@>=
15894 void mp_end_name (MP mp) {
15895 pool_pointer s; /* length of area, name, and extension */
15898 s = mp->str_start[mp->str_ptr];
15899 if ( mp->area_delimiter<0 ) {
15900 mp->cur_area=xstrdup("");
15902 len = mp->area_delimiter-s;
15903 copy_pool_segment(mp->cur_area,s,len);
15906 if ( mp->ext_delimiter<0 ) {
15907 mp->cur_ext=xstrdup("");
15908 len = mp->pool_ptr-s;
15910 copy_pool_segment(mp->cur_ext,mp->ext_delimiter,(mp->pool_ptr-mp->ext_delimiter));
15911 len = mp->ext_delimiter-s;
15913 copy_pool_segment(mp->cur_name,s,len);
15914 mp->pool_ptr=s; /* don't need this partial string */
15917 @ Conversely, here is a routine that takes three strings and prints a file
15918 name that might have produced them. (The routine is system dependent, because
15919 some operating systems put the file area last instead of first.)
15920 @^system dependencies@>
15922 @<Basic printing...@>=
15923 void mp_print_file_name (MP mp, char * n, char * a, char * e) {
15924 mp_print(mp, a); mp_print(mp, n); mp_print(mp, e);
15927 @ Another system-dependent routine is needed to convert three internal
15929 to the |name_of_file| value that is used to open files. The present code
15930 allows both lowercase and uppercase letters in the file name.
15931 @^system dependencies@>
15933 @d append_to_name(A) { c=(A);
15934 if ( k<file_name_size ) {
15935 mp->name_of_file[k]=xchr(c);
15940 @<Declare subroutines for parsing file names@>=
15941 void mp_pack_file_name (MP mp, const char *n, const char *a, const char *e) {
15942 integer k; /* number of positions filled in |name_of_file| */
15943 ASCII_code c; /* character being packed */
15944 const char *j; /* a character index */
15948 for (j=a;*j;j++) { append_to_name(*j); }
15950 for (j=n;*j;j++) { append_to_name(*j); }
15952 for (j=e;*j;j++) { append_to_name(*j); }
15954 mp->name_of_file[k]=0;
15958 @ @<Internal library declarations@>=
15959 void mp_pack_file_name (MP mp, const char *n, const char *a, const char *e) ;
15961 @ A messier routine is also needed, since mem file names must be scanned
15962 before \MP's string mechanism has been initialized. We shall use the
15963 global variable |MP_mem_default| to supply the text for default system areas
15964 and extensions related to mem files.
15965 @^system dependencies@>
15967 @d mem_default_length 9 /* length of the |MP_mem_default| string */
15968 @d mem_ext_length 4 /* length of its `\.{.mem}' part */
15969 @d mem_extension ".mem" /* the extension, as a \.{WEB} constant */
15972 char *MP_mem_default;
15974 @ @<Option variables@>=
15975 char *mem_name; /* for commandline */
15977 @ @<Allocate or initialize ...@>=
15978 mp->MP_mem_default = xstrdup("plain.mem");
15979 mp->mem_name = xstrdup(opt->mem_name);
15981 @^system dependencies@>
15983 @ @<Dealloc variables@>=
15984 xfree(mp->MP_mem_default);
15985 xfree(mp->mem_name);
15987 @ @<Check the ``constant'' values for consistency@>=
15988 if ( mem_default_length>file_name_size ) mp->bad=20;
15990 @ Here is the messy routine that was just mentioned. It sets |name_of_file|
15991 from the first |n| characters of |MP_mem_default|, followed by
15992 |buffer[a..b-1]|, followed by the last |mem_ext_length| characters of
15995 We dare not give error messages here, since \MP\ calls this routine before
15996 the |error| routine is ready to roll. Instead, we simply drop excess characters,
15997 since the error will be detected in another way when a strange file name
15999 @^system dependencies@>
16001 @c void mp_pack_buffered_name (MP mp,small_number n, integer a,
16003 integer k; /* number of positions filled in |name_of_file| */
16004 ASCII_code c; /* character being packed */
16005 integer j; /* index into |buffer| or |MP_mem_default| */
16006 if ( n+b-a+1+mem_ext_length>file_name_size )
16007 b=a+file_name_size-n-1-mem_ext_length;
16009 for (j=0;j<n;j++) {
16010 append_to_name(xord((int)mp->MP_mem_default[j]));
16012 for (j=a;j<b;j++) {
16013 append_to_name(mp->buffer[j]);
16015 for (j=mem_default_length-mem_ext_length;
16016 j<mem_default_length;j++) {
16017 append_to_name(xord((int)mp->MP_mem_default[j]));
16019 mp->name_of_file[k]=0;
16023 @ Here is the only place we use |pack_buffered_name|. This part of the program
16024 becomes active when a ``virgin'' \MP\ is trying to get going, just after
16025 the preliminary initialization, or when the user is substituting another
16026 mem file by typing `\.\&' after the initial `\.{**}' prompt. The buffer
16027 contains the first line of input in |buffer[loc..(last-1)]|, where
16028 |loc<last| and |buffer[loc]<>" "|.
16031 boolean mp_open_mem_file (MP mp) ;
16034 boolean mp_open_mem_file (MP mp) {
16035 int j; /* the first space after the file name */
16036 if (mp->mem_name!=NULL) {
16037 mp->mem_file = (mp->open_file)(mp,mp->mem_name, "r", mp_filetype_memfile);
16038 if ( mp->mem_file ) return true;
16041 if ( mp->buffer[loc]=='&' ) {
16042 incr(loc); j=loc; mp->buffer[mp->last]=' ';
16043 while ( mp->buffer[j]!=' ' ) incr(j);
16044 mp_pack_buffered_name(mp, 0,loc,j); /* try first without the system file area */
16045 if ( mp_w_open_in(mp, &mp->mem_file) ) goto FOUND;
16047 wterm_ln("Sorry, I can\'t find that mem file; will try PLAIN.");
16048 @.Sorry, I can't find...@>
16051 /* now pull out all the stops: try for the system \.{plain} file */
16052 mp_pack_buffered_name(mp, mem_default_length-mem_ext_length,0,0);
16053 if ( ! mp_w_open_in(mp, &mp->mem_file) ) {
16055 wterm_ln("I can\'t find the PLAIN mem file!\n");
16056 @.I can't find PLAIN...@>
16061 loc=j; return true;
16064 @ Operating systems often make it possible to determine the exact name (and
16065 possible version number) of a file that has been opened. The following routine,
16066 which simply makes a \MP\ string from the value of |name_of_file|, should
16067 ideally be changed to deduce the full name of file~|f|, which is the file
16068 most recently opened, if it is possible to do this.
16069 @^system dependencies@>
16072 #define mp_a_make_name_string(A,B) mp_make_name_string(A)
16073 #define mp_b_make_name_string(A,B) mp_make_name_string(A)
16074 #define mp_w_make_name_string(A,B) mp_make_name_string(A)
16077 str_number mp_make_name_string (MP mp) {
16078 int k; /* index into |name_of_file| */
16079 str_room(mp->name_length);
16080 for (k=0;k<mp->name_length;k++) {
16081 append_char(xord((int)mp->name_of_file[k]));
16083 return mp_make_string(mp);
16086 @ Now let's consider the ``driver''
16087 routines by which \MP\ deals with file names
16088 in a system-independent manner. First comes a procedure that looks for a
16089 file name in the input by taking the information from the input buffer.
16090 (We can't use |get_next|, because the conversion to tokens would
16091 destroy necessary information.)
16093 This procedure doesn't allow semicolons or percent signs to be part of
16094 file names, because of other conventions of \MP.
16095 {\sl The {\logos METAFONT\/}book} doesn't
16096 use semicolons or percents immediately after file names, but some users
16097 no doubt will find it natural to do so; therefore system-dependent
16098 changes to allow such characters in file names should probably
16099 be made with reluctance, and only when an entire file name that
16100 includes special characters is ``quoted'' somehow.
16101 @^system dependencies@>
16103 @c void mp_scan_file_name (MP mp) {
16105 while ( mp->buffer[loc]==' ' ) incr(loc);
16107 if ( (mp->buffer[loc]==';')||(mp->buffer[loc]=='%') ) break;
16108 if ( ! mp_more_name(mp, mp->buffer[loc]) ) break;
16114 @ Here is another version that takes its input from a string.
16116 @<Declare subroutines for parsing file names@>=
16117 void mp_str_scan_file (MP mp, str_number s) {
16118 pool_pointer p,q; /* current position and stopping point */
16120 p=mp->str_start[s]; q=str_stop(s);
16122 if ( ! mp_more_name(mp, mp->str_pool[p]) ) break;
16128 @ And one that reads from a |char*|.
16130 @<Declare subroutines for parsing file names@>=
16131 void mp_ptr_scan_file (MP mp, char *s) {
16132 char *p, *q; /* current position and stopping point */
16134 p=s; q=p+strlen(s);
16136 if ( ! mp_more_name(mp, *p)) break;
16143 @ The global variable |job_name| contains the file name that was first
16144 \&{input} by the user. This name is extended by `\.{.log}' and `\.{ps}' and
16145 `\.{.mem}' and `\.{.tfm}' in order to make the names of \MP's output files.
16148 boolean log_opened; /* has the transcript file been opened? */
16149 char *log_name; /* full name of the log file */
16151 @ @<Option variables@>=
16152 char *job_name; /* principal file name */
16154 @ Initially |job_name=NULL|; it becomes nonzero as soon as the true name is known.
16155 We have |job_name=NULL| if and only if the `\.{log}' file has not been opened,
16156 except of course for a short time just after |job_name| has become nonzero.
16158 @<Allocate or ...@>=
16159 mp->job_name=mp_xstrdup(mp, opt->job_name);
16160 mp->log_opened=false;
16162 @ @<Dealloc variables@>=
16163 xfree(mp->job_name);
16165 @ Here is a routine that manufactures the output file names, assuming that
16166 |job_name<>0|. It ignores and changes the current settings of |cur_area|
16169 @d pack_cur_name mp_pack_file_name(mp, mp->cur_name,mp->cur_area,mp->cur_ext)
16172 void mp_pack_job_name (MP mp, const char *s) ;
16175 void mp_pack_job_name (MP mp, const char *s) { /* |s = ".log"|, |".mem"|, |".ps"|, or .\\{nnn} */
16176 xfree(mp->cur_name); mp->cur_name=xstrdup(mp->job_name);
16177 xfree(mp->cur_area); mp->cur_area=xstrdup("");
16178 xfree(mp->cur_ext); mp->cur_ext=xstrdup(s);
16182 @ If some trouble arises when \MP\ tries to open a file, the following
16183 routine calls upon the user to supply another file name. Parameter~|s|
16184 is used in the error message to identify the type of file; parameter~|e|
16185 is the default extension if none is given. Upon exit from the routine,
16186 variables |cur_name|, |cur_area|, |cur_ext|, and |name_of_file| are
16187 ready for another attempt at file opening.
16190 void mp_prompt_file_name (MP mp, const char * s, const char * e) ;
16192 @ @c void mp_prompt_file_name (MP mp, const char * s, const char * e) {
16193 size_t k; /* index into |buffer| */
16194 char * saved_cur_name;
16195 if ( mp->interaction==mp_scroll_mode )
16197 if (strcmp(s,"input file name")==0) {
16198 print_err("I can\'t find file `");
16199 @.I can't find file x@>
16201 print_err("I can\'t write on file `");
16203 @.I can't write on file x@>
16204 mp_print_file_name(mp, mp->cur_name,mp->cur_area,mp->cur_ext);
16205 mp_print(mp, "'.");
16206 if (strcmp(e,"")==0)
16207 mp_show_context(mp);
16208 mp_print_nl(mp, "Please type another "); mp_print(mp, s);
16210 if ( mp->interaction<mp_scroll_mode )
16211 mp_fatal_error(mp, "*** (job aborted, file error in nonstop mode)");
16212 @.job aborted, file error...@>
16213 saved_cur_name = xstrdup(mp->cur_name);
16214 clear_terminal; prompt_input(": "); @<Scan file name in the buffer@>;
16215 if (strcmp(mp->cur_ext,"")==0)
16216 mp->cur_ext=xstrdup(e);
16217 if (strlen(mp->cur_name)==0) {
16218 mp->cur_name=saved_cur_name;
16220 xfree(saved_cur_name);
16225 @ @<Scan file name in the buffer@>=
16227 mp_begin_name(mp); k=mp->first;
16228 while ( (mp->buffer[k]==' ')&&(k<mp->last) ) incr(k);
16230 if ( k==mp->last ) break;
16231 if ( ! mp_more_name(mp, mp->buffer[k]) ) break;
16237 @ The |open_log_file| routine is used to open the transcript file and to help
16238 it catch up to what has previously been printed on the terminal.
16240 @c void mp_open_log_file (MP mp) {
16241 int old_setting; /* previous |selector| setting */
16242 int k; /* index into |months| and |buffer| */
16243 int l; /* end of first input line */
16244 integer m; /* the current month */
16245 const char *months="JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC";
16246 /* abbreviations of month names */
16247 old_setting=mp->selector;
16248 if ( mp->job_name==NULL ) {
16249 mp->job_name=xstrdup("mpout");
16251 mp_pack_job_name(mp,".log");
16252 while ( ! mp_a_open_out(mp, &mp->log_file, mp_filetype_log) ) {
16253 @<Try to get a different log file name@>;
16255 mp->log_name=xstrdup(mp->name_of_file);
16256 mp->selector=log_only; mp->log_opened=true;
16257 @<Print the banner line, including the date and time@>;
16258 mp->input_stack[mp->input_ptr]=mp->cur_input;
16259 /* make sure bottom level is in memory */
16261 if (!mp->noninteractive) {
16262 mp_print_nl(mp, "**");
16263 l=mp->input_stack[0].limit_field-1; /* last position of first line */
16264 for (k=0;k<=l;k++) mp_print_str(mp, mp->buffer[k]);
16265 mp_print_ln(mp); /* now the transcript file contains the first line of input */
16267 mp->selector=old_setting+2; /* |log_only| or |term_and_log| */
16270 @ @<Dealloc variables@>=
16271 xfree(mp->log_name);
16273 @ Sometimes |open_log_file| is called at awkward moments when \MP\ is
16274 unable to print error messages or even to |show_context|.
16275 The |prompt_file_name| routine can result in a |fatal_error|, but the |error|
16276 routine will not be invoked because |log_opened| will be false.
16278 The normal idea of |mp_batch_mode| is that nothing at all should be written
16279 on the terminal. However, in the unusual case that
16280 no log file could be opened, we make an exception and allow
16281 an explanatory message to be seen.
16283 Incidentally, the program always refers to the log file as a `\.{transcript
16284 file}', because some systems cannot use the extension `\.{.log}' for
16287 @<Try to get a different log file name@>=
16289 mp->selector=term_only;
16290 mp_prompt_file_name(mp, "transcript file name",".log");
16293 @ @<Print the banner...@>=
16296 mp_print(mp, mp->mem_ident); mp_print(mp, " ");
16297 mp_print_int(mp, mp_round_unscaled(mp, mp->internal[mp_day]));
16298 mp_print_char(mp, ' ');
16299 m=mp_round_unscaled(mp, mp->internal[mp_month]);
16300 for (k=3*m-3;k<3*m;k++) { wlog_chr(months[k]); }
16301 mp_print_char(mp, ' ');
16302 mp_print_int(mp, mp_round_unscaled(mp, mp->internal[mp_year]));
16303 mp_print_char(mp, ' ');
16304 m=mp_round_unscaled(mp, mp->internal[mp_time]);
16305 mp_print_dd(mp, m / 60); mp_print_char(mp, ':'); mp_print_dd(mp, m % 60);
16308 @ The |try_extension| function tries to open an input file determined by
16309 |cur_name|, |cur_area|, and the argument |ext|. It returns |false| if it
16310 can't find the file in |cur_area| or the appropriate system area.
16312 @c boolean mp_try_extension (MP mp, const char *ext) {
16313 mp_pack_file_name(mp, mp->cur_name,mp->cur_area, ext);
16314 in_name=xstrdup(mp->cur_name);
16315 in_area=xstrdup(mp->cur_area);
16316 if ( mp_a_open_in(mp, &cur_file, mp_filetype_program) ) {
16319 mp_pack_file_name(mp, mp->cur_name,NULL,ext);
16320 return mp_a_open_in(mp, &cur_file, mp_filetype_program);
16324 @ Let's turn now to the procedure that is used to initiate file reading
16325 when an `\.{input}' command is being processed.
16327 @c void mp_start_input (MP mp) { /* \MP\ will \.{input} something */
16328 char *fname = NULL;
16329 @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>;
16331 mp_begin_file_reading(mp); /* set up |cur_file| and new level of input */
16332 if ( strlen(mp->cur_ext)==0 ) {
16333 if ( mp_try_extension(mp, ".mp") ) break;
16334 else if ( mp_try_extension(mp, "") ) break;
16335 else if ( mp_try_extension(mp, ".mf") ) break;
16336 /* |else do_nothing; | */
16337 } else if ( mp_try_extension(mp, mp->cur_ext) ) {
16340 mp_end_file_reading(mp); /* remove the level that didn't work */
16341 mp_prompt_file_name(mp, "input file name","");
16343 name=mp_a_make_name_string(mp, cur_file);
16344 fname = xstrdup(mp->name_of_file);
16345 if ( mp->job_name==NULL ) {
16346 mp->job_name=xstrdup(mp->cur_name);
16347 mp_open_log_file(mp);
16348 } /* |open_log_file| doesn't |show_context|, so |limit|
16349 and |loc| needn't be set to meaningful values yet */
16350 if ( ((int)mp->term_offset+(int)strlen(fname)) > (mp->max_print_line-2)) mp_print_ln(mp);
16351 else if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_char(mp, ' ');
16352 mp_print_char(mp, '('); incr(mp->open_parens); mp_print(mp, fname);
16355 @<Flush |name| and replace it with |cur_name| if it won't be needed@>;
16356 @<Read the first line of the new file@>;
16359 @ This code should be omitted if |a_make_name_string| returns something other
16360 than just a copy of its argument and the full file name is needed for opening
16361 \.{MPX} files or implementing the switch-to-editor option.
16362 @^system dependencies@>
16364 @<Flush |name| and replace it with |cur_name| if it won't be needed@>=
16365 mp_flush_string(mp, name); name=rts(mp->cur_name); xfree(mp->cur_name)
16367 @ If the file is empty, it is considered to contain a single blank line,
16368 so there is no need to test the return value.
16370 @<Read the first line...@>=
16373 (void)mp_input_ln(mp, cur_file );
16374 mp_firm_up_the_line(mp);
16375 mp->buffer[limit]='%'; mp->first=limit+1; loc=start;
16378 @ @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>=
16379 while ( token_state &&(loc==null) ) mp_end_token_list(mp);
16380 if ( token_state ) {
16381 print_err("File names can't appear within macros");
16382 @.File names can't...@>
16383 help3("Sorry...I've converted what follows to tokens,")
16384 ("possibly garbaging the name you gave.")
16385 ("Please delete the tokens and insert the name again.");
16388 if ( file_state ) {
16389 mp_scan_file_name(mp);
16391 xfree(mp->cur_name); mp->cur_name=xstrdup("");
16392 xfree(mp->cur_ext); mp->cur_ext =xstrdup("");
16393 xfree(mp->cur_area); mp->cur_area=xstrdup("");
16396 @ The following simple routine starts reading the \.{MPX} file associated
16397 with the current input file.
16399 @c void mp_start_mpx_input (MP mp) {
16400 char *origname = NULL; /* a copy of nameoffile */
16401 mp_pack_file_name(mp, in_name, in_area, ".mpx");
16402 @<Try to make sure |name_of_file| refers to a valid \.{MPX} file and
16403 |goto not_found| if there is a problem@>;
16404 mp_begin_file_reading(mp);
16405 if ( ! mp_a_open_in(mp, &cur_file, mp_filetype_program) ) {
16406 mp_end_file_reading(mp);
16409 name=mp_a_make_name_string(mp, cur_file);
16410 mp->mpx_name[index]=name; add_str_ref(name);
16411 @<Read the first line of the new file@>;
16415 @<Explain that the \.{MPX} file can't be read and |succumb|@>;
16419 @ This should ideally be changed to do whatever is necessary to create the
16420 \.{MPX} file given by |name_of_file| if it does not exist or if it is out
16421 of date. This requires invoking \.{MPtoTeX} on the |origname| and passing
16422 the results through \TeX\ and \.{DVItoMP}. (It is possible to use a
16423 completely different typesetting program if suitable postprocessor is
16424 available to perform the function of \.{DVItoMP}.)
16425 @^system dependencies@>
16427 @ @<Exported types@>=
16428 typedef int (*mp_run_make_mpx_command)(MP mp, char *origname, char *mtxname);
16430 @ @<Option variables@>=
16431 mp_run_make_mpx_command run_make_mpx;
16433 @ @<Allocate or initialize ...@>=
16434 set_callback_option(run_make_mpx);
16436 @ @<Internal library declarations@>=
16437 int mp_run_make_mpx (MP mp, char *origname, char *mtxname);
16439 @ The default does nothing.
16441 int mp_run_make_mpx (MP mp, char *origname, char *mtxname) {
16448 @ @<Try to make sure |name_of_file| refers to a valid \.{MPX} file and
16449 |goto not_found| if there is a problem@>=
16450 origname = mp_xstrdup(mp,mp->name_of_file);
16451 *(origname+strlen(origname)-1)=0; /* drop the x */
16452 if (!(mp->run_make_mpx)(mp, origname, mp->name_of_file))
16455 @ @<Explain that the \.{MPX} file can't be read and |succumb|@>=
16456 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
16457 mp_print_nl(mp, ">> ");
16458 mp_print(mp, origname);
16459 mp_print_nl(mp, ">> ");
16460 mp_print(mp, mp->name_of_file);
16461 mp_print_nl(mp, "! Unable to make mpx file");
16462 help4("The two files given above are one of your source files")
16463 ("and an auxiliary file I need to read to find out what your")
16464 ("btex..etex blocks mean. If you don't know why I had trouble,")
16465 ("try running it manually through MPtoTeX, TeX, and DVItoMP");
16468 @ The last file-opening commands are for files accessed via the \&{readfrom}
16469 @:read_from_}{\&{readfrom} primitive@>
16470 operator and the \&{write} command. Such files are stored in separate arrays.
16471 @:write_}{\&{write} primitive@>
16473 @<Types in the outer block@>=
16474 typedef unsigned int readf_index; /* |0..max_read_files| */
16475 typedef unsigned int write_index; /* |0..max_write_files| */
16478 readf_index max_read_files; /* maximum number of simultaneously open \&{readfrom} files */
16479 void ** rd_file; /* \&{readfrom} files */
16480 char ** rd_fname; /* corresponding file name or 0 if file not open */
16481 readf_index read_files; /* number of valid entries in the above arrays */
16482 write_index max_write_files; /* maximum number of simultaneously open \&{write} */
16483 void ** wr_file; /* \&{write} files */
16484 char ** wr_fname; /* corresponding file name or 0 if file not open */
16485 write_index write_files; /* number of valid entries in the above arrays */
16487 @ @<Allocate or initialize ...@>=
16488 mp->max_read_files=8;
16489 mp->rd_file = xmalloc((mp->max_read_files+1),sizeof(void *));
16490 mp->rd_fname = xmalloc((mp->max_read_files+1),sizeof(char *));
16491 memset(mp->rd_fname, 0, sizeof(char *)*(mp->max_read_files+1));
16493 mp->max_write_files=8;
16494 mp->wr_file = xmalloc((mp->max_write_files+1),sizeof(void *));
16495 mp->wr_fname = xmalloc((mp->max_write_files+1),sizeof(char *));
16496 memset(mp->wr_fname, 0, sizeof(char *)*(mp->max_write_files+1));
16500 @ This routine starts reading the file named by string~|s| without setting
16501 |loc|, |limit|, or |name|. It returns |false| if the file is empty or cannot
16502 be opened. Otherwise it updates |rd_file[n]| and |rd_fname[n]|.
16504 @c boolean mp_start_read_input (MP mp,char *s, readf_index n) {
16505 mp_ptr_scan_file(mp, s);
16507 mp_begin_file_reading(mp);
16508 if ( ! mp_a_open_in(mp, &mp->rd_file[n], (mp_filetype_text+n)) )
16510 if ( ! mp_input_ln(mp, mp->rd_file[n] ) ) {
16511 (mp->close_file)(mp,mp->rd_file[n]);
16514 mp->rd_fname[n]=xstrdup(mp->name_of_file);
16517 mp_end_file_reading(mp);
16521 @ Open |wr_file[n]| using file name~|s| and update |wr_fname[n]|.
16524 void mp_open_write_file (MP mp, char *s, readf_index n) ;
16526 @ @c void mp_open_write_file (MP mp,char *s, readf_index n) {
16527 mp_ptr_scan_file(mp, s);
16529 while ( ! mp_a_open_out(mp, &mp->wr_file[n], (mp_filetype_text+n)) )
16530 mp_prompt_file_name(mp, "file name for write output","");
16531 mp->wr_fname[n]=xstrdup(mp->name_of_file);
16535 @* \[36] Introduction to the parsing routines.
16536 We come now to the central nervous system that sparks many of \MP's activities.
16537 By evaluating expressions, from their primary constituents to ever larger
16538 subexpressions, \MP\ builds the structures that ultimately define complete
16539 pictures or fonts of type.
16541 Four mutually recursive subroutines are involved in this process: We call them
16542 $$\hbox{|scan_primary|, |scan_secondary|, |scan_tertiary|,
16543 and |scan_expression|.}$$
16545 Each of them is parameterless and begins with the first token to be scanned
16546 already represented in |cur_cmd|, |cur_mod|, and |cur_sym|. After execution,
16547 the value of the primary or secondary or tertiary or expression that was
16548 found will appear in the global variables |cur_type| and |cur_exp|. The
16549 token following the expression will be represented in |cur_cmd|, |cur_mod|,
16552 Technically speaking, the parsing algorithms are ``LL(1),'' more or less;
16553 backup mechanisms have been added in order to provide reasonable error
16557 small_number cur_type; /* the type of the expression just found */
16558 integer cur_exp; /* the value of the expression just found */
16563 @ Many different kinds of expressions are possible, so it is wise to have
16564 precise descriptions of what |cur_type| and |cur_exp| mean in all cases:
16567 |cur_type=mp_vacuous| means that this expression didn't turn out to have a
16568 value at all, because it arose from a \&{begingroup}$\,\ldots\,$\&{endgroup}
16569 construction in which there was no expression before the \&{endgroup}.
16570 In this case |cur_exp| has some irrelevant value.
16573 |cur_type=mp_boolean_type| means that |cur_exp| is either |true_code|
16577 |cur_type=mp_unknown_boolean| means that |cur_exp| points to a capsule
16579 a ring of equivalent booleans whose value has not yet been defined.
16582 |cur_type=mp_string_type| means that |cur_exp| is a string number (i.e., an
16583 integer in the range |0<=cur_exp<str_ptr|). That string's reference count
16584 includes this particular reference.
16587 |cur_type=mp_unknown_string| means that |cur_exp| points to a capsule
16589 a ring of equivalent strings whose value has not yet been defined.
16592 |cur_type=mp_pen_type| means that |cur_exp| points to a node in a pen. Nobody
16593 else points to any of the nodes in this pen. The pen may be polygonal or
16597 |cur_type=mp_unknown_pen| means that |cur_exp| points to a capsule
16599 a ring of equivalent pens whose value has not yet been defined.
16602 |cur_type=mp_path_type| means that |cur_exp| points to a the first node of
16603 a path; nobody else points to this particular path. The control points of
16604 the path will have been chosen.
16607 |cur_type=mp_unknown_path| means that |cur_exp| points to a capsule
16609 a ring of equivalent paths whose value has not yet been defined.
16612 |cur_type=mp_picture_type| means that |cur_exp| points to an edge header node.
16613 There may be other pointers to this particular set of edges. The header node
16614 contains a reference count that includes this particular reference.
16617 |cur_type=mp_unknown_picture| means that |cur_exp| points to a capsule
16619 a ring of equivalent pictures whose value has not yet been defined.
16622 |cur_type=mp_transform_type| means that |cur_exp| points to a |mp_transform_type|
16623 capsule node. The |value| part of this capsule
16624 points to a transform node that contains six numeric values,
16625 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16628 |cur_type=mp_color_type| means that |cur_exp| points to a |color_type|
16629 capsule node. The |value| part of this capsule
16630 points to a color node that contains three numeric values,
16631 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16634 |cur_type=mp_cmykcolor_type| means that |cur_exp| points to a |mp_cmykcolor_type|
16635 capsule node. The |value| part of this capsule
16636 points to a color node that contains four numeric values,
16637 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16640 |cur_type=mp_pair_type| means that |cur_exp| points to a capsule
16641 node whose type is |mp_pair_type|. The |value| part of this capsule
16642 points to a pair node that contains two numeric values,
16643 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16646 |cur_type=mp_known| means that |cur_exp| is a |scaled| value.
16649 |cur_type=mp_dependent| means that |cur_exp| points to a capsule node whose type
16650 is |dependent|. The |dep_list| field in this capsule points to the associated
16654 |cur_type=mp_proto_dependent| means that |cur_exp| points to a |mp_proto_dependent|
16655 capsule node. The |dep_list| field in this capsule
16656 points to the associated dependency list.
16659 |cur_type=independent| means that |cur_exp| points to a capsule node
16660 whose type is |independent|. This somewhat unusual case can arise, for
16661 example, in the expression
16662 `$x+\&{begingroup}\penalty0\,\&{string}\,x; 0\,\&{endgroup}$'.
16665 |cur_type=mp_token_list| means that |cur_exp| points to a linked list of
16668 \smallskip\noindent
16669 The possible settings of |cur_type| have been listed here in increasing
16670 numerical order. Notice that |cur_type| will never be |mp_numeric_type| or
16671 |suffixed_macro| or |mp_unsuffixed_macro|, although variables of those types
16672 are allowed. Conversely, \MP\ has no variables of type |mp_vacuous| or
16675 @ Capsules are two-word nodes that have a similar meaning
16676 to |cur_type| and |cur_exp|. Such nodes have |name_type=capsule|,
16677 and their |type| field is one of the possibilities for |cur_type| listed above.
16678 Also |link<=void| in capsules that aren't part of a token list.
16680 The |value| field of a capsule is, in most cases, the value that
16681 corresponds to its |type|, as |cur_exp| corresponds to |cur_type|.
16682 However, when |cur_exp| would point to a capsule,
16683 no extra layer of indirection is present; the |value|
16684 field is what would have been called |value(cur_exp)| if it had not been
16685 encapsulated. Furthermore, if the type is |dependent| or
16686 |mp_proto_dependent|, the |value| field of a capsule is replaced by
16687 |dep_list| and |prev_dep| fields, since dependency lists in capsules are
16688 always part of the general |dep_list| structure.
16690 The |get_x_next| routine is careful not to change the values of |cur_type|
16691 and |cur_exp| when it gets an expanded token. However, |get_x_next| might
16692 call a macro, which might parse an expression, which might execute lots of
16693 commands in a group; hence it's possible that |cur_type| might change
16694 from, say, |mp_unknown_boolean| to |mp_boolean_type|, or from |dependent| to
16695 |known| or |independent|, during the time |get_x_next| is called. The
16696 programs below are careful to stash sensitive intermediate results in
16697 capsules, so that \MP's generality doesn't cause trouble.
16699 Here's a procedure that illustrates these conventions. It takes
16700 the contents of $(|cur_type|\kern-.3pt,|cur_exp|\kern-.3pt)$
16701 and stashes them away in a
16702 capsule. It is not used when |cur_type=mp_token_list|.
16703 After the operation, |cur_type=mp_vacuous|; hence there is no need to
16704 copy path lists or to update reference counts, etc.
16706 The special link |mp_void| is put on the capsule returned by
16707 |stash_cur_exp|, because this procedure is used to store macro parameters
16708 that must be easily distinguishable from token lists.
16710 @<Declare the stashing/unstashing routines@>=
16711 pointer mp_stash_cur_exp (MP mp) {
16712 pointer p; /* the capsule that will be returned */
16713 switch (mp->cur_type) {
16714 case unknown_types:
16715 case mp_transform_type:
16716 case mp_color_type:
16719 case mp_proto_dependent:
16720 case mp_independent:
16721 case mp_cmykcolor_type:
16725 p=mp_get_node(mp, value_node_size); name_type(p)=mp_capsule;
16726 type(p)=mp->cur_type; value(p)=mp->cur_exp;
16729 mp->cur_type=mp_vacuous; link(p)=mp_void;
16733 @ The inverse of |stash_cur_exp| is the following procedure, which
16734 deletes an unnecessary capsule and puts its contents into |cur_type|
16737 The program steps of \MP\ can be divided into two categories: those in
16738 which |cur_type| and |cur_exp| are ``alive'' and those in which they are
16739 ``dead,'' in the sense that |cur_type| and |cur_exp| contain relevant
16740 information or not. It's important not to ignore them when they're alive,
16741 and it's important not to pay attention to them when they're dead.
16743 There's also an intermediate category: If |cur_type=mp_vacuous|, then
16744 |cur_exp| is irrelevant, hence we can proceed without caring if |cur_type|
16745 and |cur_exp| are alive or dead. In such cases we say that |cur_type|
16746 and |cur_exp| are {\sl dormant}. It is permissible to call |get_x_next|
16747 only when they are alive or dormant.
16749 The \\{stash} procedure above assumes that |cur_type| and |cur_exp|
16750 are alive or dormant. The \\{unstash} procedure assumes that they are
16751 dead or dormant; it resuscitates them.
16753 @<Declare the stashing/unstashing...@>=
16754 void mp_unstash_cur_exp (MP mp,pointer p) ;
16757 void mp_unstash_cur_exp (MP mp,pointer p) {
16758 mp->cur_type=type(p);
16759 switch (mp->cur_type) {
16760 case unknown_types:
16761 case mp_transform_type:
16762 case mp_color_type:
16765 case mp_proto_dependent:
16766 case mp_independent:
16767 case mp_cmykcolor_type:
16771 mp->cur_exp=value(p);
16772 mp_free_node(mp, p,value_node_size);
16777 @ The following procedure prints the values of expressions in an
16778 abbreviated format. If its first parameter |p| is null, the value of
16779 |(cur_type,cur_exp)| is displayed; otherwise |p| should be a capsule
16780 containing the desired value. The second parameter controls the amount of
16781 output. If it is~0, dependency lists will be abbreviated to
16782 `\.{linearform}' unless they consist of a single term. If it is greater
16783 than~1, complicated structures (pens, pictures, and paths) will be displayed
16787 @<Declare subroutines for printing expressions@>=
16788 @<Declare the procedure called |print_dp|@>
16789 @<Declare the stashing/unstashing routines@>
16790 void mp_print_exp (MP mp,pointer p, small_number verbosity) {
16791 boolean restore_cur_exp; /* should |cur_exp| be restored? */
16792 small_number t; /* the type of the expression */
16793 pointer q; /* a big node being displayed */
16794 integer v=0; /* the value of the expression */
16796 restore_cur_exp=false;
16798 p=mp_stash_cur_exp(mp); restore_cur_exp=true;
16801 if ( t<mp_dependent ) v=value(p); else if ( t<mp_independent ) v=dep_list(p);
16802 @<Print an abbreviated value of |v| with format depending on |t|@>;
16803 if ( restore_cur_exp ) mp_unstash_cur_exp(mp, p);
16806 @ @<Print an abbreviated value of |v| with format depending on |t|@>=
16808 case mp_vacuous:mp_print(mp, "mp_vacuous"); break;
16809 case mp_boolean_type:
16810 if ( v==true_code ) mp_print(mp, "true"); else mp_print(mp, "false");
16812 case unknown_types: case mp_numeric_type:
16813 @<Display a variable that's been declared but not defined@>;
16815 case mp_string_type:
16816 mp_print_char(mp, '"'); mp_print_str(mp, v); mp_print_char(mp, '"');
16818 case mp_pen_type: case mp_path_type: case mp_picture_type:
16819 @<Display a complex type@>;
16821 case mp_transform_type: case mp_color_type: case mp_pair_type: case mp_cmykcolor_type:
16822 if ( v==null ) mp_print_type(mp, t);
16823 else @<Display a big node@>;
16825 case mp_known:mp_print_scaled(mp, v); break;
16826 case mp_dependent: case mp_proto_dependent:
16827 mp_print_dp(mp, t,v,verbosity);
16829 case mp_independent:mp_print_variable_name(mp, p); break;
16830 default: mp_confusion(mp, "exp"); break;
16831 @:this can't happen exp}{\quad exp@>
16834 @ @<Display a big node@>=
16836 mp_print_char(mp, '('); q=v+mp->big_node_size[t];
16838 if ( type(v)==mp_known ) mp_print_scaled(mp, value(v));
16839 else if ( type(v)==mp_independent ) mp_print_variable_name(mp, v);
16840 else mp_print_dp(mp, type(v),dep_list(v),verbosity);
16842 if ( v!=q ) mp_print_char(mp, ',');
16844 mp_print_char(mp, ')');
16847 @ Values of type \&{picture}, \&{path}, and \&{pen} are displayed verbosely
16848 in the log file only, unless the user has given a positive value to
16851 @<Display a complex type@>=
16852 if ( verbosity<=1 ) {
16853 mp_print_type(mp, t);
16855 if ( mp->selector==term_and_log )
16856 if ( mp->internal[mp_tracing_online]<=0 ) {
16857 mp->selector=term_only;
16858 mp_print_type(mp, t); mp_print(mp, " (see the transcript file)");
16859 mp->selector=term_and_log;
16862 case mp_pen_type:mp_print_pen(mp, v,"",false); break;
16863 case mp_path_type:mp_print_path(mp, v,"",false); break;
16864 case mp_picture_type:mp_print_edges(mp, v,"",false); break;
16865 } /* there are no other cases */
16868 @ @<Declare the procedure called |print_dp|@>=
16869 void mp_print_dp (MP mp,small_number t, pointer p,
16870 small_number verbosity) {
16871 pointer q; /* the node following |p| */
16873 if ( (info(q)==null) || (verbosity>0) ) mp_print_dependency(mp, p,t);
16874 else mp_print(mp, "linearform");
16877 @ The displayed name of a variable in a ring will not be a capsule unless
16878 the ring consists entirely of capsules.
16880 @<Display a variable that's been declared but not defined@>=
16881 { mp_print_type(mp, t);
16883 { mp_print_char(mp, ' ');
16884 while ( (name_type(v)==mp_capsule) && (v!=p) ) v=value(v);
16885 mp_print_variable_name(mp, v);
16889 @ When errors are detected during parsing, it is often helpful to
16890 display an expression just above the error message, using |exp_err|
16891 or |disp_err| instead of |print_err|.
16893 @d exp_err(A) mp_disp_err(mp, null,(A)) /* displays the current expression */
16895 @<Declare subroutines for printing expressions@>=
16896 void mp_disp_err (MP mp,pointer p, const char *s) {
16897 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
16898 mp_print_nl(mp, ">> ");
16900 mp_print_exp(mp, p,1); /* ``medium verbose'' printing of the expression */
16902 mp_print_nl(mp, "! "); mp_print(mp, s);
16907 @ If |cur_type| and |cur_exp| contain relevant information that should
16908 be recycled, we will use the following procedure, which changes |cur_type|
16909 to |known| and stores a given value in |cur_exp|. We can think of |cur_type|
16910 and |cur_exp| as either alive or dormant after this has been done,
16911 because |cur_exp| will not contain a pointer value.
16913 @ @c void mp_flush_cur_exp (MP mp,scaled v) {
16914 switch (mp->cur_type) {
16915 case unknown_types: case mp_transform_type: case mp_color_type: case mp_pair_type:
16916 case mp_dependent: case mp_proto_dependent: case mp_independent: case mp_cmykcolor_type:
16917 mp_recycle_value(mp, mp->cur_exp);
16918 mp_free_node(mp, mp->cur_exp,value_node_size);
16920 case mp_string_type:
16921 delete_str_ref(mp->cur_exp); break;
16922 case mp_pen_type: case mp_path_type:
16923 mp_toss_knot_list(mp, mp->cur_exp); break;
16924 case mp_picture_type:
16925 delete_edge_ref(mp->cur_exp); break;
16929 mp->cur_type=mp_known; mp->cur_exp=v;
16932 @ There's a much more general procedure that is capable of releasing
16933 the storage associated with any two-word value packet.
16935 @<Declare the recycling subroutines@>=
16936 void mp_recycle_value (MP mp,pointer p) ;
16938 @ @c void mp_recycle_value (MP mp,pointer p) {
16939 small_number t; /* a type code */
16940 integer vv; /* another value */
16941 pointer q,r,s,pp; /* link manipulation registers */
16942 integer v=0; /* a value */
16944 if ( t<mp_dependent ) v=value(p);
16946 case undefined: case mp_vacuous: case mp_boolean_type: case mp_known:
16947 case mp_numeric_type:
16949 case unknown_types:
16950 mp_ring_delete(mp, p); break;
16951 case mp_string_type:
16952 delete_str_ref(v); break;
16953 case mp_path_type: case mp_pen_type:
16954 mp_toss_knot_list(mp, v); break;
16955 case mp_picture_type:
16956 delete_edge_ref(v); break;
16957 case mp_cmykcolor_type: case mp_pair_type: case mp_color_type:
16958 case mp_transform_type:
16959 @<Recycle a big node@>; break;
16960 case mp_dependent: case mp_proto_dependent:
16961 @<Recycle a dependency list@>; break;
16962 case mp_independent:
16963 @<Recycle an independent variable@>; break;
16964 case mp_token_list: case mp_structured:
16965 mp_confusion(mp, "recycle"); break;
16966 @:this can't happen recycle}{\quad recycle@>
16967 case mp_unsuffixed_macro: case mp_suffixed_macro:
16968 mp_delete_mac_ref(mp, value(p)); break;
16969 } /* there are no other cases */
16973 @ @<Recycle a big node@>=
16975 q=v+mp->big_node_size[t];
16977 q=q-2; mp_recycle_value(mp, q);
16979 mp_free_node(mp, v,mp->big_node_size[t]);
16982 @ @<Recycle a dependency list@>=
16985 while ( info(q)!=null ) q=link(q);
16986 link(prev_dep(p))=link(q);
16987 prev_dep(link(q))=prev_dep(p);
16988 link(q)=null; mp_flush_node_list(mp, dep_list(p));
16991 @ When an independent variable disappears, it simply fades away, unless
16992 something depends on it. In the latter case, a dependent variable whose
16993 coefficient of dependence is maximal will take its place.
16994 The relevant algorithm is due to Ignacio~A. Zabala, who implemented it
16995 as part of his Ph.D. thesis (Stanford University, December 1982).
16996 @^Zabala Salelles, Ignacio Andr\'es@>
16998 For example, suppose that variable $x$ is being recycled, and that the
16999 only variables depending on~$x$ are $y=2x+a$ and $z=x+b$. In this case
17000 we want to make $y$ independent and $z=.5y-.5a+b$; no other variables
17001 will depend on~$y$. If $\\{tracingequations}>0$ in this situation,
17002 we will print `\.{\#\#\# -2x=-y+a}'.
17004 There's a slight complication, however: An independent variable $x$
17005 can occur both in dependency lists and in proto-dependency lists.
17006 This makes it necessary to be careful when deciding which coefficient
17009 Furthermore, this complication is not so slight when
17010 a proto-dependent variable is chosen to become independent. For example,
17011 suppose that $y=2x+100a$ is proto-dependent while $z=x+b$ is dependent;
17012 then we must change $z=.5y-50a+b$ to a proto-dependency, because of the
17013 large coefficient `50'.
17015 In order to deal with these complications without wasting too much time,
17016 we shall link together the occurrences of~$x$ among all the linear
17017 dependencies, maintaining separate lists for the dependent and
17018 proto-dependent cases.
17020 @<Recycle an independent variable@>=
17022 mp->max_c[mp_dependent]=0; mp->max_c[mp_proto_dependent]=0;
17023 mp->max_link[mp_dependent]=null; mp->max_link[mp_proto_dependent]=null;
17025 while ( q!=dep_head ) {
17026 s=value_loc(q); /* now |link(s)=dep_list(q)| */
17029 if ( info(r)==null ) break;
17030 if ( info(r)!=p ) {
17033 t=type(q); link(s)=link(r); info(r)=q;
17034 if ( abs(value(r))>mp->max_c[t] ) {
17035 @<Record a new maximum coefficient of type |t|@>;
17037 link(r)=mp->max_link[t]; mp->max_link[t]=r;
17043 if ( (mp->max_c[mp_dependent]>0)||(mp->max_c[mp_proto_dependent]>0) ) {
17044 @<Choose a dependent variable to take the place of the disappearing
17045 independent variable, and change all remaining dependencies
17050 @ The code for independency removal makes use of three two-word arrays.
17053 integer max_c[mp_proto_dependent+1]; /* max coefficient magnitude */
17054 pointer max_ptr[mp_proto_dependent+1]; /* where |p| occurs with |max_c| */
17055 pointer max_link[mp_proto_dependent+1]; /* other occurrences of |p| */
17057 @ @<Record a new maximum coefficient...@>=
17059 if ( mp->max_c[t]>0 ) {
17060 link(mp->max_ptr[t])=mp->max_link[t]; mp->max_link[t]=mp->max_ptr[t];
17062 mp->max_c[t]=abs(value(r)); mp->max_ptr[t]=r;
17065 @ @<Choose a dependent...@>=
17067 if ( (mp->max_c[mp_dependent] / 010000) >= mp->max_c[mp_proto_dependent] )
17070 t=mp_proto_dependent;
17071 @<Determine the dependency list |s| to substitute for the independent
17073 t=mp_dependent+mp_proto_dependent-t; /* complement |t| */
17074 if ( mp->max_c[t]>0 ) { /* we need to pick up an unchosen dependency */
17075 link(mp->max_ptr[t])=mp->max_link[t]; mp->max_link[t]=mp->max_ptr[t];
17077 if ( t!=mp_dependent ) { @<Substitute new dependencies in place of |p|@>; }
17078 else { @<Substitute new proto-dependencies in place of |p|@>;}
17079 mp_flush_node_list(mp, s);
17080 if ( mp->fix_needed ) mp_fix_dependencies(mp);
17084 @ Let |s=max_ptr[t]|. At this point we have $|value|(s)=\pm|max_c|[t]$,
17085 and |info(s)| points to the dependent variable~|pp| of type~|t| from
17086 whose dependency list we have removed node~|s|. We must reinsert
17087 node~|s| into the dependency list, with coefficient $-1.0$, and with
17088 |pp| as the new independent variable. Since |pp| will have a larger serial
17089 number than any other variable, we can put node |s| at the head of the
17092 @<Determine the dep...@>=
17093 s=mp->max_ptr[t]; pp=info(s); v=value(s);
17094 if ( t==mp_dependent ) value(s)=-fraction_one; else value(s)=-unity;
17095 r=dep_list(pp); link(s)=r;
17096 while ( info(r)!=null ) r=link(r);
17097 q=link(r); link(r)=null;
17098 prev_dep(q)=prev_dep(pp); link(prev_dep(pp))=q;
17100 if ( mp->cur_exp==pp ) if ( mp->cur_type==t ) mp->cur_type=mp_independent;
17101 if ( mp->internal[mp_tracing_equations]>0 ) {
17102 @<Show the transformed dependency@>;
17105 @ Now $(-v)$ times the formerly independent variable~|p| is being replaced
17106 by the dependency list~|s|.
17108 @<Show the transformed...@>=
17109 if ( mp_interesting(mp, p) ) {
17110 mp_begin_diagnostic(mp); mp_print_nl(mp, "### ");
17111 @:]]]\#\#\#_}{\.{\#\#\#}@>
17112 if ( v>0 ) mp_print_char(mp, '-');
17113 if ( t==mp_dependent ) vv=mp_round_fraction(mp, mp->max_c[mp_dependent]);
17114 else vv=mp->max_c[mp_proto_dependent];
17115 if ( vv!=unity ) mp_print_scaled(mp, vv);
17116 mp_print_variable_name(mp, p);
17117 while ( value(p) % s_scale>0 ) {
17118 mp_print(mp, "*4"); value(p)=value(p)-2;
17120 if ( t==mp_dependent ) mp_print_char(mp, '='); else mp_print(mp, " = ");
17121 mp_print_dependency(mp, s,t);
17122 mp_end_diagnostic(mp, false);
17125 @ Finally, there are dependent and proto-dependent variables whose
17126 dependency lists must be brought up to date.
17128 @<Substitute new dependencies...@>=
17129 for (t=mp_dependent;t<=mp_proto_dependent;t++){
17131 while ( r!=null ) {
17133 dep_list(q)=mp_p_plus_fq(mp, dep_list(q),
17134 mp_make_fraction(mp, value(r),-v),s,t,mp_dependent);
17135 if ( dep_list(q)==mp->dep_final ) mp_make_known(mp, q,mp->dep_final);
17136 q=r; r=link(r); mp_free_node(mp, q,dep_node_size);
17140 @ @<Substitute new proto...@>=
17141 for (t=mp_dependent;t<=mp_proto_dependent;t++) {
17143 while ( r!=null ) {
17145 if ( t==mp_dependent ) { /* for safety's sake, we change |q| to |mp_proto_dependent| */
17146 if ( mp->cur_exp==q ) if ( mp->cur_type==mp_dependent )
17147 mp->cur_type=mp_proto_dependent;
17148 dep_list(q)=mp_p_over_v(mp, dep_list(q),unity,
17149 mp_dependent,mp_proto_dependent);
17150 type(q)=mp_proto_dependent;
17151 value(r)=mp_round_fraction(mp, value(r));
17153 dep_list(q)=mp_p_plus_fq(mp, dep_list(q),
17154 mp_make_scaled(mp, value(r),-v),s,
17155 mp_proto_dependent,mp_proto_dependent);
17156 if ( dep_list(q)==mp->dep_final )
17157 mp_make_known(mp, q,mp->dep_final);
17158 q=r; r=link(r); mp_free_node(mp, q,dep_node_size);
17162 @ Here are some routines that provide handy combinations of actions
17163 that are often needed during error recovery. For example,
17164 `|flush_error|' flushes the current expression, replaces it by
17165 a given value, and calls |error|.
17167 Errors often are detected after an extra token has already been scanned.
17168 The `\\{put\_get}' routines put that token back before calling |error|;
17169 then they get it back again. (Or perhaps they get another token, if
17170 the user has changed things.)
17173 void mp_flush_error (MP mp,scaled v);
17174 void mp_put_get_error (MP mp);
17175 void mp_put_get_flush_error (MP mp,scaled v) ;
17178 void mp_flush_error (MP mp,scaled v) {
17179 mp_error(mp); mp_flush_cur_exp(mp, v);
17181 void mp_put_get_error (MP mp) {
17182 mp_back_error(mp); mp_get_x_next(mp);
17184 void mp_put_get_flush_error (MP mp,scaled v) {
17185 mp_put_get_error(mp);
17186 mp_flush_cur_exp(mp, v);
17189 @ A global variable |var_flag| is set to a special command code
17190 just before \MP\ calls |scan_expression|, if the expression should be
17191 treated as a variable when this command code immediately follows. For
17192 example, |var_flag| is set to |assignment| at the beginning of a
17193 statement, because we want to know the {\sl location\/} of a variable at
17194 the left of `\.{:=}', not the {\sl value\/} of that variable.
17196 The |scan_expression| subroutine calls |scan_tertiary|,
17197 which calls |scan_secondary|, which calls |scan_primary|, which sets
17198 |var_flag:=0|. In this way each of the scanning routines ``knows''
17199 when it has been called with a special |var_flag|, but |var_flag| is
17202 A variable preceding a command that equals |var_flag| is converted to a
17203 token list rather than a value. Furthermore, an `\.{=}' sign following an
17204 expression with |var_flag=assignment| is not considered to be a relation
17205 that produces boolean expressions.
17209 int var_flag; /* command that wants a variable */
17214 @* \[37] Parsing primary expressions.
17215 The first parsing routine, |scan_primary|, is also the most complicated one,
17216 since it involves so many different cases. But each case---with one
17217 exception---is fairly simple by itself.
17219 When |scan_primary| begins, the first token of the primary to be scanned
17220 should already appear in |cur_cmd|, |cur_mod|, and |cur_sym|. The values
17221 of |cur_type| and |cur_exp| should be either dead or dormant, as explained
17222 earlier. If |cur_cmd| is not between |min_primary_command| and
17223 |max_primary_command|, inclusive, a syntax error will be signaled.
17225 @<Declare the basic parsing subroutines@>=
17226 void mp_scan_primary (MP mp) {
17227 pointer p,q,r; /* for list manipulation */
17228 quarterword c; /* a primitive operation code */
17229 int my_var_flag; /* initial value of |my_var_flag| */
17230 pointer l_delim,r_delim; /* hash addresses of a delimiter pair */
17231 @<Other local variables for |scan_primary|@>;
17232 my_var_flag=mp->var_flag; mp->var_flag=0;
17235 @<Supply diagnostic information, if requested@>;
17236 switch (mp->cur_cmd) {
17237 case left_delimiter:
17238 @<Scan a delimited primary@>; break;
17240 @<Scan a grouped primary@>; break;
17242 @<Scan a string constant@>; break;
17243 case numeric_token:
17244 @<Scan a primary that starts with a numeric token@>; break;
17246 @<Scan a nullary operation@>; break;
17247 case unary: case type_name: case cycle: case plus_or_minus:
17248 @<Scan a unary operation@>; break;
17249 case primary_binary:
17250 @<Scan a binary operation with `\&{of}' between its operands@>; break;
17252 @<Convert a suffix to a string@>; break;
17253 case internal_quantity:
17254 @<Scan an internal numeric quantity@>; break;
17255 case capsule_token:
17256 mp_make_exp_copy(mp, mp->cur_mod); break;
17258 @<Scan a variable primary; |goto restart| if it turns out to be a macro@>; break;
17260 mp_bad_exp(mp, "A primary"); goto RESTART; break;
17261 @.A primary expression...@>
17263 mp_get_x_next(mp); /* the routines |goto done| if they don't want this */
17265 if ( mp->cur_cmd==left_bracket ) {
17266 if ( mp->cur_type>=mp_known ) {
17267 @<Scan a mediation construction@>;
17274 @ Errors at the beginning of expressions are flagged by |bad_exp|.
17276 @c void mp_bad_exp (MP mp, const char * s) {
17278 print_err(s); mp_print(mp, " expression can't begin with `");
17279 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod);
17280 mp_print_char(mp, '\'');
17281 help4("I'm afraid I need some sort of value in order to continue,")
17282 ("so I've tentatively inserted `0'. You may want to")
17283 ("delete this zero and insert something else;")
17284 ("see Chapter 27 of The METAFONTbook for an example.");
17285 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
17286 mp_back_input(mp); mp->cur_sym=0; mp->cur_cmd=numeric_token;
17287 mp->cur_mod=0; mp_ins_error(mp);
17288 save_flag=mp->var_flag; mp->var_flag=0; mp_get_x_next(mp);
17289 mp->var_flag=save_flag;
17292 @ @<Supply diagnostic information, if requested@>=
17294 if ( mp->panicking ) mp_check_mem(mp, false);
17296 if ( mp->interrupt!=0 ) if ( mp->OK_to_interrupt ) {
17297 mp_back_input(mp); check_interrupt; mp_get_x_next(mp);
17300 @ @<Scan a delimited primary@>=
17302 l_delim=mp->cur_sym; r_delim=mp->cur_mod;
17303 mp_get_x_next(mp); mp_scan_expression(mp);
17304 if ( (mp->cur_cmd==comma) && (mp->cur_type>=mp_known) ) {
17305 @<Scan the rest of a delimited set of numerics@>;
17307 mp_check_delimiter(mp, l_delim,r_delim);
17311 @ The |stash_in| subroutine puts the current (numeric) expression into a field
17312 within a ``big node.''
17314 @c void mp_stash_in (MP mp,pointer p) {
17315 pointer q; /* temporary register */
17316 type(p)=mp->cur_type;
17317 if ( mp->cur_type==mp_known ) {
17318 value(p)=mp->cur_exp;
17320 if ( mp->cur_type==mp_independent ) {
17321 @<Stash an independent |cur_exp| into a big node@>;
17323 mp->mem[value_loc(p)]=mp->mem[value_loc(mp->cur_exp)];
17324 /* |dep_list(p):=dep_list(cur_exp)| and |prev_dep(p):=prev_dep(cur_exp)| */
17325 link(prev_dep(p))=p;
17327 mp_free_node(mp, mp->cur_exp,value_node_size);
17329 mp->cur_type=mp_vacuous;
17332 @ In rare cases the current expression can become |independent|. There
17333 may be many dependency lists pointing to such an independent capsule,
17334 so we can't simply move it into place within a big node. Instead,
17335 we copy it, then recycle it.
17337 @ @<Stash an independent |cur_exp|...@>=
17339 q=mp_single_dependency(mp, mp->cur_exp);
17340 if ( q==mp->dep_final ){
17341 type(p)=mp_known; value(p)=0; mp_free_node(mp, q,dep_node_size);
17343 type(p)=mp_dependent; mp_new_dep(mp, p,q);
17345 mp_recycle_value(mp, mp->cur_exp);
17348 @ This code uses the fact that |red_part_loc| and |green_part_loc|
17349 are synonymous with |x_part_loc| and |y_part_loc|.
17351 @<Scan the rest of a delimited set of numerics@>=
17353 p=mp_stash_cur_exp(mp);
17354 mp_get_x_next(mp); mp_scan_expression(mp);
17355 @<Make sure the second part of a pair or color has a numeric type@>;
17356 q=mp_get_node(mp, value_node_size); name_type(q)=mp_capsule;
17357 if ( mp->cur_cmd==comma ) type(q)=mp_color_type;
17358 else type(q)=mp_pair_type;
17359 mp_init_big_node(mp, q); r=value(q);
17360 mp_stash_in(mp, y_part_loc(r));
17361 mp_unstash_cur_exp(mp, p);
17362 mp_stash_in(mp, x_part_loc(r));
17363 if ( mp->cur_cmd==comma ) {
17364 @<Scan the last of a triplet of numerics@>;
17366 if ( mp->cur_cmd==comma ) {
17367 type(q)=mp_cmykcolor_type;
17368 mp_init_big_node(mp, q); t=value(q);
17369 mp->mem[cyan_part_loc(t)]=mp->mem[red_part_loc(r)];
17370 value(cyan_part_loc(t))=value(red_part_loc(r));
17371 mp->mem[magenta_part_loc(t)]=mp->mem[green_part_loc(r)];
17372 value(magenta_part_loc(t))=value(green_part_loc(r));
17373 mp->mem[yellow_part_loc(t)]=mp->mem[blue_part_loc(r)];
17374 value(yellow_part_loc(t))=value(blue_part_loc(r));
17375 mp_recycle_value(mp, r);
17377 @<Scan the last of a quartet of numerics@>;
17379 mp_check_delimiter(mp, l_delim,r_delim);
17380 mp->cur_type=type(q);
17384 @ @<Make sure the second part of a pair or color has a numeric type@>=
17385 if ( mp->cur_type<mp_known ) {
17386 exp_err("Nonnumeric ypart has been replaced by 0");
17387 @.Nonnumeric...replaced by 0@>
17388 help4("I've started to scan a pair `(a,b)' or a color `(a,b,c)';")
17389 ("but after finding a nice `a' I found a `b' that isn't")
17390 ("of numeric type. So I've changed that part to zero.")
17391 ("(The b that I didn't like appears above the error message.)");
17392 mp_put_get_flush_error(mp, 0);
17395 @ @<Scan the last of a triplet of numerics@>=
17397 mp_get_x_next(mp); mp_scan_expression(mp);
17398 if ( mp->cur_type<mp_known ) {
17399 exp_err("Nonnumeric third part has been replaced by 0");
17400 @.Nonnumeric...replaced by 0@>
17401 help3("I've just scanned a color `(a,b,c)' or cmykcolor(a,b,c,d); but the `c'")
17402 ("isn't of numeric type. So I've changed that part to zero.")
17403 ("(The c that I didn't like appears above the error message.)");
17404 mp_put_get_flush_error(mp, 0);
17406 mp_stash_in(mp, blue_part_loc(r));
17409 @ @<Scan the last of a quartet of numerics@>=
17411 mp_get_x_next(mp); mp_scan_expression(mp);
17412 if ( mp->cur_type<mp_known ) {
17413 exp_err("Nonnumeric blackpart has been replaced by 0");
17414 @.Nonnumeric...replaced by 0@>
17415 help3("I've just scanned a cmykcolor `(c,m,y,k)'; but the `k' isn't")
17416 ("of numeric type. So I've changed that part to zero.")
17417 ("(The k that I didn't like appears above the error message.)");
17418 mp_put_get_flush_error(mp, 0);
17420 mp_stash_in(mp, black_part_loc(r));
17423 @ The local variable |group_line| keeps track of the line
17424 where a \&{begingroup} command occurred; this will be useful
17425 in an error message if the group doesn't actually end.
17427 @<Other local variables for |scan_primary|@>=
17428 integer group_line; /* where a group began */
17430 @ @<Scan a grouped primary@>=
17432 group_line=mp_true_line(mp);
17433 if ( mp->internal[mp_tracing_commands]>0 ) show_cur_cmd_mod;
17434 save_boundary_item(p);
17436 mp_do_statement(mp); /* ends with |cur_cmd>=semicolon| */
17437 } while (mp->cur_cmd==semicolon);
17438 if ( mp->cur_cmd!=end_group ) {
17439 print_err("A group begun on line ");
17440 @.A group...never ended@>
17441 mp_print_int(mp, group_line);
17442 mp_print(mp, " never ended");
17443 help2("I saw a `begingroup' back there that hasn't been matched")
17444 ("by `endgroup'. So I've inserted `endgroup' now.");
17445 mp_back_error(mp); mp->cur_cmd=end_group;
17448 /* this might change |cur_type|, if independent variables are recycled */
17449 if ( mp->internal[mp_tracing_commands]>0 ) show_cur_cmd_mod;
17452 @ @<Scan a string constant@>=
17454 mp->cur_type=mp_string_type; mp->cur_exp=mp->cur_mod;
17457 @ Later we'll come to procedures that perform actual operations like
17458 addition, square root, and so on; our purpose now is to do the parsing.
17459 But we might as well mention those future procedures now, so that the
17460 suspense won't be too bad:
17463 |do_nullary(c)| does primitive operations that have no operands (e.g.,
17464 `\&{true}' or `\&{pencircle}');
17467 |do_unary(c)| applies a primitive operation to the current expression;
17470 |do_binary(p,c)| applies a primitive operation to the capsule~|p|
17471 and the current expression.
17473 @<Scan a nullary operation@>=mp_do_nullary(mp, mp->cur_mod)
17475 @ @<Scan a unary operation@>=
17477 c=mp->cur_mod; mp_get_x_next(mp); mp_scan_primary(mp);
17478 mp_do_unary(mp, c); goto DONE;
17481 @ A numeric token might be a primary by itself, or it might be the
17482 numerator of a fraction composed solely of numeric tokens, or it might
17483 multiply the primary that follows (provided that the primary doesn't begin
17484 with a plus sign or a minus sign). The code here uses the facts that
17485 |max_primary_command=plus_or_minus| and
17486 |max_primary_command-1=numeric_token|. If a fraction is found that is less
17487 than unity, we try to retain higher precision when we use it in scalar
17490 @<Other local variables for |scan_primary|@>=
17491 scaled num,denom; /* for primaries that are fractions, like `1/2' */
17493 @ @<Scan a primary that starts with a numeric token@>=
17495 mp->cur_exp=mp->cur_mod; mp->cur_type=mp_known; mp_get_x_next(mp);
17496 if ( mp->cur_cmd!=slash ) {
17500 if ( mp->cur_cmd!=numeric_token ) {
17502 mp->cur_cmd=slash; mp->cur_mod=over; mp->cur_sym=frozen_slash;
17505 num=mp->cur_exp; denom=mp->cur_mod;
17506 if ( denom==0 ) { @<Protest division by zero@>; }
17507 else { mp->cur_exp=mp_make_scaled(mp, num,denom); }
17508 check_arith; mp_get_x_next(mp);
17510 if ( mp->cur_cmd>=min_primary_command ) {
17511 if ( mp->cur_cmd<numeric_token ) { /* in particular, |cur_cmd<>plus_or_minus| */
17512 p=mp_stash_cur_exp(mp); mp_scan_primary(mp);
17513 if ( (abs(num)>=abs(denom))||(mp->cur_type<mp_color_type) ) {
17514 mp_do_binary(mp, p,times);
17516 mp_frac_mult(mp, num,denom);
17517 mp_free_node(mp, p,value_node_size);
17524 @ @<Protest division...@>=
17526 print_err("Division by zero");
17527 @.Division by zero@>
17528 help1("I'll pretend that you meant to divide by 1."); mp_error(mp);
17531 @ @<Scan a binary operation with `\&{of}' between its operands@>=
17533 c=mp->cur_mod; mp_get_x_next(mp); mp_scan_expression(mp);
17534 if ( mp->cur_cmd!=of_token ) {
17535 mp_missing_err(mp, "of"); mp_print(mp, " for ");
17536 mp_print_cmd_mod(mp, primary_binary,c);
17538 help1("I've got the first argument; will look now for the other.");
17541 p=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_primary(mp);
17542 mp_do_binary(mp, p,c); goto DONE;
17545 @ @<Convert a suffix to a string@>=
17547 mp_get_x_next(mp); mp_scan_suffix(mp);
17548 mp->old_setting=mp->selector; mp->selector=new_string;
17549 mp_show_token_list(mp, mp->cur_exp,null,100000,0);
17550 mp_flush_token_list(mp, mp->cur_exp);
17551 mp->cur_exp=mp_make_string(mp); mp->selector=mp->old_setting;
17552 mp->cur_type=mp_string_type;
17556 @ If an internal quantity appears all by itself on the left of an
17557 assignment, we return a token list of length one, containing the address
17558 of the internal quantity plus |hash_end|. (This accords with the conventions
17559 of the save stack, as described earlier.)
17561 @<Scan an internal...@>=
17564 if ( my_var_flag==assignment ) {
17566 if ( mp->cur_cmd==assignment ) {
17567 mp->cur_exp=mp_get_avail(mp);
17568 info(mp->cur_exp)=q+hash_end; mp->cur_type=mp_token_list;
17573 mp->cur_type=mp_known; mp->cur_exp=mp->internal[q];
17576 @ The most difficult part of |scan_primary| has been saved for last, since
17577 it was necessary to build up some confidence first. We can now face the task
17578 of scanning a variable.
17580 As we scan a variable, we build a token list containing the relevant
17581 names and subscript values, simultaneously following along in the
17582 ``collective'' structure to see if we are actually dealing with a macro
17583 instead of a value.
17585 The local variables |pre_head| and |post_head| will point to the beginning
17586 of the prefix and suffix lists; |tail| will point to the end of the list
17587 that is currently growing.
17589 Another local variable, |tt|, contains partial information about the
17590 declared type of the variable-so-far. If |tt>=mp_unsuffixed_macro|, the
17591 relation |tt=type(q)| will always hold. If |tt=undefined|, the routine
17592 doesn't bother to update its information about type. And if
17593 |undefined<tt<mp_unsuffixed_macro|, the precise value of |tt| isn't critical.
17595 @ @<Other local variables for |scan_primary|@>=
17596 pointer pre_head,post_head,tail;
17597 /* prefix and suffix list variables */
17598 small_number tt; /* approximation to the type of the variable-so-far */
17599 pointer t; /* a token */
17600 pointer macro_ref = 0; /* reference count for a suffixed macro */
17602 @ @<Scan a variable primary...@>=
17604 fast_get_avail(pre_head); tail=pre_head; post_head=null; tt=mp_vacuous;
17606 t=mp_cur_tok(mp); link(tail)=t;
17607 if ( tt!=undefined ) {
17608 @<Find the approximate type |tt| and corresponding~|q|@>;
17609 if ( tt>=mp_unsuffixed_macro ) {
17610 @<Either begin an unsuffixed macro call or
17611 prepare for a suffixed one@>;
17614 mp_get_x_next(mp); tail=t;
17615 if ( mp->cur_cmd==left_bracket ) {
17616 @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>;
17618 if ( mp->cur_cmd>max_suffix_token ) break;
17619 if ( mp->cur_cmd<min_suffix_token ) break;
17620 } /* now |cur_cmd| is |internal_quantity|, |tag_token|, or |numeric_token| */
17621 @<Handle unusual cases that masquerade as variables, and |goto restart|
17622 or |goto done| if appropriate;
17623 otherwise make a copy of the variable and |goto done|@>;
17626 @ @<Either begin an unsuffixed macro call or...@>=
17629 if ( tt>mp_unsuffixed_macro ) { /* |tt=mp_suffixed_macro| */
17630 post_head=mp_get_avail(mp); tail=post_head; link(tail)=t;
17631 tt=undefined; macro_ref=value(q); add_mac_ref(macro_ref);
17633 @<Set up unsuffixed macro call and |goto restart|@>;
17637 @ @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>=
17639 mp_get_x_next(mp); mp_scan_expression(mp);
17640 if ( mp->cur_cmd!=right_bracket ) {
17641 @<Put the left bracket and the expression back to be rescanned@>;
17643 if ( mp->cur_type!=mp_known ) mp_bad_subscript(mp);
17644 mp->cur_cmd=numeric_token; mp->cur_mod=mp->cur_exp; mp->cur_sym=0;
17648 @ The left bracket that we thought was introducing a subscript might have
17649 actually been the left bracket in a mediation construction like `\.{x[a,b]}'.
17650 So we don't issue an error message at this point; but we do want to back up
17651 so as to avoid any embarrassment about our incorrect assumption.
17653 @<Put the left bracket and the expression back to be rescanned@>=
17655 mp_back_input(mp); /* that was the token following the current expression */
17656 mp_back_expr(mp); mp->cur_cmd=left_bracket;
17657 mp->cur_mod=0; mp->cur_sym=frozen_left_bracket;
17660 @ Here's a routine that puts the current expression back to be read again.
17662 @c void mp_back_expr (MP mp) {
17663 pointer p; /* capsule token */
17664 p=mp_stash_cur_exp(mp); link(p)=null; back_list(p);
17667 @ Unknown subscripts lead to the following error message.
17669 @c void mp_bad_subscript (MP mp) {
17670 exp_err("Improper subscript has been replaced by zero");
17671 @.Improper subscript...@>
17672 help3("A bracketed subscript must have a known numeric value;")
17673 ("unfortunately, what I found was the value that appears just")
17674 ("above this error message. So I'll try a zero subscript.");
17675 mp_flush_error(mp, 0);
17678 @ Every time we call |get_x_next|, there's a chance that the variable we've
17679 been looking at will disappear. Thus, we cannot safely keep |q| pointing
17680 into the variable structure; we need to start searching from the root each time.
17682 @<Find the approximate type |tt| and corresponding~|q|@>=
17685 p=link(pre_head); q=info(p); tt=undefined;
17686 if ( eq_type(q) % outer_tag==tag_token ) {
17688 if ( q==null ) goto DONE2;
17692 tt=type(q); goto DONE2;
17694 if ( type(q)!=mp_structured ) goto DONE2;
17695 q=link(attr_head(q)); /* the |collective_subscript| attribute */
17696 if ( p>=mp->hi_mem_min ) { /* it's not a subscript */
17697 do { q=link(q); } while (! (attr_loc(q)>=info(p)));
17698 if ( attr_loc(q)>info(p) ) goto DONE2;
17706 @ How do things stand now? Well, we have scanned an entire variable name,
17707 including possible subscripts and/or attributes; |cur_cmd|, |cur_mod|, and
17708 |cur_sym| represent the token that follows. If |post_head=null|, a
17709 token list for this variable name starts at |link(pre_head)|, with all
17710 subscripts evaluated. But if |post_head<>null|, the variable turned out
17711 to be a suffixed macro; |pre_head| is the head of the prefix list, while
17712 |post_head| is the head of a token list containing both `\.{\AT!}' and
17715 Our immediate problem is to see if this variable still exists. (Variable
17716 structures can change drastically whenever we call |get_x_next|; users
17717 aren't supposed to do this, but the fact that it is possible means that
17718 we must be cautious.)
17720 The following procedure prints an error message when a variable
17721 unexpectedly disappears. Its help message isn't quite right for
17722 our present purposes, but we'll be able to fix that up.
17725 void mp_obliterated (MP mp,pointer q) {
17726 print_err("Variable "); mp_show_token_list(mp, q,null,1000,0);
17727 mp_print(mp, " has been obliterated");
17728 @.Variable...obliterated@>
17729 help5("It seems you did a nasty thing---probably by accident,")
17730 ("but nevertheless you nearly hornswoggled me...")
17731 ("While I was evaluating the right-hand side of this")
17732 ("command, something happened, and the left-hand side")
17733 ("is no longer a variable! So I won't change anything.");
17736 @ If the variable does exist, we also need to check
17737 for a few other special cases before deciding that a plain old ordinary
17738 variable has, indeed, been scanned.
17740 @<Handle unusual cases that masquerade as variables...@>=
17741 if ( post_head!=null ) {
17742 @<Set up suffixed macro call and |goto restart|@>;
17744 q=link(pre_head); free_avail(pre_head);
17745 if ( mp->cur_cmd==my_var_flag ) {
17746 mp->cur_type=mp_token_list; mp->cur_exp=q; goto DONE;
17748 p=mp_find_variable(mp, q);
17750 mp_make_exp_copy(mp, p);
17752 mp_obliterated(mp, q);
17753 mp->help_line[2]="While I was evaluating the suffix of this variable,";
17754 mp->help_line[1]="something was redefined, and it's no longer a variable!";
17755 mp->help_line[0]="In order to get back on my feet, I've inserted `0' instead.";
17756 mp_put_get_flush_error(mp, 0);
17758 mp_flush_node_list(mp, q);
17761 @ The only complication associated with macro calling is that the prefix
17762 and ``at'' parameters must be packaged in an appropriate list of lists.
17764 @<Set up unsuffixed macro call and |goto restart|@>=
17766 p=mp_get_avail(mp); info(pre_head)=link(pre_head); link(pre_head)=p;
17767 info(p)=t; mp_macro_call(mp, value(q),pre_head,null);
17772 @ If the ``variable'' that turned out to be a suffixed macro no longer exists,
17773 we don't care, because we have reserved a pointer (|macro_ref|) to its
17776 @<Set up suffixed macro call and |goto restart|@>=
17778 mp_back_input(mp); p=mp_get_avail(mp); q=link(post_head);
17779 info(pre_head)=link(pre_head); link(pre_head)=post_head;
17780 info(post_head)=q; link(post_head)=p; info(p)=link(q); link(q)=null;
17781 mp_macro_call(mp, macro_ref,pre_head,null); decr(ref_count(macro_ref));
17782 mp_get_x_next(mp); goto RESTART;
17785 @ Our remaining job is simply to make a copy of the value that has been
17786 found. Some cases are harder than others, but complexity arises solely
17787 because of the multiplicity of possible cases.
17789 @<Declare the procedure called |make_exp_copy|@>=
17790 @<Declare subroutines needed by |make_exp_copy|@>
17791 void mp_make_exp_copy (MP mp,pointer p) {
17792 pointer q,r,t; /* registers for list manipulation */
17794 mp->cur_type=type(p);
17795 switch (mp->cur_type) {
17796 case mp_vacuous: case mp_boolean_type: case mp_known:
17797 mp->cur_exp=value(p); break;
17798 case unknown_types:
17799 mp->cur_exp=mp_new_ring_entry(mp, p);
17801 case mp_string_type:
17802 mp->cur_exp=value(p); add_str_ref(mp->cur_exp);
17804 case mp_picture_type:
17805 mp->cur_exp=value(p);add_edge_ref(mp->cur_exp);
17808 mp->cur_exp=copy_pen(value(p));
17811 mp->cur_exp=mp_copy_path(mp, value(p));
17813 case mp_transform_type: case mp_color_type:
17814 case mp_cmykcolor_type: case mp_pair_type:
17815 @<Copy the big node |p|@>;
17817 case mp_dependent: case mp_proto_dependent:
17818 mp_encapsulate(mp, mp_copy_dep_list(mp, dep_list(p)));
17820 case mp_numeric_type:
17821 new_indep(p); goto RESTART;
17823 case mp_independent:
17824 q=mp_single_dependency(mp, p);
17825 if ( q==mp->dep_final ){
17826 mp->cur_type=mp_known; mp->cur_exp=0; mp_free_node(mp, q,dep_node_size);
17828 mp->cur_type=mp_dependent; mp_encapsulate(mp, q);
17832 mp_confusion(mp, "copy");
17833 @:this can't happen copy}{\quad copy@>
17838 @ The |encapsulate| subroutine assumes that |dep_final| is the
17839 tail of dependency list~|p|.
17841 @<Declare subroutines needed by |make_exp_copy|@>=
17842 void mp_encapsulate (MP mp,pointer p) {
17843 mp->cur_exp=mp_get_node(mp, value_node_size); type(mp->cur_exp)=mp->cur_type;
17844 name_type(mp->cur_exp)=mp_capsule; mp_new_dep(mp, mp->cur_exp,p);
17847 @ The most tedious case arises when the user refers to a
17848 \&{pair}, \&{color}, or \&{transform} variable; we must copy several fields,
17849 each of which can be |independent|, |dependent|, |mp_proto_dependent|,
17852 @<Copy the big node |p|@>=
17854 if ( value(p)==null )
17855 mp_init_big_node(mp, p);
17856 t=mp_get_node(mp, value_node_size); name_type(t)=mp_capsule; type(t)=mp->cur_type;
17857 mp_init_big_node(mp, t);
17858 q=value(p)+mp->big_node_size[mp->cur_type];
17859 r=value(t)+mp->big_node_size[mp->cur_type];
17861 q=q-2; r=r-2; mp_install(mp, r,q);
17862 } while (q!=value(p));
17866 @ The |install| procedure copies a numeric field~|q| into field~|r| of
17867 a big node that will be part of a capsule.
17869 @<Declare subroutines needed by |make_exp_copy|@>=
17870 void mp_install (MP mp,pointer r, pointer q) {
17871 pointer p; /* temporary register */
17872 if ( type(q)==mp_known ){
17873 value(r)=value(q); type(r)=mp_known;
17874 } else if ( type(q)==mp_independent ) {
17875 p=mp_single_dependency(mp, q);
17876 if ( p==mp->dep_final ) {
17877 type(r)=mp_known; value(r)=0; mp_free_node(mp, p,dep_node_size);
17879 type(r)=mp_dependent; mp_new_dep(mp, r,p);
17882 type(r)=type(q); mp_new_dep(mp, r,mp_copy_dep_list(mp, dep_list(q)));
17886 @ Expressions of the form `\.{a[b,c]}' are converted into
17887 `\.{b+a*(c-b)}', without checking the types of \.b~or~\.c,
17888 provided that \.a is numeric.
17890 @<Scan a mediation...@>=
17892 p=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_expression(mp);
17893 if ( mp->cur_cmd!=comma ) {
17894 @<Put the left bracket and the expression back...@>;
17895 mp_unstash_cur_exp(mp, p);
17897 q=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_expression(mp);
17898 if ( mp->cur_cmd!=right_bracket ) {
17899 mp_missing_err(mp, "]");
17901 help3("I've scanned an expression of the form `a[b,c',")
17902 ("so a right bracket should have come next.")
17903 ("I shall pretend that one was there.");
17906 r=mp_stash_cur_exp(mp); mp_make_exp_copy(mp, q);
17907 mp_do_binary(mp, r,minus); mp_do_binary(mp, p,times);
17908 mp_do_binary(mp, q,plus); mp_get_x_next(mp);
17912 @ Here is a comparatively simple routine that is used to scan the
17913 \&{suffix} parameters of a macro.
17915 @<Declare the basic parsing subroutines@>=
17916 void mp_scan_suffix (MP mp) {
17917 pointer h,t; /* head and tail of the list being built */
17918 pointer p; /* temporary register */
17919 h=mp_get_avail(mp); t=h;
17921 if ( mp->cur_cmd==left_bracket ) {
17922 @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>;
17924 if ( mp->cur_cmd==numeric_token ) {
17925 p=mp_new_num_tok(mp, mp->cur_mod);
17926 } else if ((mp->cur_cmd==tag_token)||(mp->cur_cmd==internal_quantity) ) {
17927 p=mp_get_avail(mp); info(p)=mp->cur_sym;
17931 link(t)=p; t=p; mp_get_x_next(mp);
17933 mp->cur_exp=link(h); free_avail(h); mp->cur_type=mp_token_list;
17936 @ @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>=
17938 mp_get_x_next(mp); mp_scan_expression(mp);
17939 if ( mp->cur_type!=mp_known ) mp_bad_subscript(mp);
17940 if ( mp->cur_cmd!=right_bracket ) {
17941 mp_missing_err(mp, "]");
17943 help3("I've seen a `[' and a subscript value, in a suffix,")
17944 ("so a right bracket should have come next.")
17945 ("I shall pretend that one was there.");
17948 mp->cur_cmd=numeric_token; mp->cur_mod=mp->cur_exp;
17951 @* \[38] Parsing secondary and higher expressions.
17953 After the intricacies of |scan_primary|\kern-1pt,
17954 the |scan_secondary| routine is
17955 refreshingly simple. It's not trivial, but the operations are relatively
17956 straightforward; the main difficulty is, again, that expressions and data
17957 structures might change drastically every time we call |get_x_next|, so a
17958 cautious approach is mandatory. For example, a macro defined by
17959 \&{primarydef} might have disappeared by the time its second argument has
17960 been scanned; we solve this by increasing the reference count of its token
17961 list, so that the macro can be called even after it has been clobbered.
17963 @<Declare the basic parsing subroutines@>=
17964 void mp_scan_secondary (MP mp) {
17965 pointer p; /* for list manipulation */
17966 halfword c,d; /* operation codes or modifiers */
17967 pointer mac_name; /* token defined with \&{primarydef} */
17969 if ((mp->cur_cmd<min_primary_command)||
17970 (mp->cur_cmd>max_primary_command) )
17971 mp_bad_exp(mp, "A secondary");
17972 @.A secondary expression...@>
17973 mp_scan_primary(mp);
17975 if ( mp->cur_cmd<=max_secondary_command &&
17976 mp->cur_cmd>=min_secondary_command ) {
17977 p=mp_stash_cur_exp(mp);
17978 c=mp->cur_mod; d=mp->cur_cmd;
17979 if ( d==secondary_primary_macro ) {
17980 mac_name=mp->cur_sym;
17984 mp_scan_primary(mp);
17985 if ( d!=secondary_primary_macro ) {
17986 mp_do_binary(mp, p,c);
17989 mp_binary_mac(mp, p,c,mac_name);
17990 decr(ref_count(c));
17998 @ The following procedure calls a macro that has two parameters,
18001 @c void mp_binary_mac (MP mp,pointer p, pointer c, pointer n) {
18002 pointer q,r; /* nodes in the parameter list */
18003 q=mp_get_avail(mp); r=mp_get_avail(mp); link(q)=r;
18004 info(q)=p; info(r)=mp_stash_cur_exp(mp);
18005 mp_macro_call(mp, c,q,n);
18008 @ The next procedure, |scan_tertiary|, is pretty much the same deal.
18010 @<Declare the basic parsing subroutines@>=
18011 void mp_scan_tertiary (MP mp) {
18012 pointer p; /* for list manipulation */
18013 halfword c,d; /* operation codes or modifiers */
18014 pointer mac_name; /* token defined with \&{secondarydef} */
18016 if ((mp->cur_cmd<min_primary_command)||
18017 (mp->cur_cmd>max_primary_command) )
18018 mp_bad_exp(mp, "A tertiary");
18019 @.A tertiary expression...@>
18020 mp_scan_secondary(mp);
18022 if ( mp->cur_cmd<=max_tertiary_command ) {
18023 if ( mp->cur_cmd>=min_tertiary_command ) {
18024 p=mp_stash_cur_exp(mp); c=mp->cur_mod; d=mp->cur_cmd;
18025 if ( d==tertiary_secondary_macro ) {
18026 mac_name=mp->cur_sym; add_mac_ref(c);
18028 mp_get_x_next(mp); mp_scan_secondary(mp);
18029 if ( d!=tertiary_secondary_macro ) {
18030 mp_do_binary(mp, p,c);
18032 mp_back_input(mp); mp_binary_mac(mp, p,c,mac_name);
18033 decr(ref_count(c)); mp_get_x_next(mp);
18041 @ Finally we reach the deepest level in our quartet of parsing routines.
18042 This one is much like the others; but it has an extra complication from
18043 paths, which materialize here.
18045 @d continue_path 25 /* a label inside of |scan_expression| */
18046 @d finish_path 26 /* another */
18048 @<Declare the basic parsing subroutines@>=
18049 void mp_scan_expression (MP mp) {
18050 pointer p,q,r,pp,qq; /* for list manipulation */
18051 halfword c,d; /* operation codes or modifiers */
18052 int my_var_flag; /* initial value of |var_flag| */
18053 pointer mac_name; /* token defined with \&{tertiarydef} */
18054 boolean cycle_hit; /* did a path expression just end with `\&{cycle}'? */
18055 scaled x,y; /* explicit coordinates or tension at a path join */
18056 int t; /* knot type following a path join */
18058 my_var_flag=mp->var_flag; mac_name=null;
18060 if ((mp->cur_cmd<min_primary_command)||
18061 (mp->cur_cmd>max_primary_command) )
18062 mp_bad_exp(mp, "An");
18063 @.An expression...@>
18064 mp_scan_tertiary(mp);
18066 if ( mp->cur_cmd<=max_expression_command )
18067 if ( mp->cur_cmd>=min_expression_command ) {
18068 if ( (mp->cur_cmd!=equals)||(my_var_flag!=assignment) ) {
18069 p=mp_stash_cur_exp(mp); c=mp->cur_mod; d=mp->cur_cmd;
18070 if ( d==expression_tertiary_macro ) {
18071 mac_name=mp->cur_sym; add_mac_ref(c);
18073 if ( (d<ampersand)||((d==ampersand)&&
18074 ((type(p)==mp_pair_type)||(type(p)==mp_path_type))) ) {
18075 @<Scan a path construction operation;
18076 but |return| if |p| has the wrong type@>;
18078 mp_get_x_next(mp); mp_scan_tertiary(mp);
18079 if ( d!=expression_tertiary_macro ) {
18080 mp_do_binary(mp, p,c);
18082 mp_back_input(mp); mp_binary_mac(mp, p,c,mac_name);
18083 decr(ref_count(c)); mp_get_x_next(mp);
18092 @ The reader should review the data structure conventions for paths before
18093 hoping to understand the next part of this code.
18095 @<Scan a path construction operation...@>=
18098 @<Convert the left operand, |p|, into a partial path ending at~|q|;
18099 but |return| if |p| doesn't have a suitable type@>;
18101 @<Determine the path join parameters;
18102 but |goto finish_path| if there's only a direction specifier@>;
18103 if ( mp->cur_cmd==cycle ) {
18104 @<Get ready to close a cycle@>;
18106 mp_scan_tertiary(mp);
18107 @<Convert the right operand, |cur_exp|,
18108 into a partial path from |pp| to~|qq|@>;
18110 @<Join the partial paths and reset |p| and |q| to the head and tail
18112 if ( mp->cur_cmd>=min_expression_command )
18113 if ( mp->cur_cmd<=ampersand ) if ( ! cycle_hit ) goto CONTINUE_PATH;
18115 @<Choose control points for the path and put the result into |cur_exp|@>;
18118 @ @<Convert the left operand, |p|, into a partial path ending at~|q|...@>=
18120 mp_unstash_cur_exp(mp, p);
18121 if ( mp->cur_type==mp_pair_type ) p=mp_new_knot(mp);
18122 else if ( mp->cur_type==mp_path_type ) p=mp->cur_exp;
18125 while ( link(q)!=p ) q=link(q);
18126 if ( left_type(p)!=mp_endpoint ) { /* open up a cycle */
18127 r=mp_copy_knot(mp, p); link(q)=r; q=r;
18129 left_type(p)=mp_open; right_type(q)=mp_open;
18132 @ A pair of numeric values is changed into a knot node for a one-point path
18133 when \MP\ discovers that the pair is part of a path.
18135 @c @<Declare the procedure called |known_pair|@>
18136 pointer mp_new_knot (MP mp) { /* convert a pair to a knot with two endpoints */
18137 pointer q; /* the new node */
18138 q=mp_get_node(mp, knot_node_size); left_type(q)=mp_endpoint;
18139 right_type(q)=mp_endpoint; originator(q)=mp_metapost_user; link(q)=q;
18140 mp_known_pair(mp); x_coord(q)=mp->cur_x; y_coord(q)=mp->cur_y;
18144 @ The |known_pair| subroutine sets |cur_x| and |cur_y| to the components
18145 of the current expression, assuming that the current expression is a
18146 pair of known numerics. Unknown components are zeroed, and the
18147 current expression is flushed.
18149 @<Declare the procedure called |known_pair|@>=
18150 void mp_known_pair (MP mp) {
18151 pointer p; /* the pair node */
18152 if ( mp->cur_type!=mp_pair_type ) {
18153 exp_err("Undefined coordinates have been replaced by (0,0)");
18154 @.Undefined coordinates...@>
18155 help5("I need x and y numbers for this part of the path.")
18156 ("The value I found (see above) was no good;")
18157 ("so I'll try to keep going by using zero instead.")
18158 ("(Chapter 27 of The METAFONTbook explains that")
18159 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18160 ("you might want to type `I ??" "?' now.)");
18161 mp_put_get_flush_error(mp, 0); mp->cur_x=0; mp->cur_y=0;
18163 p=value(mp->cur_exp);
18164 @<Make sure that both |x| and |y| parts of |p| are known;
18165 copy them into |cur_x| and |cur_y|@>;
18166 mp_flush_cur_exp(mp, 0);
18170 @ @<Make sure that both |x| and |y| parts of |p| are known...@>=
18171 if ( type(x_part_loc(p))==mp_known ) {
18172 mp->cur_x=value(x_part_loc(p));
18174 mp_disp_err(mp, x_part_loc(p),
18175 "Undefined x coordinate has been replaced by 0");
18176 @.Undefined coordinates...@>
18177 help5("I need a `known' x value for this part of the path.")
18178 ("The value I found (see above) was no good;")
18179 ("so I'll try to keep going by using zero instead.")
18180 ("(Chapter 27 of The METAFONTbook explains that")
18181 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18182 ("you might want to type `I ??" "?' now.)");
18183 mp_put_get_error(mp); mp_recycle_value(mp, x_part_loc(p)); mp->cur_x=0;
18185 if ( type(y_part_loc(p))==mp_known ) {
18186 mp->cur_y=value(y_part_loc(p));
18188 mp_disp_err(mp, y_part_loc(p),
18189 "Undefined y coordinate has been replaced by 0");
18190 help5("I need a `known' y value for this part of the path.")
18191 ("The value I found (see above) was no good;")
18192 ("so I'll try to keep going by using zero instead.")
18193 ("(Chapter 27 of The METAFONTbook explains that")
18194 ("you might want to type `I ??" "?' now.)");
18195 mp_put_get_error(mp); mp_recycle_value(mp, y_part_loc(p)); mp->cur_y=0;
18198 @ At this point |cur_cmd| is either |ampersand|, |left_brace|, or |path_join|.
18200 @<Determine the path join parameters...@>=
18201 if ( mp->cur_cmd==left_brace ) {
18202 @<Put the pre-join direction information into node |q|@>;
18205 if ( d==path_join ) {
18206 @<Determine the tension and/or control points@>;
18207 } else if ( d!=ampersand ) {
18211 if ( mp->cur_cmd==left_brace ) {
18212 @<Put the post-join direction information into |x| and |t|@>;
18213 } else if ( right_type(q)!=mp_explicit ) {
18217 @ The |scan_direction| subroutine looks at the directional information
18218 that is enclosed in braces, and also scans ahead to the following character.
18219 A type code is returned, either |open| (if the direction was $(0,0)$),
18220 or |curl| (if the direction was a curl of known value |cur_exp|), or
18221 |given| (if the direction is given by the |angle| value that now
18222 appears in |cur_exp|).
18224 There's nothing difficult about this subroutine, but the program is rather
18225 lengthy because a variety of potential errors need to be nipped in the bud.
18227 @c small_number mp_scan_direction (MP mp) {
18228 int t; /* the type of information found */
18229 scaled x; /* an |x| coordinate */
18231 if ( mp->cur_cmd==curl_command ) {
18232 @<Scan a curl specification@>;
18234 @<Scan a given direction@>;
18236 if ( mp->cur_cmd!=right_brace ) {
18237 mp_missing_err(mp, "}");
18238 @.Missing `\char`\}'@>
18239 help3("I've scanned a direction spec for part of a path,")
18240 ("so a right brace should have come next.")
18241 ("I shall pretend that one was there.");
18248 @ @<Scan a curl specification@>=
18249 { mp_get_x_next(mp); mp_scan_expression(mp);
18250 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<0) ){
18251 exp_err("Improper curl has been replaced by 1");
18253 help1("A curl must be a known, nonnegative number.");
18254 mp_put_get_flush_error(mp, unity);
18259 @ @<Scan a given direction@>=
18260 { mp_scan_expression(mp);
18261 if ( mp->cur_type>mp_pair_type ) {
18262 @<Get given directions separated by commas@>;
18266 if ( (mp->cur_x==0)&&(mp->cur_y==0) ) t=mp_open;
18267 else { t=mp_given; mp->cur_exp=mp_n_arg(mp, mp->cur_x,mp->cur_y);}
18270 @ @<Get given directions separated by commas@>=
18272 if ( mp->cur_type!=mp_known ) {
18273 exp_err("Undefined x coordinate has been replaced by 0");
18274 @.Undefined coordinates...@>
18275 help5("I need a `known' x value for this part of the path.")
18276 ("The value I found (see above) was no good;")
18277 ("so I'll try to keep going by using zero instead.")
18278 ("(Chapter 27 of The METAFONTbook explains that")
18279 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18280 ("you might want to type `I ??" "?' now.)");
18281 mp_put_get_flush_error(mp, 0);
18284 if ( mp->cur_cmd!=comma ) {
18285 mp_missing_err(mp, ",");
18287 help2("I've got the x coordinate of a path direction;")
18288 ("will look for the y coordinate next.");
18291 mp_get_x_next(mp); mp_scan_expression(mp);
18292 if ( mp->cur_type!=mp_known ) {
18293 exp_err("Undefined y coordinate has been replaced by 0");
18294 help5("I need a `known' y value for this part of the path.")
18295 ("The value I found (see above) was no good;")
18296 ("so I'll try to keep going by using zero instead.")
18297 ("(Chapter 27 of The METAFONTbook explains that")
18298 ("you might want to type `I ??" "?' now.)");
18299 mp_put_get_flush_error(mp, 0);
18301 mp->cur_y=mp->cur_exp; mp->cur_x=x;
18304 @ At this point |right_type(q)| is usually |open|, but it may have been
18305 set to some other value by a previous operation. We must maintain
18306 the value of |right_type(q)| in cases such as
18307 `\.{..\{curl2\}z\{0,0\}..}'.
18309 @<Put the pre-join...@>=
18311 t=mp_scan_direction(mp);
18312 if ( t!=mp_open ) {
18313 right_type(q)=t; right_given(q)=mp->cur_exp;
18314 if ( left_type(q)==mp_open ) {
18315 left_type(q)=t; left_given(q)=mp->cur_exp;
18316 } /* note that |left_given(q)=left_curl(q)| */
18320 @ Since |left_tension| and |left_y| share the same position in knot nodes,
18321 and since |left_given| is similarly equivalent to |left_x|, we use
18322 |x| and |y| to hold the given direction and tension information when
18323 there are no explicit control points.
18325 @<Put the post-join...@>=
18327 t=mp_scan_direction(mp);
18328 if ( right_type(q)!=mp_explicit ) x=mp->cur_exp;
18329 else t=mp_explicit; /* the direction information is superfluous */
18332 @ @<Determine the tension and/or...@>=
18335 if ( mp->cur_cmd==tension ) {
18336 @<Set explicit tensions@>;
18337 } else if ( mp->cur_cmd==controls ) {
18338 @<Set explicit control points@>;
18340 right_tension(q)=unity; y=unity; mp_back_input(mp); /* default tension */
18343 if ( mp->cur_cmd!=path_join ) {
18344 mp_missing_err(mp, "..");
18346 help1("A path join command should end with two dots.");
18353 @ @<Set explicit tensions@>=
18355 mp_get_x_next(mp); y=mp->cur_cmd;
18356 if ( mp->cur_cmd==at_least ) mp_get_x_next(mp);
18357 mp_scan_primary(mp);
18358 @<Make sure that the current expression is a valid tension setting@>;
18359 if ( y==at_least ) negate(mp->cur_exp);
18360 right_tension(q)=mp->cur_exp;
18361 if ( mp->cur_cmd==and_command ) {
18362 mp_get_x_next(mp); y=mp->cur_cmd;
18363 if ( mp->cur_cmd==at_least ) mp_get_x_next(mp);
18364 mp_scan_primary(mp);
18365 @<Make sure that the current expression is a valid tension setting@>;
18366 if ( y==at_least ) negate(mp->cur_exp);
18371 @ @d min_tension three_quarter_unit
18373 @<Make sure that the current expression is a valid tension setting@>=
18374 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<min_tension) ) {
18375 exp_err("Improper tension has been set to 1");
18376 @.Improper tension@>
18377 help1("The expression above should have been a number >=3/4.");
18378 mp_put_get_flush_error(mp, unity);
18381 @ @<Set explicit control points@>=
18383 right_type(q)=mp_explicit; t=mp_explicit; mp_get_x_next(mp); mp_scan_primary(mp);
18384 mp_known_pair(mp); right_x(q)=mp->cur_x; right_y(q)=mp->cur_y;
18385 if ( mp->cur_cmd!=and_command ) {
18386 x=right_x(q); y=right_y(q);
18388 mp_get_x_next(mp); mp_scan_primary(mp);
18389 mp_known_pair(mp); x=mp->cur_x; y=mp->cur_y;
18393 @ @<Convert the right operand, |cur_exp|, into a partial path...@>=
18395 if ( mp->cur_type!=mp_path_type ) pp=mp_new_knot(mp);
18396 else pp=mp->cur_exp;
18398 while ( link(qq)!=pp ) qq=link(qq);
18399 if ( left_type(pp)!=mp_endpoint ) { /* open up a cycle */
18400 r=mp_copy_knot(mp, pp); link(qq)=r; qq=r;
18402 left_type(pp)=mp_open; right_type(qq)=mp_open;
18405 @ If a person tries to define an entire path by saying `\.{(x,y)\&cycle}',
18406 we silently change the specification to `\.{(x,y)..cycle}', since a cycle
18407 shouldn't have length zero.
18409 @<Get ready to close a cycle@>=
18411 cycle_hit=true; mp_get_x_next(mp); pp=p; qq=p;
18412 if ( d==ampersand ) if ( p==q ) {
18413 d=path_join; right_tension(q)=unity; y=unity;
18417 @ @<Join the partial paths and reset |p| and |q|...@>=
18419 if ( d==ampersand ) {
18420 if ( (x_coord(q)!=x_coord(pp))||(y_coord(q)!=y_coord(pp)) ) {
18421 print_err("Paths don't touch; `&' will be changed to `..'");
18422 @.Paths don't touch@>
18423 help3("When you join paths `p&q', the ending point of p")
18424 ("must be exactly equal to the starting point of q.")
18425 ("So I'm going to pretend that you said `p..q' instead.");
18426 mp_put_get_error(mp); d=path_join; right_tension(q)=unity; y=unity;
18429 @<Plug an opening in |right_type(pp)|, if possible@>;
18430 if ( d==ampersand ) {
18431 @<Splice independent paths together@>;
18433 @<Plug an opening in |right_type(q)|, if possible@>;
18434 link(q)=pp; left_y(pp)=y;
18435 if ( t!=mp_open ) { left_x(pp)=x; left_type(pp)=t; };
18440 @ @<Plug an opening in |right_type(q)|...@>=
18441 if ( right_type(q)==mp_open ) {
18442 if ( (left_type(q)==mp_curl)||(left_type(q)==mp_given) ) {
18443 right_type(q)=left_type(q); right_given(q)=left_given(q);
18447 @ @<Plug an opening in |right_type(pp)|...@>=
18448 if ( right_type(pp)==mp_open ) {
18449 if ( (t==mp_curl)||(t==mp_given) ) {
18450 right_type(pp)=t; right_given(pp)=x;
18454 @ @<Splice independent paths together@>=
18456 if ( left_type(q)==mp_open ) if ( right_type(q)==mp_open ) {
18457 left_type(q)=mp_curl; left_curl(q)=unity;
18459 if ( right_type(pp)==mp_open ) if ( t==mp_open ) {
18460 right_type(pp)=mp_curl; right_curl(pp)=unity;
18462 right_type(q)=right_type(pp); link(q)=link(pp);
18463 right_x(q)=right_x(pp); right_y(q)=right_y(pp);
18464 mp_free_node(mp, pp,knot_node_size);
18465 if ( qq==pp ) qq=q;
18468 @ @<Choose control points for the path...@>=
18470 if ( d==ampersand ) p=q;
18472 left_type(p)=mp_endpoint;
18473 if ( right_type(p)==mp_open ) {
18474 right_type(p)=mp_curl; right_curl(p)=unity;
18476 right_type(q)=mp_endpoint;
18477 if ( left_type(q)==mp_open ) {
18478 left_type(q)=mp_curl; left_curl(q)=unity;
18482 mp_make_choices(mp, p);
18483 mp->cur_type=mp_path_type; mp->cur_exp=p
18485 @ Finally, we sometimes need to scan an expression whose value is
18486 supposed to be either |true_code| or |false_code|.
18488 @<Declare the basic parsing subroutines@>=
18489 void mp_get_boolean (MP mp) {
18490 mp_get_x_next(mp); mp_scan_expression(mp);
18491 if ( mp->cur_type!=mp_boolean_type ) {
18492 exp_err("Undefined condition will be treated as `false'");
18493 @.Undefined condition...@>
18494 help2("The expression shown above should have had a definite")
18495 ("true-or-false value. I'm changing it to `false'.");
18496 mp_put_get_flush_error(mp, false_code); mp->cur_type=mp_boolean_type;
18500 @* \[39] Doing the operations.
18501 The purpose of parsing is primarily to permit people to avoid piles of
18502 parentheses. But the real work is done after the structure of an expression
18503 has been recognized; that's when new expressions are generated. We
18504 turn now to the guts of \MP, which handles individual operators that
18505 have come through the parsing mechanism.
18507 We'll start with the easy ones that take no operands, then work our way
18508 up to operators with one and ultimately two arguments. In other words,
18509 we will write the three procedures |do_nullary|, |do_unary|, and |do_binary|
18510 that are invoked periodically by the expression scanners.
18512 First let's make sure that all of the primitive operators are in the
18513 hash table. Although |scan_primary| and its relatives made use of the
18514 \\{cmd} code for these operators, the \\{do} routines base everything
18515 on the \\{mod} code. For example, |do_binary| doesn't care whether the
18516 operation it performs is a |primary_binary| or |secondary_binary|, etc.
18519 mp_primitive(mp, "true",nullary,true_code);
18520 @:true_}{\&{true} primitive@>
18521 mp_primitive(mp, "false",nullary,false_code);
18522 @:false_}{\&{false} primitive@>
18523 mp_primitive(mp, "nullpicture",nullary,null_picture_code);
18524 @:null_picture_}{\&{nullpicture} primitive@>
18525 mp_primitive(mp, "nullpen",nullary,null_pen_code);
18526 @:null_pen_}{\&{nullpen} primitive@>
18527 mp_primitive(mp, "jobname",nullary,job_name_op);
18528 @:job_name_}{\&{jobname} primitive@>
18529 mp_primitive(mp, "readstring",nullary,read_string_op);
18530 @:read_string_}{\&{readstring} primitive@>
18531 mp_primitive(mp, "pencircle",nullary,pen_circle);
18532 @:pen_circle_}{\&{pencircle} primitive@>
18533 mp_primitive(mp, "normaldeviate",nullary,normal_deviate);
18534 @:normal_deviate_}{\&{normaldeviate} primitive@>
18535 mp_primitive(mp, "readfrom",unary,read_from_op);
18536 @:read_from_}{\&{readfrom} primitive@>
18537 mp_primitive(mp, "closefrom",unary,close_from_op);
18538 @:close_from_}{\&{closefrom} primitive@>
18539 mp_primitive(mp, "odd",unary,odd_op);
18540 @:odd_}{\&{odd} primitive@>
18541 mp_primitive(mp, "known",unary,known_op);
18542 @:known_}{\&{known} primitive@>
18543 mp_primitive(mp, "unknown",unary,unknown_op);
18544 @:unknown_}{\&{unknown} primitive@>
18545 mp_primitive(mp, "not",unary,not_op);
18546 @:not_}{\&{not} primitive@>
18547 mp_primitive(mp, "decimal",unary,decimal);
18548 @:decimal_}{\&{decimal} primitive@>
18549 mp_primitive(mp, "reverse",unary,reverse);
18550 @:reverse_}{\&{reverse} primitive@>
18551 mp_primitive(mp, "makepath",unary,make_path_op);
18552 @:make_path_}{\&{makepath} primitive@>
18553 mp_primitive(mp, "makepen",unary,make_pen_op);
18554 @:make_pen_}{\&{makepen} primitive@>
18555 mp_primitive(mp, "oct",unary,oct_op);
18556 @:oct_}{\&{oct} primitive@>
18557 mp_primitive(mp, "hex",unary,hex_op);
18558 @:hex_}{\&{hex} primitive@>
18559 mp_primitive(mp, "ASCII",unary,ASCII_op);
18560 @:ASCII_}{\&{ASCII} primitive@>
18561 mp_primitive(mp, "char",unary,char_op);
18562 @:char_}{\&{char} primitive@>
18563 mp_primitive(mp, "length",unary,length_op);
18564 @:length_}{\&{length} primitive@>
18565 mp_primitive(mp, "turningnumber",unary,turning_op);
18566 @:turning_number_}{\&{turningnumber} primitive@>
18567 mp_primitive(mp, "xpart",unary,x_part);
18568 @:x_part_}{\&{xpart} primitive@>
18569 mp_primitive(mp, "ypart",unary,y_part);
18570 @:y_part_}{\&{ypart} primitive@>
18571 mp_primitive(mp, "xxpart",unary,xx_part);
18572 @:xx_part_}{\&{xxpart} primitive@>
18573 mp_primitive(mp, "xypart",unary,xy_part);
18574 @:xy_part_}{\&{xypart} primitive@>
18575 mp_primitive(mp, "yxpart",unary,yx_part);
18576 @:yx_part_}{\&{yxpart} primitive@>
18577 mp_primitive(mp, "yypart",unary,yy_part);
18578 @:yy_part_}{\&{yypart} primitive@>
18579 mp_primitive(mp, "redpart",unary,red_part);
18580 @:red_part_}{\&{redpart} primitive@>
18581 mp_primitive(mp, "greenpart",unary,green_part);
18582 @:green_part_}{\&{greenpart} primitive@>
18583 mp_primitive(mp, "bluepart",unary,blue_part);
18584 @:blue_part_}{\&{bluepart} primitive@>
18585 mp_primitive(mp, "cyanpart",unary,cyan_part);
18586 @:cyan_part_}{\&{cyanpart} primitive@>
18587 mp_primitive(mp, "magentapart",unary,magenta_part);
18588 @:magenta_part_}{\&{magentapart} primitive@>
18589 mp_primitive(mp, "yellowpart",unary,yellow_part);
18590 @:yellow_part_}{\&{yellowpart} primitive@>
18591 mp_primitive(mp, "blackpart",unary,black_part);
18592 @:black_part_}{\&{blackpart} primitive@>
18593 mp_primitive(mp, "greypart",unary,grey_part);
18594 @:grey_part_}{\&{greypart} primitive@>
18595 mp_primitive(mp, "colormodel",unary,color_model_part);
18596 @:color_model_part_}{\&{colormodel} primitive@>
18597 mp_primitive(mp, "fontpart",unary,font_part);
18598 @:font_part_}{\&{fontpart} primitive@>
18599 mp_primitive(mp, "textpart",unary,text_part);
18600 @:text_part_}{\&{textpart} primitive@>
18601 mp_primitive(mp, "pathpart",unary,path_part);
18602 @:path_part_}{\&{pathpart} primitive@>
18603 mp_primitive(mp, "penpart",unary,pen_part);
18604 @:pen_part_}{\&{penpart} primitive@>
18605 mp_primitive(mp, "dashpart",unary,dash_part);
18606 @:dash_part_}{\&{dashpart} primitive@>
18607 mp_primitive(mp, "sqrt",unary,sqrt_op);
18608 @:sqrt_}{\&{sqrt} primitive@>
18609 mp_primitive(mp, "mexp",unary,m_exp_op);
18610 @:m_exp_}{\&{mexp} primitive@>
18611 mp_primitive(mp, "mlog",unary,m_log_op);
18612 @:m_log_}{\&{mlog} primitive@>
18613 mp_primitive(mp, "sind",unary,sin_d_op);
18614 @:sin_d_}{\&{sind} primitive@>
18615 mp_primitive(mp, "cosd",unary,cos_d_op);
18616 @:cos_d_}{\&{cosd} primitive@>
18617 mp_primitive(mp, "floor",unary,floor_op);
18618 @:floor_}{\&{floor} primitive@>
18619 mp_primitive(mp, "uniformdeviate",unary,uniform_deviate);
18620 @:uniform_deviate_}{\&{uniformdeviate} primitive@>
18621 mp_primitive(mp, "charexists",unary,char_exists_op);
18622 @:char_exists_}{\&{charexists} primitive@>
18623 mp_primitive(mp, "fontsize",unary,font_size);
18624 @:font_size_}{\&{fontsize} primitive@>
18625 mp_primitive(mp, "llcorner",unary,ll_corner_op);
18626 @:ll_corner_}{\&{llcorner} primitive@>
18627 mp_primitive(mp, "lrcorner",unary,lr_corner_op);
18628 @:lr_corner_}{\&{lrcorner} primitive@>
18629 mp_primitive(mp, "ulcorner",unary,ul_corner_op);
18630 @:ul_corner_}{\&{ulcorner} primitive@>
18631 mp_primitive(mp, "urcorner",unary,ur_corner_op);
18632 @:ur_corner_}{\&{urcorner} primitive@>
18633 mp_primitive(mp, "arclength",unary,arc_length);
18634 @:arc_length_}{\&{arclength} primitive@>
18635 mp_primitive(mp, "angle",unary,angle_op);
18636 @:angle_}{\&{angle} primitive@>
18637 mp_primitive(mp, "cycle",cycle,cycle_op);
18638 @:cycle_}{\&{cycle} primitive@>
18639 mp_primitive(mp, "stroked",unary,stroked_op);
18640 @:stroked_}{\&{stroked} primitive@>
18641 mp_primitive(mp, "filled",unary,filled_op);
18642 @:filled_}{\&{filled} primitive@>
18643 mp_primitive(mp, "textual",unary,textual_op);
18644 @:textual_}{\&{textual} primitive@>
18645 mp_primitive(mp, "clipped",unary,clipped_op);
18646 @:clipped_}{\&{clipped} primitive@>
18647 mp_primitive(mp, "bounded",unary,bounded_op);
18648 @:bounded_}{\&{bounded} primitive@>
18649 mp_primitive(mp, "+",plus_or_minus,plus);
18650 @:+ }{\.{+} primitive@>
18651 mp_primitive(mp, "-",plus_or_minus,minus);
18652 @:- }{\.{-} primitive@>
18653 mp_primitive(mp, "*",secondary_binary,times);
18654 @:* }{\.{*} primitive@>
18655 mp_primitive(mp, "/",slash,over); mp->eqtb[frozen_slash]=mp->eqtb[mp->cur_sym];
18656 @:/ }{\.{/} primitive@>
18657 mp_primitive(mp, "++",tertiary_binary,pythag_add);
18658 @:++_}{\.{++} primitive@>
18659 mp_primitive(mp, "+-+",tertiary_binary,pythag_sub);
18660 @:+-+_}{\.{+-+} primitive@>
18661 mp_primitive(mp, "or",tertiary_binary,or_op);
18662 @:or_}{\&{or} primitive@>
18663 mp_primitive(mp, "and",and_command,and_op);
18664 @:and_}{\&{and} primitive@>
18665 mp_primitive(mp, "<",expression_binary,less_than);
18666 @:< }{\.{<} primitive@>
18667 mp_primitive(mp, "<=",expression_binary,less_or_equal);
18668 @:<=_}{\.{<=} primitive@>
18669 mp_primitive(mp, ">",expression_binary,greater_than);
18670 @:> }{\.{>} primitive@>
18671 mp_primitive(mp, ">=",expression_binary,greater_or_equal);
18672 @:>=_}{\.{>=} primitive@>
18673 mp_primitive(mp, "=",equals,equal_to);
18674 @:= }{\.{=} primitive@>
18675 mp_primitive(mp, "<>",expression_binary,unequal_to);
18676 @:<>_}{\.{<>} primitive@>
18677 mp_primitive(mp, "substring",primary_binary,substring_of);
18678 @:substring_}{\&{substring} primitive@>
18679 mp_primitive(mp, "subpath",primary_binary,subpath_of);
18680 @:subpath_}{\&{subpath} primitive@>
18681 mp_primitive(mp, "directiontime",primary_binary,direction_time_of);
18682 @:direction_time_}{\&{directiontime} primitive@>
18683 mp_primitive(mp, "point",primary_binary,point_of);
18684 @:point_}{\&{point} primitive@>
18685 mp_primitive(mp, "precontrol",primary_binary,precontrol_of);
18686 @:precontrol_}{\&{precontrol} primitive@>
18687 mp_primitive(mp, "postcontrol",primary_binary,postcontrol_of);
18688 @:postcontrol_}{\&{postcontrol} primitive@>
18689 mp_primitive(mp, "penoffset",primary_binary,pen_offset_of);
18690 @:pen_offset_}{\&{penoffset} primitive@>
18691 mp_primitive(mp, "arctime",primary_binary,arc_time_of);
18692 @:arc_time_of_}{\&{arctime} primitive@>
18693 mp_primitive(mp, "mpversion",nullary,mp_version);
18694 @:mp_verison_}{\&{mpversion} primitive@>
18695 mp_primitive(mp, "&",ampersand,concatenate);
18696 @:!!!}{\.{\&} primitive@>
18697 mp_primitive(mp, "rotated",secondary_binary,rotated_by);
18698 @:rotated_}{\&{rotated} primitive@>
18699 mp_primitive(mp, "slanted",secondary_binary,slanted_by);
18700 @:slanted_}{\&{slanted} primitive@>
18701 mp_primitive(mp, "scaled",secondary_binary,scaled_by);
18702 @:scaled_}{\&{scaled} primitive@>
18703 mp_primitive(mp, "shifted",secondary_binary,shifted_by);
18704 @:shifted_}{\&{shifted} primitive@>
18705 mp_primitive(mp, "transformed",secondary_binary,transformed_by);
18706 @:transformed_}{\&{transformed} primitive@>
18707 mp_primitive(mp, "xscaled",secondary_binary,x_scaled);
18708 @:x_scaled_}{\&{xscaled} primitive@>
18709 mp_primitive(mp, "yscaled",secondary_binary,y_scaled);
18710 @:y_scaled_}{\&{yscaled} primitive@>
18711 mp_primitive(mp, "zscaled",secondary_binary,z_scaled);
18712 @:z_scaled_}{\&{zscaled} primitive@>
18713 mp_primitive(mp, "infont",secondary_binary,in_font);
18714 @:in_font_}{\&{infont} primitive@>
18715 mp_primitive(mp, "intersectiontimes",tertiary_binary,intersect);
18716 @:intersection_times_}{\&{intersectiontimes} primitive@>
18717 mp_primitive(mp, "envelope",primary_binary,envelope_of);
18718 @:envelope_}{\&{envelope} primitive@>
18720 @ @<Cases of |print_cmd...@>=
18723 case primary_binary:
18724 case secondary_binary:
18725 case tertiary_binary:
18726 case expression_binary:
18728 case plus_or_minus:
18733 mp_print_op(mp, m);
18736 @ OK, let's look at the simplest \\{do} procedure first.
18738 @c @<Declare nullary action procedure@>
18739 void mp_do_nullary (MP mp,quarterword c) {
18741 if ( mp->internal[mp_tracing_commands]>two )
18742 mp_show_cmd_mod(mp, nullary,c);
18744 case true_code: case false_code:
18745 mp->cur_type=mp_boolean_type; mp->cur_exp=c;
18747 case null_picture_code:
18748 mp->cur_type=mp_picture_type;
18749 mp->cur_exp=mp_get_node(mp, edge_header_size);
18750 mp_init_edges(mp, mp->cur_exp);
18752 case null_pen_code:
18753 mp->cur_type=mp_pen_type; mp->cur_exp=mp_get_pen_circle(mp, 0);
18755 case normal_deviate:
18756 mp->cur_type=mp_known; mp->cur_exp=mp_norm_rand(mp);
18759 mp->cur_type=mp_pen_type; mp->cur_exp=mp_get_pen_circle(mp, unity);
18762 if ( mp->job_name==NULL ) mp_open_log_file(mp);
18763 mp->cur_type=mp_string_type; mp->cur_exp=rts(mp->job_name);
18766 mp->cur_type=mp_string_type;
18767 mp->cur_exp=intern(metapost_version) ;
18769 case read_string_op:
18770 @<Read a string from the terminal@>;
18772 } /* there are no other cases */
18776 @ @<Read a string...@>=
18778 if ( mp->interaction<=mp_nonstop_mode )
18779 mp_fatal_error(mp, "*** (cannot readstring in nonstop modes)");
18780 mp_begin_file_reading(mp); name=is_read;
18781 limit=start; prompt_input("");
18782 mp_finish_read(mp);
18785 @ @<Declare nullary action procedure@>=
18786 void mp_finish_read (MP mp) { /* copy |buffer| line to |cur_exp| */
18788 str_room((int)mp->last-start);
18789 for (k=start;k<=mp->last-1;k++) {
18790 append_char(mp->buffer[k]);
18792 mp_end_file_reading(mp); mp->cur_type=mp_string_type;
18793 mp->cur_exp=mp_make_string(mp);
18796 @ Things get a bit more interesting when there's an operand. The
18797 operand to |do_unary| appears in |cur_type| and |cur_exp|.
18799 @c @<Declare unary action procedures@>
18800 void mp_do_unary (MP mp,quarterword c) {
18801 pointer p,q,r; /* for list manipulation */
18802 integer x; /* a temporary register */
18804 if ( mp->internal[mp_tracing_commands]>two )
18805 @<Trace the current unary operation@>;
18808 if ( mp->cur_type<mp_color_type ) mp_bad_unary(mp, plus);
18811 @<Negate the current expression@>;
18813 @<Additional cases of unary operators@>;
18814 } /* there are no other cases */
18818 @ The |nice_pair| function returns |true| if both components of a pair
18821 @<Declare unary action procedures@>=
18822 boolean mp_nice_pair (MP mp,integer p, quarterword t) {
18823 if ( t==mp_pair_type ) {
18825 if ( type(x_part_loc(p))==mp_known )
18826 if ( type(y_part_loc(p))==mp_known )
18832 @ The |nice_color_or_pair| function is analogous except that it also accepts
18833 fully known colors.
18835 @<Declare unary action procedures@>=
18836 boolean mp_nice_color_or_pair (MP mp,integer p, quarterword t) {
18837 pointer q,r; /* for scanning the big node */
18838 if ( (t!=mp_pair_type)&&(t!=mp_color_type)&&(t!=mp_cmykcolor_type) ) {
18842 r=q+mp->big_node_size[type(p)];
18845 if ( type(r)!=mp_known )
18852 @ @<Declare unary action...@>=
18853 void mp_print_known_or_unknown_type (MP mp,small_number t, integer v) {
18854 mp_print_char(mp, '(');
18855 if ( t>mp_known ) mp_print(mp, "unknown numeric");
18856 else { if ( (t==mp_pair_type)||(t==mp_color_type)||(t==mp_cmykcolor_type) )
18857 if ( ! mp_nice_color_or_pair(mp, v,t) ) mp_print(mp, "unknown ");
18858 mp_print_type(mp, t);
18860 mp_print_char(mp, ')');
18863 @ @<Declare unary action...@>=
18864 void mp_bad_unary (MP mp,quarterword c) {
18865 exp_err("Not implemented: "); mp_print_op(mp, c);
18866 @.Not implemented...@>
18867 mp_print_known_or_unknown_type(mp, mp->cur_type,mp->cur_exp);
18868 help3("I'm afraid I don't know how to apply that operation to that")
18869 ("particular type. Continue, and I'll simply return the")
18870 ("argument (shown above) as the result of the operation.");
18871 mp_put_get_error(mp);
18874 @ @<Trace the current unary operation@>=
18876 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
18877 mp_print_op(mp, c); mp_print_char(mp, '(');
18878 mp_print_exp(mp, null,0); /* show the operand, but not verbosely */
18879 mp_print(mp, ")}"); mp_end_diagnostic(mp, false);
18882 @ Negation is easy except when the current expression
18883 is of type |independent|, or when it is a pair with one or more
18884 |independent| components.
18886 It is tempting to argue that the negative of an independent variable
18887 is an independent variable, hence we don't have to do anything when
18888 negating it. The fallacy is that other dependent variables pointing
18889 to the current expression must change the sign of their
18890 coefficients if we make no change to the current expression.
18892 Instead, we work around the problem by copying the current expression
18893 and recycling it afterwards (cf.~the |stash_in| routine).
18895 @<Negate the current expression@>=
18896 switch (mp->cur_type) {
18897 case mp_color_type:
18898 case mp_cmykcolor_type:
18900 case mp_independent:
18901 q=mp->cur_exp; mp_make_exp_copy(mp, q);
18902 if ( mp->cur_type==mp_dependent ) {
18903 mp_negate_dep_list(mp, dep_list(mp->cur_exp));
18904 } else if ( mp->cur_type<=mp_pair_type ) { /* |mp_color_type| or |mp_pair_type| */
18905 p=value(mp->cur_exp);
18906 r=p+mp->big_node_size[mp->cur_type];
18909 if ( type(r)==mp_known ) negate(value(r));
18910 else mp_negate_dep_list(mp, dep_list(r));
18912 } /* if |cur_type=mp_known| then |cur_exp=0| */
18913 mp_recycle_value(mp, q); mp_free_node(mp, q,value_node_size);
18916 case mp_proto_dependent:
18917 mp_negate_dep_list(mp, dep_list(mp->cur_exp));
18920 negate(mp->cur_exp);
18923 mp_bad_unary(mp, minus);
18927 @ @<Declare unary action...@>=
18928 void mp_negate_dep_list (MP mp,pointer p) {
18931 if ( info(p)==null ) return;
18936 @ @<Additional cases of unary operators@>=
18938 if ( mp->cur_type!=mp_boolean_type ) mp_bad_unary(mp, not_op);
18939 else mp->cur_exp=true_code+false_code-mp->cur_exp;
18942 @ @d three_sixty_units 23592960 /* that's |360*unity| */
18943 @d boolean_reset(A) if ( (A) ) mp->cur_exp=true_code; else mp->cur_exp=false_code
18945 @<Additional cases of unary operators@>=
18952 case uniform_deviate:
18954 case char_exists_op:
18955 if ( mp->cur_type!=mp_known ) {
18956 mp_bad_unary(mp, c);
18959 case sqrt_op:mp->cur_exp=mp_square_rt(mp, mp->cur_exp);break;
18960 case m_exp_op:mp->cur_exp=mp_m_exp(mp, mp->cur_exp);break;
18961 case m_log_op:mp->cur_exp=mp_m_log(mp, mp->cur_exp);break;
18964 mp_n_sin_cos(mp, (mp->cur_exp % three_sixty_units)*16);
18965 if ( c==sin_d_op ) mp->cur_exp=mp_round_fraction(mp, mp->n_sin);
18966 else mp->cur_exp=mp_round_fraction(mp, mp->n_cos);
18968 case floor_op:mp->cur_exp=mp_floor_scaled(mp, mp->cur_exp);break;
18969 case uniform_deviate:mp->cur_exp=mp_unif_rand(mp, mp->cur_exp);break;
18971 boolean_reset(odd(mp_round_unscaled(mp, mp->cur_exp)));
18972 mp->cur_type=mp_boolean_type;
18974 case char_exists_op:
18975 @<Determine if a character has been shipped out@>;
18977 } /* there are no other cases */
18981 @ @<Additional cases of unary operators@>=
18983 if ( mp_nice_pair(mp, mp->cur_exp,mp->cur_type) ) {
18984 p=value(mp->cur_exp);
18985 x=mp_n_arg(mp, value(x_part_loc(p)),value(y_part_loc(p)));
18986 if ( x>=0 ) mp_flush_cur_exp(mp, (x+8)/ 16);
18987 else mp_flush_cur_exp(mp, -((-x+8)/ 16));
18989 mp_bad_unary(mp, angle_op);
18993 @ If the current expression is a pair, but the context wants it to
18994 be a path, we call |pair_to_path|.
18996 @<Declare unary action...@>=
18997 void mp_pair_to_path (MP mp) {
18998 mp->cur_exp=mp_new_knot(mp);
18999 mp->cur_type=mp_path_type;
19003 @d pict_color_type(A) ((link(dummy_loc(mp->cur_exp))!=null) &&
19004 (has_color(link(dummy_loc(mp->cur_exp)))) &&
19005 ((color_model(link(dummy_loc(mp->cur_exp)))==A)
19007 ((color_model(link(dummy_loc(mp->cur_exp)))==mp_uninitialized_model) &&
19008 (mp->internal[mp_default_color_model]/unity)==(A))))
19010 @<Additional cases of unary operators@>=
19013 if ( (mp->cur_type==mp_pair_type)||(mp->cur_type==mp_transform_type) )
19014 mp_take_part(mp, c);
19015 else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
19016 else mp_bad_unary(mp, c);
19022 if ( mp->cur_type==mp_transform_type ) mp_take_part(mp, c);
19023 else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
19024 else mp_bad_unary(mp, c);
19029 if ( mp->cur_type==mp_color_type ) mp_take_part(mp, c);
19030 else if ( mp->cur_type==mp_picture_type ) {
19031 if pict_color_type(mp_rgb_model) mp_take_pict_part(mp, c);
19032 else mp_bad_color_part(mp, c);
19034 else mp_bad_unary(mp, c);
19040 if ( mp->cur_type==mp_cmykcolor_type) mp_take_part(mp, c);
19041 else if ( mp->cur_type==mp_picture_type ) {
19042 if pict_color_type(mp_cmyk_model) mp_take_pict_part(mp, c);
19043 else mp_bad_color_part(mp, c);
19045 else mp_bad_unary(mp, c);
19048 if ( mp->cur_type==mp_known ) mp->cur_exp=value(c);
19049 else if ( mp->cur_type==mp_picture_type ) {
19050 if pict_color_type(mp_grey_model) mp_take_pict_part(mp, c);
19051 else mp_bad_color_part(mp, c);
19053 else mp_bad_unary(mp, c);
19055 case color_model_part:
19056 if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
19057 else mp_bad_unary(mp, c);
19060 @ @<Declarations@>=
19061 void mp_bad_color_part(MP mp, quarterword c);
19064 void mp_bad_color_part(MP mp, quarterword c) {
19065 pointer p; /* the big node */
19066 p=link(dummy_loc(mp->cur_exp));
19067 exp_err("Wrong picture color model: "); mp_print_op(mp, c);
19068 @.Wrong picture color model...@>
19069 if (color_model(p)==mp_grey_model)
19070 mp_print(mp, " of grey object");
19071 else if (color_model(p)==mp_cmyk_model)
19072 mp_print(mp, " of cmyk object");
19073 else if (color_model(p)==mp_rgb_model)
19074 mp_print(mp, " of rgb object");
19075 else if (color_model(p)==mp_no_model)
19076 mp_print(mp, " of marking object");
19078 mp_print(mp," of defaulted object");
19079 help3("You can only ask for the redpart, greenpart, bluepart of a rgb object,")
19080 ("the cyanpart, magentapart, yellowpart or blackpart of a cmyk object, ")
19081 ("or the greypart of a grey object. No mixing and matching, please.");
19084 mp_flush_cur_exp(mp,unity);
19086 mp_flush_cur_exp(mp,0);
19089 @ In the following procedure, |cur_exp| points to a capsule, which points to
19090 a big node. We want to delete all but one part of the big node.
19092 @<Declare unary action...@>=
19093 void mp_take_part (MP mp,quarterword c) {
19094 pointer p; /* the big node */
19095 p=value(mp->cur_exp); value(temp_val)=p; type(temp_val)=mp->cur_type;
19096 link(p)=temp_val; mp_free_node(mp, mp->cur_exp,value_node_size);
19097 mp_make_exp_copy(mp, p+mp->sector_offset[c+mp_x_part_sector-x_part]);
19098 mp_recycle_value(mp, temp_val);
19101 @ @<Initialize table entries...@>=
19102 name_type(temp_val)=mp_capsule;
19104 @ @<Additional cases of unary operators@>=
19110 if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
19111 else mp_bad_unary(mp, c);
19114 @ @<Declarations@>=
19115 void mp_scale_edges (MP mp);
19117 @ @<Declare unary action...@>=
19118 void mp_take_pict_part (MP mp,quarterword c) {
19119 pointer p; /* first graphical object in |cur_exp| */
19120 p=link(dummy_loc(mp->cur_exp));
19123 case x_part: case y_part: case xx_part:
19124 case xy_part: case yx_part: case yy_part:
19125 if ( type(p)==mp_text_code ) mp_flush_cur_exp(mp, text_trans_part(p+c));
19126 else goto NOT_FOUND;
19128 case red_part: case green_part: case blue_part:
19129 if ( has_color(p) ) mp_flush_cur_exp(mp, obj_color_part(p+c));
19130 else goto NOT_FOUND;
19132 case cyan_part: case magenta_part: case yellow_part:
19134 if ( has_color(p) ) {
19135 if ( color_model(p)==mp_uninitialized_model && c==black_part)
19136 mp_flush_cur_exp(mp, unity);
19138 mp_flush_cur_exp(mp, obj_color_part(p+c+(red_part-cyan_part)));
19139 } else goto NOT_FOUND;
19142 if ( has_color(p) )
19143 mp_flush_cur_exp(mp, obj_color_part(p+c+(red_part-grey_part)));
19144 else goto NOT_FOUND;
19146 case color_model_part:
19147 if ( has_color(p) ) {
19148 if ( color_model(p)==mp_uninitialized_model )
19149 mp_flush_cur_exp(mp, mp->internal[mp_default_color_model]);
19151 mp_flush_cur_exp(mp, color_model(p)*unity);
19152 } else goto NOT_FOUND;
19154 @<Handle other cases in |take_pict_part| or |goto not_found|@>;
19155 } /* all cases have been enumerated */
19159 @<Convert the current expression to a null value appropriate
19163 @ @<Handle other cases in |take_pict_part| or |goto not_found|@>=
19165 if ( type(p)!=mp_text_code ) goto NOT_FOUND;
19167 mp_flush_cur_exp(mp, text_p(p));
19168 add_str_ref(mp->cur_exp);
19169 mp->cur_type=mp_string_type;
19173 if ( type(p)!=mp_text_code ) goto NOT_FOUND;
19175 mp_flush_cur_exp(mp, rts(mp->font_name[font_n(p)]));
19176 add_str_ref(mp->cur_exp);
19177 mp->cur_type=mp_string_type;
19181 if ( type(p)==mp_text_code ) goto NOT_FOUND;
19182 else if ( is_stop(p) ) mp_confusion(mp, "pict");
19183 @:this can't happen pict}{\quad pict@>
19185 mp_flush_cur_exp(mp, mp_copy_path(mp, path_p(p)));
19186 mp->cur_type=mp_path_type;
19190 if ( ! has_pen(p) ) goto NOT_FOUND;
19192 if ( pen_p(p)==null ) goto NOT_FOUND;
19193 else { mp_flush_cur_exp(mp, copy_pen(pen_p(p)));
19194 mp->cur_type=mp_pen_type;
19199 if ( type(p)!=mp_stroked_code ) goto NOT_FOUND;
19200 else { if ( dash_p(p)==null ) goto NOT_FOUND;
19201 else { add_edge_ref(dash_p(p));
19202 mp->se_sf=dash_scale(p);
19203 mp->se_pic=dash_p(p);
19204 mp_scale_edges(mp);
19205 mp_flush_cur_exp(mp, mp->se_pic);
19206 mp->cur_type=mp_picture_type;
19211 @ Since |scale_edges| had to be declared |forward|, it had to be declared as a
19212 parameterless procedure even though it really takes two arguments and updates
19213 one of them. Hence the following globals are needed.
19216 pointer se_pic; /* edge header used and updated by |scale_edges| */
19217 scaled se_sf; /* the scale factor argument to |scale_edges| */
19219 @ @<Convert the current expression to a null value appropriate...@>=
19221 case text_part: case font_part:
19222 mp_flush_cur_exp(mp, rts(""));
19223 mp->cur_type=mp_string_type;
19226 mp_flush_cur_exp(mp, mp_get_node(mp, knot_node_size));
19227 left_type(mp->cur_exp)=mp_endpoint;
19228 right_type(mp->cur_exp)=mp_endpoint;
19229 link(mp->cur_exp)=mp->cur_exp;
19230 x_coord(mp->cur_exp)=0;
19231 y_coord(mp->cur_exp)=0;
19232 originator(mp->cur_exp)=mp_metapost_user;
19233 mp->cur_type=mp_path_type;
19236 mp_flush_cur_exp(mp, mp_get_pen_circle(mp, 0));
19237 mp->cur_type=mp_pen_type;
19240 mp_flush_cur_exp(mp, mp_get_node(mp, edge_header_size));
19241 mp_init_edges(mp, mp->cur_exp);
19242 mp->cur_type=mp_picture_type;
19245 mp_flush_cur_exp(mp, 0);
19249 @ @<Additional cases of unary...@>=
19251 if ( mp->cur_type!=mp_known ) {
19252 mp_bad_unary(mp, char_op);
19254 mp->cur_exp=mp_round_unscaled(mp, mp->cur_exp) % 256;
19255 mp->cur_type=mp_string_type;
19256 if ( mp->cur_exp<0 ) mp->cur_exp=mp->cur_exp+256;
19260 if ( mp->cur_type!=mp_known ) {
19261 mp_bad_unary(mp, decimal);
19263 mp->old_setting=mp->selector; mp->selector=new_string;
19264 mp_print_scaled(mp, mp->cur_exp); mp->cur_exp=mp_make_string(mp);
19265 mp->selector=mp->old_setting; mp->cur_type=mp_string_type;
19271 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, c);
19272 else mp_str_to_num(mp, c);
19275 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, font_size);
19276 else @<Find the design size of the font whose name is |cur_exp|@>;
19279 @ @<Declare unary action...@>=
19280 void mp_str_to_num (MP mp,quarterword c) { /* converts a string to a number */
19281 integer n; /* accumulator */
19282 ASCII_code m; /* current character */
19283 pool_pointer k; /* index into |str_pool| */
19284 int b; /* radix of conversion */
19285 boolean bad_char; /* did the string contain an invalid digit? */
19286 if ( c==ASCII_op ) {
19287 if ( length(mp->cur_exp)==0 ) n=-1;
19288 else n=mp->str_pool[mp->str_start[mp->cur_exp]];
19290 if ( c==oct_op ) b=8; else b=16;
19291 n=0; bad_char=false;
19292 for (k=mp->str_start[mp->cur_exp];k<=str_stop(mp->cur_exp)-1;k++) {
19294 if ( (m>='0')&&(m<='9') ) m=m-'0';
19295 else if ( (m>='A')&&(m<='F') ) m=m-'A'+10;
19296 else if ( (m>='a')&&(m<='f') ) m=m-'a'+10;
19297 else { bad_char=true; m=0; };
19298 if ( m>=b ) { bad_char=true; m=0; };
19299 if ( n<32768 / b ) n=n*b+m; else n=32767;
19301 @<Give error messages if |bad_char| or |n>=4096|@>;
19303 mp_flush_cur_exp(mp, n*unity);
19306 @ @<Give error messages if |bad_char|...@>=
19308 exp_err("String contains illegal digits");
19309 @.String contains illegal digits@>
19311 help1("I zeroed out characters that weren't in the range 0..7.");
19313 help1("I zeroed out characters that weren't hex digits.");
19315 mp_put_get_error(mp);
19318 if ( mp->internal[mp_warning_check]>0 ) {
19319 print_err("Number too large (");
19320 mp_print_int(mp, n); mp_print_char(mp, ')');
19321 @.Number too large@>
19322 help2("I have trouble with numbers greater than 4095; watch out.")
19323 ("(Set warningcheck:=0 to suppress this message.)");
19324 mp_put_get_error(mp);
19328 @ The length operation is somewhat unusual in that it applies to a variety
19329 of different types of operands.
19331 @<Additional cases of unary...@>=
19333 switch (mp->cur_type) {
19334 case mp_string_type: mp_flush_cur_exp(mp, length(mp->cur_exp)*unity); break;
19335 case mp_path_type: mp_flush_cur_exp(mp, mp_path_length(mp)); break;
19336 case mp_known: mp->cur_exp=abs(mp->cur_exp); break;
19337 case mp_picture_type: mp_flush_cur_exp(mp, mp_pict_length(mp)); break;
19339 if ( mp_nice_pair(mp, mp->cur_exp,mp->cur_type) )
19340 mp_flush_cur_exp(mp, mp_pyth_add(mp,
19341 value(x_part_loc(value(mp->cur_exp))),
19342 value(y_part_loc(value(mp->cur_exp)))));
19343 else mp_bad_unary(mp, c);
19348 @ @<Declare unary action...@>=
19349 scaled mp_path_length (MP mp) { /* computes the length of the current path */
19350 scaled n; /* the path length so far */
19351 pointer p; /* traverser */
19353 if ( left_type(p)==mp_endpoint ) n=-unity; else n=0;
19354 do { p=link(p); n=n+unity; } while (p!=mp->cur_exp);
19358 @ @<Declare unary action...@>=
19359 scaled mp_pict_length (MP mp) {
19360 /* counts interior components in picture |cur_exp| */
19361 scaled n; /* the count so far */
19362 pointer p; /* traverser */
19364 p=link(dummy_loc(mp->cur_exp));
19366 if ( is_start_or_stop(p) )
19367 if ( mp_skip_1component(mp, p)==null ) p=link(p);
19368 while ( p!=null ) {
19369 skip_component(p) return n;
19376 @ Implement |turningnumber|
19378 @<Additional cases of unary...@>=
19380 if ( mp->cur_type==mp_pair_type ) mp_flush_cur_exp(mp, 0);
19381 else if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, turning_op);
19382 else if ( left_type(mp->cur_exp)==mp_endpoint )
19383 mp_flush_cur_exp(mp, 0); /* not a cyclic path */
19385 mp_flush_cur_exp(mp, mp_turn_cycles_wrapper(mp, mp->cur_exp));
19388 @ The function |an_angle| returns the value of the |angle| primitive, or $0$ if the
19389 argument is |origin|.
19391 @<Declare unary action...@>=
19392 angle mp_an_angle (MP mp,scaled xpar, scaled ypar) {
19393 if ( (! ((xpar==0) && (ypar==0))) )
19394 return mp_n_arg(mp, xpar,ypar);
19399 @ The actual turning number is (for the moment) computed in a C function
19400 that receives eight integers corresponding to the four controlling points,
19401 and returns a single angle. Besides those, we have to account for discrete
19402 moves at the actual points.
19404 @d floor(a) (a>=0 ? a : -(int)(-a))
19405 @d bezier_error (720<<20)+1
19406 @d sign(v) ((v)>0 ? 1 : ((v)<0 ? -1 : 0 ))
19408 @d out ((double)(xo>>20))
19409 @d mid ((double)(xm>>20))
19410 @d in ((double)(xi>>20))
19411 @d divisor (256*256)
19412 @d double2angle(a) (int)floor(a*256.0*256.0*16.0)
19414 @<Declare unary action...@>=
19415 angle mp_bezier_slope(MP mp, integer AX,integer AY,integer BX,integer BY,
19416 integer CX,integer CY,integer DX,integer DY);
19419 angle mp_bezier_slope(MP mp, integer AX,integer AY,integer BX,integer BY,
19420 integer CX,integer CY,integer DX,integer DY) {
19422 integer deltax,deltay;
19423 double ax,ay,bx,by,cx,cy,dx,dy;
19424 angle xi = 0, xo = 0, xm = 0;
19426 ax=AX/divisor; ay=AY/divisor;
19427 bx=BX/divisor; by=BY/divisor;
19428 cx=CX/divisor; cy=CY/divisor;
19429 dx=DX/divisor; dy=DY/divisor;
19431 deltax = (BX-AX); deltay = (BY-AY);
19432 if (deltax==0 && deltay == 0) { deltax=(CX-AX); deltay=(CY-AY); }
19433 if (deltax==0 && deltay == 0) { deltax=(DX-AX); deltay=(DY-AY); }
19434 xi = mp_an_angle(mp,deltax,deltay);
19436 deltax = (CX-BX); deltay = (CY-BY);
19437 xm = mp_an_angle(mp,deltax,deltay);
19439 deltax = (DX-CX); deltay = (DY-CY);
19440 if (deltax==0 && deltay == 0) { deltax=(DX-BX); deltay=(DY-BY); }
19441 if (deltax==0 && deltay == 0) { deltax=(DX-AX); deltay=(DY-AY); }
19442 xo = mp_an_angle(mp,deltax,deltay);
19444 a = (bx-ax)*(cy-by) - (cx-bx)*(by-ay); /* a = (bp-ap)x(cp-bp); */
19445 b = (bx-ax)*(dy-cy) - (by-ay)*(dx-cx);; /* b = (bp-ap)x(dp-cp);*/
19446 c = (cx-bx)*(dy-cy) - (dx-cx)*(cy-by); /* c = (cp-bp)x(dp-cp);*/
19448 if ((a==0)&&(c==0)) {
19449 res = (b==0 ? 0 : (out-in));
19450 print_roots("no roots (a)");
19451 } else if ((a==0)||(c==0)) {
19452 if ((sign(b) == sign(a)) || (sign(b) == sign(c))) {
19453 res = out-in; /* ? */
19456 else if (res>180.0)
19458 print_roots("no roots (b)");
19460 res = out-in; /* ? */
19461 print_roots("one root (a)");
19463 } else if ((sign(a)*sign(c))<0) {
19464 res = out-in; /* ? */
19467 else if (res>180.0)
19469 print_roots("one root (b)");
19471 if (sign(a) == sign(b)) {
19472 res = out-in; /* ? */
19475 else if (res>180.0)
19477 print_roots("no roots (d)");
19479 if ((b*b) == (4*a*c)) {
19480 res = bezier_error;
19481 print_roots("double root"); /* cusp */
19482 } else if ((b*b) < (4*a*c)) {
19483 res = out-in; /* ? */
19484 if (res<=0.0 &&res>-180.0)
19486 else if (res>=0.0 && res<180.0)
19488 print_roots("no roots (e)");
19493 else if (res>180.0)
19495 print_roots("two roots"); /* two inflections */
19499 return double2angle(res);
19503 @d p_nextnext link(link(p))
19505 @d seven_twenty_deg 05500000000 /* $720\cdot2^{20}$, represents $720^\circ$ */
19507 @<Declare unary action...@>=
19508 scaled mp_new_turn_cycles (MP mp,pointer c) {
19509 angle res,ang; /* the angles of intermediate results */
19510 scaled turns; /* the turn counter */
19511 pointer p; /* for running around the path */
19512 integer xp,yp; /* coordinates of next point */
19513 integer x,y; /* helper coordinates */
19514 angle in_angle,out_angle; /* helper angles */
19515 int old_setting; /* saved |selector| setting */
19519 old_setting = mp->selector; mp->selector=term_only;
19520 if ( mp->internal[mp_tracing_commands]>unity ) {
19521 mp_begin_diagnostic(mp);
19522 mp_print_nl(mp, "");
19523 mp_end_diagnostic(mp, false);
19526 xp = x_coord(p_next); yp = y_coord(p_next);
19527 ang = mp_bezier_slope(mp,x_coord(p), y_coord(p), right_x(p), right_y(p),
19528 left_x(p_next), left_y(p_next), xp, yp);
19529 if ( ang>seven_twenty_deg ) {
19530 print_err("Strange path");
19532 mp->selector=old_setting;
19536 if ( res > one_eighty_deg ) {
19537 res = res - three_sixty_deg;
19538 turns = turns + unity;
19540 if ( res <= -one_eighty_deg ) {
19541 res = res + three_sixty_deg;
19542 turns = turns - unity;
19544 /* incoming angle at next point */
19545 x = left_x(p_next); y = left_y(p_next);
19546 if ( (xp==x)&&(yp==y) ) { x = right_x(p); y = right_y(p); };
19547 if ( (xp==x)&&(yp==y) ) { x = x_coord(p); y = y_coord(p); };
19548 in_angle = mp_an_angle(mp, xp - x, yp - y);
19549 /* outgoing angle at next point */
19550 x = right_x(p_next); y = right_y(p_next);
19551 if ( (xp==x)&&(yp==y) ) { x = left_x(p_nextnext); y = left_y(p_nextnext); };
19552 if ( (xp==x)&&(yp==y) ) { x = x_coord(p_nextnext); y = y_coord(p_nextnext); };
19553 out_angle = mp_an_angle(mp, x - xp, y- yp);
19554 ang = (out_angle - in_angle);
19558 if ( res >= one_eighty_deg ) {
19559 res = res - three_sixty_deg;
19560 turns = turns + unity;
19562 if ( res <= -one_eighty_deg ) {
19563 res = res + three_sixty_deg;
19564 turns = turns - unity;
19569 mp->selector=old_setting;
19574 @ This code is based on Bogus\l{}av Jackowski's
19575 |emergency_turningnumber| macro, with some minor changes by Taco
19576 Hoekwater. The macro code looked more like this:
19578 vardef turning\_number primary p =
19579 ~~save res, ang, turns;
19581 ~~if length p <= 2:
19582 ~~~~if Angle ((point 0 of p) - (postcontrol 0 of p)) >= 0: 1 else: -1 fi
19584 ~~~~for t = 0 upto length p-1 :
19585 ~~~~~~angc := Angle ((point t+1 of p) - (point t of p))
19586 ~~~~~~~~- Angle ((point t of p) - (point t-1 of p));
19587 ~~~~~~if angc > 180: angc := angc - 360; fi;
19588 ~~~~~~if angc < -180: angc := angc + 360; fi;
19589 ~~~~~~res := res + angc;
19594 The general idea is to calculate only the sum of the angles of
19595 straight lines between the points, of a path, not worrying about cusps
19596 or self-intersections in the segments at all. If the segment is not
19597 well-behaved, the result is not necesarily correct. But the old code
19598 was not always correct either, and worse, it sometimes failed for
19599 well-behaved paths as well. All known bugs that were triggered by the
19600 original code no longer occur with this code, and it runs roughly 3
19601 times as fast because the algorithm is much simpler.
19603 @ It is possible to overflow the return value of the |turn_cycles|
19604 function when the path is sufficiently long and winding, but I am not
19605 going to bother testing for that. In any case, it would only return
19606 the looped result value, which is not a big problem.
19608 The macro code for the repeat loop was a bit nicer to look
19609 at than the pascal code, because it could use |point -1 of p|. In
19610 pascal, the fastest way to loop around the path is not to look
19611 backward once, but forward twice. These defines help hide the trick.
19613 @d p_to link(link(p))
19617 @<Declare unary action...@>=
19618 scaled mp_turn_cycles (MP mp,pointer c) {
19619 angle res,ang; /* the angles of intermediate results */
19620 scaled turns; /* the turn counter */
19621 pointer p; /* for running around the path */
19622 res=0; turns= 0; p=c;
19624 ang = mp_an_angle (mp, x_coord(p_to) - x_coord(p_here),
19625 y_coord(p_to) - y_coord(p_here))
19626 - mp_an_angle (mp, x_coord(p_here) - x_coord(p_from),
19627 y_coord(p_here) - y_coord(p_from));
19630 if ( res >= three_sixty_deg ) {
19631 res = res - three_sixty_deg;
19632 turns = turns + unity;
19634 if ( res <= -three_sixty_deg ) {
19635 res = res + three_sixty_deg;
19636 turns = turns - unity;
19643 @ @<Declare unary action...@>=
19644 scaled mp_turn_cycles_wrapper (MP mp,pointer c) {
19646 scaled saved_t_o; /* tracing\_online saved */
19647 if ( (link(c)==c)||(link(link(c))==c) ) {
19648 if ( mp_an_angle (mp, x_coord(c) - right_x(c), y_coord(c) - right_y(c)) > 0 )
19653 nval = mp_new_turn_cycles(mp, c);
19654 oval = mp_turn_cycles(mp, c);
19655 if ( nval!=oval ) {
19656 saved_t_o=mp->internal[mp_tracing_online];
19657 mp->internal[mp_tracing_online]=unity;
19658 mp_begin_diagnostic(mp);
19659 mp_print_nl (mp, "Warning: the turningnumber algorithms do not agree."
19660 " The current computed value is ");
19661 mp_print_scaled(mp, nval);
19662 mp_print(mp, ", but the 'connect-the-dots' algorithm returned ");
19663 mp_print_scaled(mp, oval);
19664 mp_end_diagnostic(mp, false);
19665 mp->internal[mp_tracing_online]=saved_t_o;
19671 @ @<Declare unary action...@>=
19672 scaled mp_count_turns (MP mp,pointer c) {
19673 pointer p; /* a knot in envelope spec |c| */
19674 integer t; /* total pen offset changes counted */
19677 t=t+info(p)-zero_off;
19680 return ((t / 3)*unity);
19683 @ @d type_range(A,B) {
19684 if ( (mp->cur_type>=(A)) && (mp->cur_type<=(B)) )
19685 mp_flush_cur_exp(mp, true_code);
19686 else mp_flush_cur_exp(mp, false_code);
19687 mp->cur_type=mp_boolean_type;
19690 if ( mp->cur_type==(A) ) mp_flush_cur_exp(mp, true_code);
19691 else mp_flush_cur_exp(mp, false_code);
19692 mp->cur_type=mp_boolean_type;
19695 @<Additional cases of unary operators@>=
19696 case mp_boolean_type:
19697 type_range(mp_boolean_type,mp_unknown_boolean); break;
19698 case mp_string_type:
19699 type_range(mp_string_type,mp_unknown_string); break;
19701 type_range(mp_pen_type,mp_unknown_pen); break;
19703 type_range(mp_path_type,mp_unknown_path); break;
19704 case mp_picture_type:
19705 type_range(mp_picture_type,mp_unknown_picture); break;
19706 case mp_transform_type: case mp_color_type: case mp_cmykcolor_type:
19708 type_test(c); break;
19709 case mp_numeric_type:
19710 type_range(mp_known,mp_independent); break;
19711 case known_op: case unknown_op:
19712 mp_test_known(mp, c); break;
19714 @ @<Declare unary action procedures@>=
19715 void mp_test_known (MP mp,quarterword c) {
19716 int b; /* is the current expression known? */
19717 pointer p,q; /* locations in a big node */
19719 switch (mp->cur_type) {
19720 case mp_vacuous: case mp_boolean_type: case mp_string_type:
19721 case mp_pen_type: case mp_path_type: case mp_picture_type:
19725 case mp_transform_type:
19726 case mp_color_type: case mp_cmykcolor_type: case mp_pair_type:
19727 p=value(mp->cur_exp);
19728 q=p+mp->big_node_size[mp->cur_type];
19731 if ( type(q)!=mp_known )
19740 if ( c==known_op ) mp_flush_cur_exp(mp, b);
19741 else mp_flush_cur_exp(mp, true_code+false_code-b);
19742 mp->cur_type=mp_boolean_type;
19745 @ @<Additional cases of unary operators@>=
19747 if ( mp->cur_type!=mp_path_type ) mp_flush_cur_exp(mp, false_code);
19748 else if ( left_type(mp->cur_exp)!=mp_endpoint ) mp_flush_cur_exp(mp, true_code);
19749 else mp_flush_cur_exp(mp, false_code);
19750 mp->cur_type=mp_boolean_type;
19753 @ @<Additional cases of unary operators@>=
19755 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19756 if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, arc_length);
19757 else mp_flush_cur_exp(mp, mp_get_arc_length(mp, mp->cur_exp));
19760 @ Here we use the fact that |c-filled_op+fill_code| is the desired graphical
19762 @^data structure assumptions@>
19764 @<Additional cases of unary operators@>=
19770 if ( mp->cur_type!=mp_picture_type ) mp_flush_cur_exp(mp, false_code);
19771 else if ( link(dummy_loc(mp->cur_exp))==null ) mp_flush_cur_exp(mp, false_code);
19772 else if ( type(link(dummy_loc(mp->cur_exp)))==c+mp_fill_code-filled_op )
19773 mp_flush_cur_exp(mp, true_code);
19774 else mp_flush_cur_exp(mp, false_code);
19775 mp->cur_type=mp_boolean_type;
19778 @ @<Additional cases of unary operators@>=
19780 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19781 if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, make_pen_op);
19783 mp->cur_type=mp_pen_type;
19784 mp->cur_exp=mp_make_pen(mp, mp->cur_exp,true);
19788 if ( mp->cur_type!=mp_pen_type ) mp_bad_unary(mp, make_path_op);
19790 mp->cur_type=mp_path_type;
19791 mp_make_path(mp, mp->cur_exp);
19795 if ( mp->cur_type==mp_path_type ) {
19796 p=mp_htap_ypoc(mp, mp->cur_exp);
19797 if ( right_type(p)==mp_endpoint ) p=link(p);
19798 mp_toss_knot_list(mp, mp->cur_exp); mp->cur_exp=p;
19799 } else if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19800 else mp_bad_unary(mp, reverse);
19803 @ The |pair_value| routine changes the current expression to a
19804 given ordered pair of values.
19806 @<Declare unary action procedures@>=
19807 void mp_pair_value (MP mp,scaled x, scaled y) {
19808 pointer p; /* a pair node */
19809 p=mp_get_node(mp, value_node_size);
19810 mp_flush_cur_exp(mp, p); mp->cur_type=mp_pair_type;
19811 type(p)=mp_pair_type; name_type(p)=mp_capsule; mp_init_big_node(mp, p);
19813 type(x_part_loc(p))=mp_known; value(x_part_loc(p))=x;
19814 type(y_part_loc(p))=mp_known; value(y_part_loc(p))=y;
19817 @ @<Additional cases of unary operators@>=
19819 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ll_corner_op);
19820 else mp_pair_value(mp, minx,miny);
19823 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, lr_corner_op);
19824 else mp_pair_value(mp, maxx,miny);
19827 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ul_corner_op);
19828 else mp_pair_value(mp, minx,maxy);
19831 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ur_corner_op);
19832 else mp_pair_value(mp, maxx,maxy);
19835 @ Here is a function that sets |minx|, |maxx|, |miny|, |maxy| to the bounding
19836 box of the current expression. The boolean result is |false| if the expression
19837 has the wrong type.
19839 @<Declare unary action procedures@>=
19840 boolean mp_get_cur_bbox (MP mp) {
19841 switch (mp->cur_type) {
19842 case mp_picture_type:
19843 mp_set_bbox(mp, mp->cur_exp,true);
19844 if ( minx_val(mp->cur_exp)>maxx_val(mp->cur_exp) ) {
19845 minx=0; maxx=0; miny=0; maxy=0;
19847 minx=minx_val(mp->cur_exp);
19848 maxx=maxx_val(mp->cur_exp);
19849 miny=miny_val(mp->cur_exp);
19850 maxy=maxy_val(mp->cur_exp);
19854 mp_path_bbox(mp, mp->cur_exp);
19857 mp_pen_bbox(mp, mp->cur_exp);
19865 @ @<Additional cases of unary operators@>=
19867 case close_from_op:
19868 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, c);
19869 else mp_do_read_or_close(mp,c);
19872 @ Here is a routine that interprets |cur_exp| as a file name and tries to read
19873 a line from the file or to close the file.
19875 @<Declare unary action procedures@>=
19876 void mp_do_read_or_close (MP mp,quarterword c) {
19877 readf_index n,n0; /* indices for searching |rd_fname| */
19878 @<Find the |n| where |rd_fname[n]=cur_exp|; if |cur_exp| must be inserted,
19879 call |start_read_input| and |goto found| or |not_found|@>;
19880 mp_begin_file_reading(mp);
19882 if ( mp_input_ln(mp, mp->rd_file[n] ) )
19884 mp_end_file_reading(mp);
19886 @<Record the end of file and set |cur_exp| to a dummy value@>;
19889 mp_flush_cur_exp(mp, 0); mp->cur_type=mp_vacuous;
19892 mp_flush_cur_exp(mp, 0);
19893 mp_finish_read(mp);
19896 @ Free slots in the |rd_file| and |rd_fname| arrays are marked with NULL's in
19899 @<Find the |n| where |rd_fname[n]=cur_exp|...@>=
19904 fn = str(mp->cur_exp);
19905 while (mp_xstrcmp(fn,mp->rd_fname[n])!=0) {
19908 } else if ( c==close_from_op ) {
19911 if ( n0==mp->read_files ) {
19912 if ( mp->read_files<mp->max_read_files ) {
19913 incr(mp->read_files);
19918 l = mp->max_read_files + (mp->max_read_files>>2);
19919 rd_file = xmalloc((l+1), sizeof(void *));
19920 rd_fname = xmalloc((l+1), sizeof(char *));
19921 for (k=0;k<=l;k++) {
19922 if (k<=mp->max_read_files) {
19923 rd_file[k]=mp->rd_file[k];
19924 rd_fname[k]=mp->rd_fname[k];
19930 xfree(mp->rd_file); xfree(mp->rd_fname);
19931 mp->max_read_files = l;
19932 mp->rd_file = rd_file;
19933 mp->rd_fname = rd_fname;
19937 if ( mp_start_read_input(mp,fn,n) )
19942 if ( mp->rd_fname[n]==NULL ) { n0=n; }
19944 if ( c==close_from_op ) {
19945 (mp->close_file)(mp,mp->rd_file[n]);
19950 @ @<Record the end of file and set |cur_exp| to a dummy value@>=
19951 xfree(mp->rd_fname[n]);
19952 mp->rd_fname[n]=NULL;
19953 if ( n==mp->read_files-1 ) mp->read_files=n;
19954 if ( c==close_from_op )
19956 mp_flush_cur_exp(mp, mp->eof_line);
19957 mp->cur_type=mp_string_type
19959 @ The string denoting end-of-file is a one-byte string at position zero, by definition
19962 str_number eof_line;
19967 @ Finally, we have the operations that combine a capsule~|p|
19968 with the current expression.
19970 @d binary_return { mp_finish_binary(mp, old_p, old_exp); return; }
19972 @c @<Declare binary action procedures@>
19973 void mp_finish_binary (MP mp, pointer old_p, pointer old_exp ){
19975 @<Recycle any sidestepped |independent| capsules@>;
19977 void mp_do_binary (MP mp,pointer p, quarterword c) {
19978 pointer q,r,rr; /* for list manipulation */
19979 pointer old_p,old_exp; /* capsules to recycle */
19980 integer v; /* for numeric manipulation */
19982 if ( mp->internal[mp_tracing_commands]>two ) {
19983 @<Trace the current binary operation@>;
19985 @<Sidestep |independent| cases in capsule |p|@>;
19986 @<Sidestep |independent| cases in the current expression@>;
19988 case plus: case minus:
19989 @<Add or subtract the current expression from |p|@>;
19991 @<Additional cases of binary operators@>;
19992 }; /* there are no other cases */
19993 mp_recycle_value(mp, p);
19994 mp_free_node(mp, p,value_node_size); /* |return| to avoid this */
19995 mp_finish_binary(mp, old_p, old_exp);
19998 @ @<Declare binary action...@>=
19999 void mp_bad_binary (MP mp,pointer p, quarterword c) {
20000 mp_disp_err(mp, p,"");
20001 exp_err("Not implemented: ");
20002 @.Not implemented...@>
20003 if ( c>=min_of ) mp_print_op(mp, c);
20004 mp_print_known_or_unknown_type(mp, type(p),p);
20005 if ( c>=min_of ) mp_print(mp, "of"); else mp_print_op(mp, c);
20006 mp_print_known_or_unknown_type(mp, mp->cur_type,mp->cur_exp);
20007 help3("I'm afraid I don't know how to apply that operation to that")
20008 ("combination of types. Continue, and I'll return the second")
20009 ("argument (see above) as the result of the operation.");
20010 mp_put_get_error(mp);
20012 void mp_bad_envelope_pen (MP mp) {
20013 mp_disp_err(mp, null,"");
20014 exp_err("Not implemented: envelope(elliptical pen)of(path)");
20015 @.Not implemented...@>
20016 help3("I'm afraid I don't know how to apply that operation to that")
20017 ("combination of types. Continue, and I'll return the second")
20018 ("argument (see above) as the result of the operation.");
20019 mp_put_get_error(mp);
20022 @ @<Trace the current binary operation@>=
20024 mp_begin_diagnostic(mp); mp_print_nl(mp, "{(");
20025 mp_print_exp(mp,p,0); /* show the operand, but not verbosely */
20026 mp_print_char(mp,')'); mp_print_op(mp,c); mp_print_char(mp,'(');
20027 mp_print_exp(mp,null,0); mp_print(mp,")}");
20028 mp_end_diagnostic(mp, false);
20031 @ Several of the binary operations are potentially complicated by the
20032 fact that |independent| values can sneak into capsules. For example,
20033 we've seen an instance of this difficulty in the unary operation
20034 of negation. In order to reduce the number of cases that need to be
20035 handled, we first change the two operands (if necessary)
20036 to rid them of |independent| components. The original operands are
20037 put into capsules called |old_p| and |old_exp|, which will be
20038 recycled after the binary operation has been safely carried out.
20040 @<Recycle any sidestepped |independent| capsules@>=
20041 if ( old_p!=null ) {
20042 mp_recycle_value(mp, old_p); mp_free_node(mp, old_p,value_node_size);
20044 if ( old_exp!=null ) {
20045 mp_recycle_value(mp, old_exp); mp_free_node(mp, old_exp,value_node_size);
20048 @ A big node is considered to be ``tarnished'' if it contains at least one
20049 independent component. We will define a simple function called `|tarnished|'
20050 that returns |null| if and only if its argument is not tarnished.
20052 @<Sidestep |independent| cases in capsule |p|@>=
20054 case mp_transform_type:
20055 case mp_color_type:
20056 case mp_cmykcolor_type:
20058 old_p=mp_tarnished(mp, p);
20060 case mp_independent: old_p=mp_void; break;
20061 default: old_p=null; break;
20063 if ( old_p!=null ) {
20064 q=mp_stash_cur_exp(mp); old_p=p; mp_make_exp_copy(mp, old_p);
20065 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q);
20068 @ @<Sidestep |independent| cases in the current expression@>=
20069 switch (mp->cur_type) {
20070 case mp_transform_type:
20071 case mp_color_type:
20072 case mp_cmykcolor_type:
20074 old_exp=mp_tarnished(mp, mp->cur_exp);
20076 case mp_independent:old_exp=mp_void; break;
20077 default: old_exp=null; break;
20079 if ( old_exp!=null ) {
20080 old_exp=mp->cur_exp; mp_make_exp_copy(mp, old_exp);
20083 @ @<Declare binary action...@>=
20084 pointer mp_tarnished (MP mp,pointer p) {
20085 pointer q; /* beginning of the big node */
20086 pointer r; /* current position in the big node */
20087 q=value(p); r=q+mp->big_node_size[type(p)];
20090 if ( type(r)==mp_independent ) return mp_void;
20095 @ @<Add or subtract the current expression from |p|@>=
20096 if ( (mp->cur_type<mp_color_type)||(type(p)<mp_color_type) ) {
20097 mp_bad_binary(mp, p,c);
20099 if ((mp->cur_type>mp_pair_type)&&(type(p)>mp_pair_type) ) {
20100 mp_add_or_subtract(mp, p,null,c);
20102 if ( mp->cur_type!=type(p) ) {
20103 mp_bad_binary(mp, p,c);
20105 q=value(p); r=value(mp->cur_exp);
20106 rr=r+mp->big_node_size[mp->cur_type];
20108 mp_add_or_subtract(mp, q,r,c);
20115 @ The first argument to |add_or_subtract| is the location of a value node
20116 in a capsule or pair node that will soon be recycled. The second argument
20117 is either a location within a pair or transform node of |cur_exp|,
20118 or it is null (which means that |cur_exp| itself should be the second
20119 argument). The third argument is either |plus| or |minus|.
20121 The sum or difference of the numeric quantities will replace the second
20122 operand. Arithmetic overflow may go undetected; users aren't supposed to
20123 be monkeying around with really big values.
20124 @^overflow in arithmetic@>
20126 @<Declare binary action...@>=
20127 @<Declare the procedure called |dep_finish|@>
20128 void mp_add_or_subtract (MP mp,pointer p, pointer q, quarterword c) {
20129 small_number s,t; /* operand types */
20130 pointer r; /* list traverser */
20131 integer v; /* second operand value */
20134 if ( t<mp_dependent ) v=mp->cur_exp; else v=dep_list(mp->cur_exp);
20137 if ( t<mp_dependent ) v=value(q); else v=dep_list(q);
20139 if ( t==mp_known ) {
20140 if ( c==minus ) negate(v);
20141 if ( type(p)==mp_known ) {
20142 v=mp_slow_add(mp, value(p),v);
20143 if ( q==null ) mp->cur_exp=v; else value(q)=v;
20146 @<Add a known value to the constant term of |dep_list(p)|@>;
20148 if ( c==minus ) mp_negate_dep_list(mp, v);
20149 @<Add operand |p| to the dependency list |v|@>;
20153 @ @<Add a known value to the constant term of |dep_list(p)|@>=
20155 while ( info(r)!=null ) r=link(r);
20156 value(r)=mp_slow_add(mp, value(r),v);
20158 q=mp_get_node(mp, value_node_size); mp->cur_exp=q; mp->cur_type=type(p);
20159 name_type(q)=mp_capsule;
20161 dep_list(q)=dep_list(p); type(q)=type(p);
20162 prev_dep(q)=prev_dep(p); link(prev_dep(p))=q;
20163 type(p)=mp_known; /* this will keep the recycler from collecting non-garbage */
20165 @ We prefer |dependent| lists to |mp_proto_dependent| ones, because it is
20166 nice to retain the extra accuracy of |fraction| coefficients.
20167 But we have to handle both kinds, and mixtures too.
20169 @<Add operand |p| to the dependency list |v|@>=
20170 if ( type(p)==mp_known ) {
20171 @<Add the known |value(p)| to the constant term of |v|@>;
20173 s=type(p); r=dep_list(p);
20174 if ( t==mp_dependent ) {
20175 if ( s==mp_dependent ) {
20176 if ( mp_max_coef(mp, r)+mp_max_coef(mp, v)<coef_bound )
20177 v=mp_p_plus_q(mp, v,r,mp_dependent); goto DONE;
20178 } /* |fix_needed| will necessarily be false */
20179 t=mp_proto_dependent;
20180 v=mp_p_over_v(mp, v,unity,mp_dependent,mp_proto_dependent);
20182 if ( s==mp_proto_dependent ) v=mp_p_plus_q(mp, v,r,mp_proto_dependent);
20183 else v=mp_p_plus_fq(mp, v,unity,r,mp_proto_dependent,mp_dependent);
20185 @<Output the answer, |v| (which might have become |known|)@>;
20188 @ @<Add the known |value(p)| to the constant term of |v|@>=
20190 while ( info(v)!=null ) v=link(v);
20191 value(v)=mp_slow_add(mp, value(p),value(v));
20194 @ @<Output the answer, |v| (which might have become |known|)@>=
20195 if ( q!=null ) mp_dep_finish(mp, v,q,t);
20196 else { mp->cur_type=t; mp_dep_finish(mp, v,null,t); }
20198 @ Here's the current situation: The dependency list |v| of type |t|
20199 should either be put into the current expression (if |q=null|) or
20200 into location |q| within a pair node (otherwise). The destination (|cur_exp|
20201 or |q|) formerly held a dependency list with the same
20202 final pointer as the list |v|.
20204 @<Declare the procedure called |dep_finish|@>=
20205 void mp_dep_finish (MP mp, pointer v, pointer q, small_number t) {
20206 pointer p; /* the destination */
20207 scaled vv; /* the value, if it is |known| */
20208 if ( q==null ) p=mp->cur_exp; else p=q;
20209 dep_list(p)=v; type(p)=t;
20210 if ( info(v)==null ) {
20213 mp_flush_cur_exp(mp, vv);
20215 mp_recycle_value(mp, p); type(q)=mp_known; value(q)=vv;
20217 } else if ( q==null ) {
20220 if ( mp->fix_needed ) mp_fix_dependencies(mp);
20223 @ Let's turn now to the six basic relations of comparison.
20225 @<Additional cases of binary operators@>=
20226 case less_than: case less_or_equal: case greater_than:
20227 case greater_or_equal: case equal_to: case unequal_to:
20228 check_arith; /* at this point |arith_error| should be |false|? */
20229 if ( (mp->cur_type>mp_pair_type)&&(type(p)>mp_pair_type) ) {
20230 mp_add_or_subtract(mp, p,null,minus); /* |cur_exp:=(p)-cur_exp| */
20231 } else if ( mp->cur_type!=type(p) ) {
20232 mp_bad_binary(mp, p,c); goto DONE;
20233 } else if ( mp->cur_type==mp_string_type ) {
20234 mp_flush_cur_exp(mp, mp_str_vs_str(mp, value(p),mp->cur_exp));
20235 } else if ((mp->cur_type==mp_unknown_string)||
20236 (mp->cur_type==mp_unknown_boolean) ) {
20237 @<Check if unknowns have been equated@>;
20238 } else if ( (mp->cur_type<=mp_pair_type)&&(mp->cur_type>=mp_transform_type)) {
20239 @<Reduce comparison of big nodes to comparison of scalars@>;
20240 } else if ( mp->cur_type==mp_boolean_type ) {
20241 mp_flush_cur_exp(mp, mp->cur_exp-value(p));
20243 mp_bad_binary(mp, p,c); goto DONE;
20245 @<Compare the current expression with zero@>;
20247 mp->arith_error=false; /* ignore overflow in comparisons */
20250 @ @<Compare the current expression with zero@>=
20251 if ( mp->cur_type!=mp_known ) {
20252 if ( mp->cur_type<mp_known ) {
20253 mp_disp_err(mp, p,"");
20254 help1("The quantities shown above have not been equated.")
20256 help2("Oh dear. I can\'t decide if the expression above is positive,")
20257 ("negative, or zero. So this comparison test won't be `true'.");
20259 exp_err("Unknown relation will be considered false");
20260 @.Unknown relation...@>
20261 mp_put_get_flush_error(mp, false_code);
20264 case less_than: boolean_reset(mp->cur_exp<0); break;
20265 case less_or_equal: boolean_reset(mp->cur_exp<=0); break;
20266 case greater_than: boolean_reset(mp->cur_exp>0); break;
20267 case greater_or_equal: boolean_reset(mp->cur_exp>=0); break;
20268 case equal_to: boolean_reset(mp->cur_exp==0); break;
20269 case unequal_to: boolean_reset(mp->cur_exp!=0); break;
20270 }; /* there are no other cases */
20272 mp->cur_type=mp_boolean_type
20274 @ When two unknown strings are in the same ring, we know that they are
20275 equal. Otherwise, we don't know whether they are equal or not, so we
20278 @<Check if unknowns have been equated@>=
20280 q=value(mp->cur_exp);
20281 while ( (q!=mp->cur_exp)&&(q!=p) ) q=value(q);
20282 if ( q==p ) mp_flush_cur_exp(mp, 0);
20285 @ @<Reduce comparison of big nodes to comparison of scalars@>=
20287 q=value(p); r=value(mp->cur_exp);
20288 rr=r+mp->big_node_size[mp->cur_type]-2;
20289 while (1) { mp_add_or_subtract(mp, q,r,minus);
20290 if ( type(r)!=mp_known ) break;
20291 if ( value(r)!=0 ) break;
20292 if ( r==rr ) break;
20295 mp_take_part(mp, name_type(r)+x_part-mp_x_part_sector);
20298 @ Here we use the sneaky fact that |and_op-false_code=or_op-true_code|.
20300 @<Additional cases of binary operators@>=
20303 if ( (type(p)!=mp_boolean_type)||(mp->cur_type!=mp_boolean_type) )
20304 mp_bad_binary(mp, p,c);
20305 else if ( value(p)==c+false_code-and_op ) mp->cur_exp=value(p);
20308 @ @<Additional cases of binary operators@>=
20310 if ( (mp->cur_type<mp_color_type)||(type(p)<mp_color_type) ) {
20311 mp_bad_binary(mp, p,times);
20312 } else if ( (mp->cur_type==mp_known)||(type(p)==mp_known) ) {
20313 @<Multiply when at least one operand is known@>;
20314 } else if ( (mp_nice_color_or_pair(mp, p,type(p))&&(mp->cur_type>mp_pair_type))
20315 ||(mp_nice_color_or_pair(mp, mp->cur_exp,mp->cur_type)&&
20316 (type(p)>mp_pair_type)) ) {
20317 mp_hard_times(mp, p);
20320 mp_bad_binary(mp, p,times);
20324 @ @<Multiply when at least one operand is known@>=
20326 if ( type(p)==mp_known ) {
20327 v=value(p); mp_free_node(mp, p,value_node_size);
20329 v=mp->cur_exp; mp_unstash_cur_exp(mp, p);
20331 if ( mp->cur_type==mp_known ) {
20332 mp->cur_exp=mp_take_scaled(mp, mp->cur_exp,v);
20333 } else if ( (mp->cur_type==mp_pair_type)||
20334 (mp->cur_type==mp_color_type)||
20335 (mp->cur_type==mp_cmykcolor_type) ) {
20336 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20338 p=p-2; mp_dep_mult(mp, p,v,true);
20339 } while (p!=value(mp->cur_exp));
20341 mp_dep_mult(mp, null,v,true);
20346 @ @<Declare binary action...@>=
20347 void mp_dep_mult (MP mp,pointer p, integer v, boolean v_is_scaled) {
20348 pointer q; /* the dependency list being multiplied by |v| */
20349 small_number s,t; /* its type, before and after */
20352 } else if ( type(p)!=mp_known ) {
20355 if ( v_is_scaled ) value(p)=mp_take_scaled(mp, value(p),v);
20356 else value(p)=mp_take_fraction(mp, value(p),v);
20359 t=type(q); q=dep_list(q); s=t;
20360 if ( t==mp_dependent ) if ( v_is_scaled )
20361 if (mp_ab_vs_cd(mp, mp_max_coef(mp,q),abs(v),coef_bound-1,unity)>=0 )
20362 t=mp_proto_dependent;
20363 q=mp_p_times_v(mp, q,v,s,t,v_is_scaled);
20364 mp_dep_finish(mp, q,p,t);
20367 @ Here is a routine that is similar to |times|; but it is invoked only
20368 internally, when |v| is a |fraction| whose magnitude is at most~1,
20369 and when |cur_type>=mp_color_type|.
20371 @c void mp_frac_mult (MP mp,scaled n, scaled d) {
20372 /* multiplies |cur_exp| by |n/d| */
20373 pointer p; /* a pair node */
20374 pointer old_exp; /* a capsule to recycle */
20375 fraction v; /* |n/d| */
20376 if ( mp->internal[mp_tracing_commands]>two ) {
20377 @<Trace the fraction multiplication@>;
20379 switch (mp->cur_type) {
20380 case mp_transform_type:
20381 case mp_color_type:
20382 case mp_cmykcolor_type:
20384 old_exp=mp_tarnished(mp, mp->cur_exp);
20386 case mp_independent: old_exp=mp_void; break;
20387 default: old_exp=null; break;
20389 if ( old_exp!=null ) {
20390 old_exp=mp->cur_exp; mp_make_exp_copy(mp, old_exp);
20392 v=mp_make_fraction(mp, n,d);
20393 if ( mp->cur_type==mp_known ) {
20394 mp->cur_exp=mp_take_fraction(mp, mp->cur_exp,v);
20395 } else if ( mp->cur_type<=mp_pair_type ) {
20396 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20399 mp_dep_mult(mp, p,v,false);
20400 } while (p!=value(mp->cur_exp));
20402 mp_dep_mult(mp, null,v,false);
20404 if ( old_exp!=null ) {
20405 mp_recycle_value(mp, old_exp);
20406 mp_free_node(mp, old_exp,value_node_size);
20410 @ @<Trace the fraction multiplication@>=
20412 mp_begin_diagnostic(mp);
20413 mp_print_nl(mp, "{("); mp_print_scaled(mp,n); mp_print_char(mp,'/');
20414 mp_print_scaled(mp,d); mp_print(mp,")*("); mp_print_exp(mp,null,0);
20416 mp_end_diagnostic(mp, false);
20419 @ The |hard_times| routine multiplies a nice color or pair by a dependency list.
20421 @<Declare binary action procedures@>=
20422 void mp_hard_times (MP mp,pointer p) {
20423 pointer q; /* a copy of the dependent variable |p| */
20424 pointer r; /* a component of the big node for the nice color or pair */
20425 scaled v; /* the known value for |r| */
20426 if ( type(p)<=mp_pair_type ) {
20427 q=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, p); p=q;
20428 }; /* now |cur_type=mp_pair_type| or |cur_type=mp_color_type| */
20429 r=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20434 if ( r==value(mp->cur_exp) )
20436 mp_new_dep(mp, r,mp_copy_dep_list(mp, dep_list(p)));
20437 mp_dep_mult(mp, r,v,true);
20439 mp->mem[value_loc(r)]=mp->mem[value_loc(p)];
20440 link(prev_dep(p))=r;
20441 mp_free_node(mp, p,value_node_size);
20442 mp_dep_mult(mp, r,v,true);
20445 @ @<Additional cases of binary operators@>=
20447 if ( (mp->cur_type!=mp_known)||(type(p)<mp_color_type) ) {
20448 mp_bad_binary(mp, p,over);
20450 v=mp->cur_exp; mp_unstash_cur_exp(mp, p);
20452 @<Squeal about division by zero@>;
20454 if ( mp->cur_type==mp_known ) {
20455 mp->cur_exp=mp_make_scaled(mp, mp->cur_exp,v);
20456 } else if ( mp->cur_type<=mp_pair_type ) {
20457 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20459 p=p-2; mp_dep_div(mp, p,v);
20460 } while (p!=value(mp->cur_exp));
20462 mp_dep_div(mp, null,v);
20469 @ @<Declare binary action...@>=
20470 void mp_dep_div (MP mp,pointer p, scaled v) {
20471 pointer q; /* the dependency list being divided by |v| */
20472 small_number s,t; /* its type, before and after */
20473 if ( p==null ) q=mp->cur_exp;
20474 else if ( type(p)!=mp_known ) q=p;
20475 else { value(p)=mp_make_scaled(mp, value(p),v); return; };
20476 t=type(q); q=dep_list(q); s=t;
20477 if ( t==mp_dependent )
20478 if ( mp_ab_vs_cd(mp, mp_max_coef(mp,q),unity,coef_bound-1,abs(v))>=0 )
20479 t=mp_proto_dependent;
20480 q=mp_p_over_v(mp, q,v,s,t);
20481 mp_dep_finish(mp, q,p,t);
20484 @ @<Squeal about division by zero@>=
20486 exp_err("Division by zero");
20487 @.Division by zero@>
20488 help2("You're trying to divide the quantity shown above the error")
20489 ("message by zero. I'm going to divide it by one instead.");
20490 mp_put_get_error(mp);
20493 @ @<Additional cases of binary operators@>=
20496 if ( (mp->cur_type==mp_known)&&(type(p)==mp_known) ) {
20497 if ( c==pythag_add ) mp->cur_exp=mp_pyth_add(mp, value(p),mp->cur_exp);
20498 else mp->cur_exp=mp_pyth_sub(mp, value(p),mp->cur_exp);
20499 } else mp_bad_binary(mp, p,c);
20502 @ The next few sections of the program deal with affine transformations
20503 of coordinate data.
20505 @<Additional cases of binary operators@>=
20506 case rotated_by: case slanted_by:
20507 case scaled_by: case shifted_by: case transformed_by:
20508 case x_scaled: case y_scaled: case z_scaled:
20509 if ( type(p)==mp_path_type ) {
20510 path_trans(c,p); binary_return;
20511 } else if ( type(p)==mp_pen_type ) {
20513 mp->cur_exp=mp_convex_hull(mp, mp->cur_exp);
20514 /* rounding error could destroy convexity */
20516 } else if ( (type(p)==mp_pair_type)||(type(p)==mp_transform_type) ) {
20517 mp_big_trans(mp, p,c);
20518 } else if ( type(p)==mp_picture_type ) {
20519 mp_do_edges_trans(mp, p,c); binary_return;
20521 mp_bad_binary(mp, p,c);
20525 @ Let |c| be one of the eight transform operators. The procedure call
20526 |set_up_trans(c)| first changes |cur_exp| to a transform that corresponds to
20527 |c| and the original value of |cur_exp|. (In particular, |cur_exp| doesn't
20528 change at all if |c=transformed_by|.)
20530 Then, if all components of the resulting transform are |known|, they are
20531 moved to the global variables |txx|, |txy|, |tyx|, |tyy|, |tx|, |ty|;
20532 and |cur_exp| is changed to the known value zero.
20534 @<Declare binary action...@>=
20535 void mp_set_up_trans (MP mp,quarterword c) {
20536 pointer p,q,r; /* list manipulation registers */
20537 if ( (c!=transformed_by)||(mp->cur_type!=mp_transform_type) ) {
20538 @<Put the current transform into |cur_exp|@>;
20540 @<If the current transform is entirely known, stash it in global variables;
20541 otherwise |return|@>;
20550 scaled ty; /* current transform coefficients */
20552 @ @<Put the current transform...@>=
20554 p=mp_stash_cur_exp(mp);
20555 mp->cur_exp=mp_id_transform(mp);
20556 mp->cur_type=mp_transform_type;
20557 q=value(mp->cur_exp);
20559 @<For each of the eight cases, change the relevant fields of |cur_exp|
20561 but do nothing if capsule |p| doesn't have the appropriate type@>;
20562 }; /* there are no other cases */
20563 mp_disp_err(mp, p,"Improper transformation argument");
20564 @.Improper transformation argument@>
20565 help3("The expression shown above has the wrong type,")
20566 ("so I can\'t transform anything using it.")
20567 ("Proceed, and I'll omit the transformation.");
20568 mp_put_get_error(mp);
20570 mp_recycle_value(mp, p);
20571 mp_free_node(mp, p,value_node_size);
20574 @ @<If the current transform is entirely known, ...@>=
20575 q=value(mp->cur_exp); r=q+transform_node_size;
20578 if ( type(r)!=mp_known ) return;
20580 mp->txx=value(xx_part_loc(q));
20581 mp->txy=value(xy_part_loc(q));
20582 mp->tyx=value(yx_part_loc(q));
20583 mp->tyy=value(yy_part_loc(q));
20584 mp->tx=value(x_part_loc(q));
20585 mp->ty=value(y_part_loc(q));
20586 mp_flush_cur_exp(mp, 0)
20588 @ @<For each of the eight cases...@>=
20590 if ( type(p)==mp_known )
20591 @<Install sines and cosines, then |goto done|@>;
20594 if ( type(p)>mp_pair_type ) {
20595 mp_install(mp, xy_part_loc(q),p); goto DONE;
20599 if ( type(p)>mp_pair_type ) {
20600 mp_install(mp, xx_part_loc(q),p); mp_install(mp, yy_part_loc(q),p);
20605 if ( type(p)==mp_pair_type ) {
20606 r=value(p); mp_install(mp, x_part_loc(q),x_part_loc(r));
20607 mp_install(mp, y_part_loc(q),y_part_loc(r)); goto DONE;
20611 if ( type(p)>mp_pair_type ) {
20612 mp_install(mp, xx_part_loc(q),p); goto DONE;
20616 if ( type(p)>mp_pair_type ) {
20617 mp_install(mp, yy_part_loc(q),p); goto DONE;
20621 if ( type(p)==mp_pair_type )
20622 @<Install a complex multiplier, then |goto done|@>;
20624 case transformed_by:
20628 @ @<Install sines and cosines, then |goto done|@>=
20629 { mp_n_sin_cos(mp, (value(p) % three_sixty_units)*16);
20630 value(xx_part_loc(q))=mp_round_fraction(mp, mp->n_cos);
20631 value(yx_part_loc(q))=mp_round_fraction(mp, mp->n_sin);
20632 value(xy_part_loc(q))=-value(yx_part_loc(q));
20633 value(yy_part_loc(q))=value(xx_part_loc(q));
20637 @ @<Install a complex multiplier, then |goto done|@>=
20640 mp_install(mp, xx_part_loc(q),x_part_loc(r));
20641 mp_install(mp, yy_part_loc(q),x_part_loc(r));
20642 mp_install(mp, yx_part_loc(q),y_part_loc(r));
20643 if ( type(y_part_loc(r))==mp_known ) negate(value(y_part_loc(r)));
20644 else mp_negate_dep_list(mp, dep_list(y_part_loc(r)));
20645 mp_install(mp, xy_part_loc(q),y_part_loc(r));
20649 @ Procedure |set_up_known_trans| is like |set_up_trans|, but it
20650 insists that the transformation be entirely known.
20652 @<Declare binary action...@>=
20653 void mp_set_up_known_trans (MP mp,quarterword c) {
20654 mp_set_up_trans(mp, c);
20655 if ( mp->cur_type!=mp_known ) {
20656 exp_err("Transform components aren't all known");
20657 @.Transform components...@>
20658 help3("I'm unable to apply a partially specified transformation")
20659 ("except to a fully known pair or transform.")
20660 ("Proceed, and I'll omit the transformation.");
20661 mp_put_get_flush_error(mp, 0);
20662 mp->txx=unity; mp->txy=0; mp->tyx=0; mp->tyy=unity;
20663 mp->tx=0; mp->ty=0;
20667 @ Here's a procedure that applies the transform |txx..ty| to a pair of
20668 coordinates in locations |p| and~|q|.
20670 @<Declare binary action...@>=
20671 void mp_trans (MP mp,pointer p, pointer q) {
20672 scaled v; /* the new |x| value */
20673 v=mp_take_scaled(mp, mp->mem[p].sc,mp->txx)+
20674 mp_take_scaled(mp, mp->mem[q].sc,mp->txy)+mp->tx;
20675 mp->mem[q].sc=mp_take_scaled(mp, mp->mem[p].sc,mp->tyx)+
20676 mp_take_scaled(mp, mp->mem[q].sc,mp->tyy)+mp->ty;
20680 @ The simplest transformation procedure applies a transform to all
20681 coordinates of a path. The |path_trans(c)(p)| macro applies
20682 a transformation defined by |cur_exp| and the transform operator |c|
20685 @d path_trans(A,B) { mp_set_up_known_trans(mp, (A));
20686 mp_unstash_cur_exp(mp, (B));
20687 mp_do_path_trans(mp, mp->cur_exp); }
20689 @<Declare binary action...@>=
20690 void mp_do_path_trans (MP mp,pointer p) {
20691 pointer q; /* list traverser */
20694 if ( left_type(q)!=mp_endpoint )
20695 mp_trans(mp, q+3,q+4); /* that's |left_x| and |left_y| */
20696 mp_trans(mp, q+1,q+2); /* that's |x_coord| and |y_coord| */
20697 if ( right_type(q)!=mp_endpoint )
20698 mp_trans(mp, q+5,q+6); /* that's |right_x| and |right_y| */
20699 @^data structure assumptions@>
20704 @ Transforming a pen is very similar, except that there are no |left_type|
20705 and |right_type| fields.
20707 @d pen_trans(A,B) { mp_set_up_known_trans(mp, (A));
20708 mp_unstash_cur_exp(mp, (B));
20709 mp_do_pen_trans(mp, mp->cur_exp); }
20711 @<Declare binary action...@>=
20712 void mp_do_pen_trans (MP mp,pointer p) {
20713 pointer q; /* list traverser */
20714 if ( pen_is_elliptical(p) ) {
20715 mp_trans(mp, p+3,p+4); /* that's |left_x| and |left_y| */
20716 mp_trans(mp, p+5,p+6); /* that's |right_x| and |right_y| */
20720 mp_trans(mp, q+1,q+2); /* that's |x_coord| and |y_coord| */
20721 @^data structure assumptions@>
20726 @ The next transformation procedure applies to edge structures. It will do
20727 any transformation, but the results may be substandard if the picture contains
20728 text that uses downloaded bitmap fonts. The binary action procedure is
20729 |do_edges_trans|, but we also need a function that just scales a picture.
20730 That routine is |scale_edges|. Both it and the underlying routine |edges_trans|
20731 should be thought of as procedures that update an edge structure |h|, except
20732 that they have to return a (possibly new) structure because of the need to call
20735 @<Declare binary action...@>=
20736 pointer mp_edges_trans (MP mp, pointer h) {
20737 pointer q; /* the object being transformed */
20738 pointer r,s; /* for list manipulation */
20739 scaled sx,sy; /* saved transformation parameters */
20740 scaled sqdet; /* square root of determinant for |dash_scale| */
20741 integer sgndet; /* sign of the determinant */
20742 scaled v; /* a temporary value */
20743 h=mp_private_edges(mp, h);
20744 sqdet=mp_sqrt_det(mp, mp->txx,mp->txy,mp->tyx,mp->tyy);
20745 sgndet=mp_ab_vs_cd(mp, mp->txx,mp->tyy,mp->txy,mp->tyx);
20746 if ( dash_list(h)!=null_dash ) {
20747 @<Try to transform the dash list of |h|@>;
20749 @<Make the bounding box of |h| unknown if it can't be updated properly
20750 without scanning the whole structure@>;
20751 q=link(dummy_loc(h));
20752 while ( q!=null ) {
20753 @<Transform graphical object |q|@>;
20758 void mp_do_edges_trans (MP mp,pointer p, quarterword c) {
20759 mp_set_up_known_trans(mp, c);
20760 value(p)=mp_edges_trans(mp, value(p));
20761 mp_unstash_cur_exp(mp, p);
20763 void mp_scale_edges (MP mp) {
20764 mp->txx=mp->se_sf; mp->tyy=mp->se_sf;
20765 mp->txy=0; mp->tyx=0; mp->tx=0; mp->ty=0;
20766 mp->se_pic=mp_edges_trans(mp, mp->se_pic);
20769 @ @<Try to transform the dash list of |h|@>=
20770 if ( (mp->txy!=0)||(mp->tyx!=0)||
20771 (mp->ty!=0)||(abs(mp->txx)!=abs(mp->tyy))) {
20772 mp_flush_dash_list(mp, h);
20774 if ( mp->txx<0 ) { @<Reverse the dash list of |h|@>; }
20775 @<Scale the dash list by |txx| and shift it by |tx|@>;
20776 dash_y(h)=mp_take_scaled(mp, dash_y(h),abs(mp->tyy));
20779 @ @<Reverse the dash list of |h|@>=
20782 dash_list(h)=null_dash;
20783 while ( r!=null_dash ) {
20785 v=start_x(s); start_x(s)=stop_x(s); stop_x(s)=v;
20786 link(s)=dash_list(h);
20791 @ @<Scale the dash list by |txx| and shift it by |tx|@>=
20793 while ( r!=null_dash ) {
20794 start_x(r)=mp_take_scaled(mp, start_x(r),mp->txx)+mp->tx;
20795 stop_x(r)=mp_take_scaled(mp, stop_x(r),mp->txx)+mp->tx;
20799 @ @<Make the bounding box of |h| unknown if it can't be updated properly...@>=
20800 if ( (mp->txx==0)&&(mp->tyy==0) ) {
20801 @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>;
20802 } else if ( (mp->txy!=0)||(mp->tyx!=0) ) {
20803 mp_init_bbox(mp, h);
20806 if ( minx_val(h)<=maxx_val(h) ) {
20807 @<Scale the bounding box by |txx+txy| and |tyx+tyy|; then shift by
20814 @ @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>=
20816 v=minx_val(h); minx_val(h)=miny_val(h); miny_val(h)=v;
20817 v=maxx_val(h); maxx_val(h)=maxy_val(h); maxy_val(h)=v;
20820 @ The sum ``|txx+txy|'' is whichever of |txx| or |txy| is nonzero. The other
20823 @<Scale the bounding box by |txx+txy| and |tyx+tyy|; then shift...@>=
20825 minx_val(h)=mp_take_scaled(mp, minx_val(h),mp->txx+mp->txy)+mp->tx;
20826 maxx_val(h)=mp_take_scaled(mp, maxx_val(h),mp->txx+mp->txy)+mp->tx;
20827 miny_val(h)=mp_take_scaled(mp, miny_val(h),mp->tyx+mp->tyy)+mp->ty;
20828 maxy_val(h)=mp_take_scaled(mp, maxy_val(h),mp->tyx+mp->tyy)+mp->ty;
20829 if ( mp->txx+mp->txy<0 ) {
20830 v=minx_val(h); minx_val(h)=maxx_val(h); maxx_val(h)=v;
20832 if ( mp->tyx+mp->tyy<0 ) {
20833 v=miny_val(h); miny_val(h)=maxy_val(h); maxy_val(h)=v;
20837 @ Now we ready for the main task of transforming the graphical objects in edge
20840 @<Transform graphical object |q|@>=
20842 case mp_fill_code: case mp_stroked_code:
20843 mp_do_path_trans(mp, path_p(q));
20844 @<Transform |pen_p(q)|, making sure polygonal pens stay counter-clockwise@>;
20846 case mp_start_clip_code: case mp_start_bounds_code:
20847 mp_do_path_trans(mp, path_p(q));
20851 @<Transform the compact transformation starting at |r|@>;
20853 case mp_stop_clip_code: case mp_stop_bounds_code:
20855 } /* there are no other cases */
20857 @ Note that the shift parameters |(tx,ty)| apply only to the path being stroked.
20858 The |dash_scale| has to be adjusted to scale the dash lengths in |dash_p(q)|
20859 since the \ps\ output procedures will try to compensate for the transformation
20860 we are applying to |pen_p(q)|. Since this compensation is based on the square
20861 root of the determinant, |sqdet| is the appropriate factor.
20863 @<Transform |pen_p(q)|, making sure...@>=
20864 if ( pen_p(q)!=null ) {
20865 sx=mp->tx; sy=mp->ty;
20866 mp->tx=0; mp->ty=0;
20867 mp_do_pen_trans(mp, pen_p(q));
20868 if ( ((type(q)==mp_stroked_code)&&(dash_p(q)!=null)) )
20869 dash_scale(q)=mp_take_scaled(mp, dash_scale(q),sqdet);
20870 if ( ! pen_is_elliptical(pen_p(q)) )
20872 pen_p(q)=mp_make_pen(mp, mp_copy_path(mp, pen_p(q)),true);
20873 /* this unreverses the pen */
20874 mp->tx=sx; mp->ty=sy;
20877 @ This uses the fact that transformations are stored in the order
20878 |(tx,ty,txx,txy,tyx,tyy)|.
20879 @^data structure assumptions@>
20881 @<Transform the compact transformation starting at |r|@>=
20882 mp_trans(mp, r,r+1);
20883 sx=mp->tx; sy=mp->ty;
20884 mp->tx=0; mp->ty=0;
20885 mp_trans(mp, r+2,r+4);
20886 mp_trans(mp, r+3,r+5);
20887 mp->tx=sx; mp->ty=sy
20889 @ The hard cases of transformation occur when big nodes are involved,
20890 and when some of their components are unknown.
20892 @<Declare binary action...@>=
20893 @<Declare subroutines needed by |big_trans|@>
20894 void mp_big_trans (MP mp,pointer p, quarterword c) {
20895 pointer q,r,pp,qq; /* list manipulation registers */
20896 small_number s; /* size of a big node */
20897 s=mp->big_node_size[type(p)]; q=value(p); r=q+s;
20900 if ( type(r)!=mp_known ) {
20901 @<Transform an unknown big node and |return|@>;
20904 @<Transform a known big node@>;
20905 } /* node |p| will now be recycled by |do_binary| */
20907 @ @<Transform an unknown big node and |return|@>=
20909 mp_set_up_known_trans(mp, c); mp_make_exp_copy(mp, p);
20910 r=value(mp->cur_exp);
20911 if ( mp->cur_type==mp_transform_type ) {
20912 mp_bilin1(mp, yy_part_loc(r),mp->tyy,xy_part_loc(q),mp->tyx,0);
20913 mp_bilin1(mp, yx_part_loc(r),mp->tyy,xx_part_loc(q),mp->tyx,0);
20914 mp_bilin1(mp, xy_part_loc(r),mp->txx,yy_part_loc(q),mp->txy,0);
20915 mp_bilin1(mp, xx_part_loc(r),mp->txx,yx_part_loc(q),mp->txy,0);
20917 mp_bilin1(mp, y_part_loc(r),mp->tyy,x_part_loc(q),mp->tyx,mp->ty);
20918 mp_bilin1(mp, x_part_loc(r),mp->txx,y_part_loc(q),mp->txy,mp->tx);
20922 @ Let |p| point to a two-word value field inside a big node of |cur_exp|,
20923 and let |q| point to a another value field. The |bilin1| procedure
20924 replaces |p| by $p\cdot t+q\cdot u+\delta$.
20926 @<Declare subroutines needed by |big_trans|@>=
20927 void mp_bilin1 (MP mp, pointer p, scaled t, pointer q,
20928 scaled u, scaled delta) {
20929 pointer r; /* list traverser */
20930 if ( t!=unity ) mp_dep_mult(mp, p,t,true);
20932 if ( type(q)==mp_known ) {
20933 delta+=mp_take_scaled(mp, value(q),u);
20935 @<Ensure that |type(p)=mp_proto_dependent|@>;
20936 dep_list(p)=mp_p_plus_fq(mp, dep_list(p),u,dep_list(q),
20937 mp_proto_dependent,type(q));
20940 if ( type(p)==mp_known ) {
20944 while ( info(r)!=null ) r=link(r);
20946 if ( r!=dep_list(p) ) value(r)=delta;
20947 else { mp_recycle_value(mp, p); type(p)=mp_known; value(p)=delta; };
20949 if ( mp->fix_needed ) mp_fix_dependencies(mp);
20952 @ @<Ensure that |type(p)=mp_proto_dependent|@>=
20953 if ( type(p)!=mp_proto_dependent ) {
20954 if ( type(p)==mp_known )
20955 mp_new_dep(mp, p,mp_const_dependency(mp, value(p)));
20957 dep_list(p)=mp_p_times_v(mp, dep_list(p),unity,mp_dependent,
20958 mp_proto_dependent,true);
20959 type(p)=mp_proto_dependent;
20962 @ @<Transform a known big node@>=
20963 mp_set_up_trans(mp, c);
20964 if ( mp->cur_type==mp_known ) {
20965 @<Transform known by known@>;
20967 pp=mp_stash_cur_exp(mp); qq=value(pp);
20968 mp_make_exp_copy(mp, p); r=value(mp->cur_exp);
20969 if ( mp->cur_type==mp_transform_type ) {
20970 mp_bilin2(mp, yy_part_loc(r),yy_part_loc(qq),
20971 value(xy_part_loc(q)),yx_part_loc(qq),null);
20972 mp_bilin2(mp, yx_part_loc(r),yy_part_loc(qq),
20973 value(xx_part_loc(q)),yx_part_loc(qq),null);
20974 mp_bilin2(mp, xy_part_loc(r),xx_part_loc(qq),
20975 value(yy_part_loc(q)),xy_part_loc(qq),null);
20976 mp_bilin2(mp, xx_part_loc(r),xx_part_loc(qq),
20977 value(yx_part_loc(q)),xy_part_loc(qq),null);
20979 mp_bilin2(mp, y_part_loc(r),yy_part_loc(qq),
20980 value(x_part_loc(q)),yx_part_loc(qq),y_part_loc(qq));
20981 mp_bilin2(mp, x_part_loc(r),xx_part_loc(qq),
20982 value(y_part_loc(q)),xy_part_loc(qq),x_part_loc(qq));
20983 mp_recycle_value(mp, pp); mp_free_node(mp, pp,value_node_size);
20986 @ Let |p| be a |mp_proto_dependent| value whose dependency list ends
20987 at |dep_final|. The following procedure adds |v| times another
20988 numeric quantity to~|p|.
20990 @<Declare subroutines needed by |big_trans|@>=
20991 void mp_add_mult_dep (MP mp,pointer p, scaled v, pointer r) {
20992 if ( type(r)==mp_known ) {
20993 value(mp->dep_final)+=mp_take_scaled(mp, value(r),v);
20995 dep_list(p)=mp_p_plus_fq(mp, dep_list(p),v,dep_list(r),
20996 mp_proto_dependent,type(r));
20997 if ( mp->fix_needed ) mp_fix_dependencies(mp);
21001 @ The |bilin2| procedure is something like |bilin1|, but with known
21002 and unknown quantities reversed. Parameter |p| points to a value field
21003 within the big node for |cur_exp|; and |type(p)=mp_known|. Parameters
21004 |t| and~|u| point to value fields elsewhere; so does parameter~|q|,
21005 unless it is |null| (which stands for zero). Location~|p| will be
21006 replaced by $p\cdot t+v\cdot u+q$.
21008 @<Declare subroutines needed by |big_trans|@>=
21009 void mp_bilin2 (MP mp,pointer p, pointer t, scaled v,
21010 pointer u, pointer q) {
21011 scaled vv; /* temporary storage for |value(p)| */
21012 vv=value(p); type(p)=mp_proto_dependent;
21013 mp_new_dep(mp, p,mp_const_dependency(mp, 0)); /* this sets |dep_final| */
21015 mp_add_mult_dep(mp, p,vv,t); /* |dep_final| doesn't change */
21016 if ( v!=0 ) mp_add_mult_dep(mp, p,v,u);
21017 if ( q!=null ) mp_add_mult_dep(mp, p,unity,q);
21018 if ( dep_list(p)==mp->dep_final ) {
21019 vv=value(mp->dep_final); mp_recycle_value(mp, p);
21020 type(p)=mp_known; value(p)=vv;
21024 @ @<Transform known by known@>=
21026 mp_make_exp_copy(mp, p); r=value(mp->cur_exp);
21027 if ( mp->cur_type==mp_transform_type ) {
21028 mp_bilin3(mp, yy_part_loc(r),mp->tyy,value(xy_part_loc(q)),mp->tyx,0);
21029 mp_bilin3(mp, yx_part_loc(r),mp->tyy,value(xx_part_loc(q)),mp->tyx,0);
21030 mp_bilin3(mp, xy_part_loc(r),mp->txx,value(yy_part_loc(q)),mp->txy,0);
21031 mp_bilin3(mp, xx_part_loc(r),mp->txx,value(yx_part_loc(q)),mp->txy,0);
21033 mp_bilin3(mp, y_part_loc(r),mp->tyy,value(x_part_loc(q)),mp->tyx,mp->ty);
21034 mp_bilin3(mp, x_part_loc(r),mp->txx,value(y_part_loc(q)),mp->txy,mp->tx);
21037 @ Finally, in |bilin3| everything is |known|.
21039 @<Declare subroutines needed by |big_trans|@>=
21040 void mp_bilin3 (MP mp,pointer p, scaled t,
21041 scaled v, scaled u, scaled delta) {
21043 delta+=mp_take_scaled(mp, value(p),t);
21046 if ( u!=0 ) value(p)=delta+mp_take_scaled(mp, v,u);
21047 else value(p)=delta;
21050 @ @<Additional cases of binary operators@>=
21052 if ( (mp->cur_type==mp_string_type)&&(type(p)==mp_string_type) ) mp_cat(mp, p);
21053 else mp_bad_binary(mp, p,concatenate);
21056 if ( mp_nice_pair(mp, p,type(p))&&(mp->cur_type==mp_string_type) )
21057 mp_chop_string(mp, value(p));
21058 else mp_bad_binary(mp, p,substring_of);
21061 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
21062 if ( mp_nice_pair(mp, p,type(p))&&(mp->cur_type==mp_path_type) )
21063 mp_chop_path(mp, value(p));
21064 else mp_bad_binary(mp, p,subpath_of);
21067 @ @<Declare binary action...@>=
21068 void mp_cat (MP mp,pointer p) {
21069 str_number a,b; /* the strings being concatenated */
21070 pool_pointer k; /* index into |str_pool| */
21071 a=value(p); b=mp->cur_exp; str_room(length(a)+length(b));
21072 for (k=mp->str_start[a];k<=str_stop(a)-1;k++) {
21073 append_char(mp->str_pool[k]);
21075 for (k=mp->str_start[b];k<=str_stop(b)-1;k++) {
21076 append_char(mp->str_pool[k]);
21078 mp->cur_exp=mp_make_string(mp); delete_str_ref(b);
21081 @ @<Declare binary action...@>=
21082 void mp_chop_string (MP mp,pointer p) {
21083 integer a, b; /* start and stop points */
21084 integer l; /* length of the original string */
21085 integer k; /* runs from |a| to |b| */
21086 str_number s; /* the original string */
21087 boolean reversed; /* was |a>b|? */
21088 a=mp_round_unscaled(mp, value(x_part_loc(p)));
21089 b=mp_round_unscaled(mp, value(y_part_loc(p)));
21090 if ( a<=b ) reversed=false;
21091 else { reversed=true; k=a; a=b; b=k; };
21092 s=mp->cur_exp; l=length(s);
21103 for (k=mp->str_start[s]+b-1;k>=mp->str_start[s]+a;k--) {
21104 append_char(mp->str_pool[k]);
21107 for (k=mp->str_start[s]+a;k<=mp->str_start[s]+b-1;k++) {
21108 append_char(mp->str_pool[k]);
21111 mp->cur_exp=mp_make_string(mp); delete_str_ref(s);
21114 @ @<Declare binary action...@>=
21115 void mp_chop_path (MP mp,pointer p) {
21116 pointer q; /* a knot in the original path */
21117 pointer pp,qq,rr,ss; /* link variables for copies of path nodes */
21118 scaled a,b,k,l; /* indices for chopping */
21119 boolean reversed; /* was |a>b|? */
21120 l=mp_path_length(mp); a=value(x_part_loc(p)); b=value(y_part_loc(p));
21121 if ( a<=b ) reversed=false;
21122 else { reversed=true; k=a; a=b; b=k; };
21123 @<Dispense with the cases |a<0| and/or |b>l|@>;
21125 while ( a>=unity ) {
21126 q=link(q); a=a-unity; b=b-unity;
21129 @<Construct a path from |pp| to |qq| of length zero@>;
21131 @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>;
21133 left_type(pp)=mp_endpoint; right_type(qq)=mp_endpoint; link(qq)=pp;
21134 mp_toss_knot_list(mp, mp->cur_exp);
21136 mp->cur_exp=link(mp_htap_ypoc(mp, pp)); mp_toss_knot_list(mp, pp);
21142 @ @<Dispense with the cases |a<0| and/or |b>l|@>=
21144 if ( left_type(mp->cur_exp)==mp_endpoint ) {
21145 a=0; if ( b<0 ) b=0;
21147 do { a=a+l; b=b+l; } while (a<0); /* a cycle always has length |l>0| */
21151 if ( left_type(mp->cur_exp)==mp_endpoint ) {
21152 b=l; if ( a>l ) a=l;
21160 @ @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>=
21162 pp=mp_copy_knot(mp, q); qq=pp;
21164 q=link(q); rr=qq; qq=mp_copy_knot(mp, q); link(rr)=qq; b=b-unity;
21167 ss=pp; pp=link(pp);
21168 mp_split_cubic(mp, ss,a*010000); pp=link(ss);
21169 mp_free_node(mp, ss,knot_node_size);
21171 b=mp_make_scaled(mp, b,unity-a); rr=pp;
21175 mp_split_cubic(mp, rr,(b+unity)*010000);
21176 mp_free_node(mp, qq,knot_node_size);
21181 @ @<Construct a path from |pp| to |qq| of length zero@>=
21183 if ( a>0 ) { mp_split_cubic(mp, q,a*010000); q=link(q); };
21184 pp=mp_copy_knot(mp, q); qq=pp;
21187 @ @<Additional cases of binary operators@>=
21188 case point_of: case precontrol_of: case postcontrol_of:
21189 if ( mp->cur_type==mp_pair_type )
21190 mp_pair_to_path(mp);
21191 if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_known) )
21192 mp_find_point(mp, value(p),c);
21194 mp_bad_binary(mp, p,c);
21196 case pen_offset_of:
21197 if ( (mp->cur_type==mp_pen_type)&& mp_nice_pair(mp, p,type(p)) )
21198 mp_set_up_offset(mp, value(p));
21200 mp_bad_binary(mp, p,pen_offset_of);
21202 case direction_time_of:
21203 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
21204 if ( (mp->cur_type==mp_path_type)&& mp_nice_pair(mp, p,type(p)) )
21205 mp_set_up_direction_time(mp, value(p));
21207 mp_bad_binary(mp, p,direction_time_of);
21210 if ( (type(p) != mp_pen_type) || (mp->cur_type != mp_path_type) )
21211 mp_bad_binary(mp, p,envelope_of);
21213 mp_set_up_envelope(mp, p);
21216 @ @<Declare binary action...@>=
21217 void mp_set_up_offset (MP mp,pointer p) {
21218 mp_find_offset(mp, value(x_part_loc(p)),value(y_part_loc(p)),mp->cur_exp);
21219 mp_pair_value(mp, mp->cur_x,mp->cur_y);
21221 void mp_set_up_direction_time (MP mp,pointer p) {
21222 mp_flush_cur_exp(mp, mp_find_direction_time(mp, value(x_part_loc(p)),
21223 value(y_part_loc(p)),mp->cur_exp));
21225 void mp_set_up_envelope (MP mp,pointer p) {
21226 small_number ljoin, lcap;
21228 pointer q = mp_copy_path(mp, mp->cur_exp); /* the original path */
21229 /* TODO: accept elliptical pens for straight paths */
21230 if (pen_is_elliptical(value(p))) {
21231 mp_bad_envelope_pen(mp);
21233 mp->cur_type = mp_path_type;
21236 if ( mp->internal[mp_linejoin]>unity ) ljoin=2;
21237 else if ( mp->internal[mp_linejoin]>0 ) ljoin=1;
21239 if ( mp->internal[mp_linecap]>unity ) lcap=2;
21240 else if ( mp->internal[mp_linecap]>0 ) lcap=1;
21242 if ( mp->internal[mp_miterlimit]<unity )
21245 miterlim=mp->internal[mp_miterlimit];
21246 mp->cur_exp = mp_make_envelope(mp, q, value(p), ljoin,lcap,miterlim);
21247 mp->cur_type = mp_path_type;
21250 @ @<Declare binary action...@>=
21251 void mp_find_point (MP mp,scaled v, quarterword c) {
21252 pointer p; /* the path */
21253 scaled n; /* its length */
21255 if ( left_type(p)==mp_endpoint ) n=-unity; else n=0;
21256 do { p=link(p); n=n+unity; } while (p!=mp->cur_exp);
21259 } else if ( v<0 ) {
21260 if ( left_type(p)==mp_endpoint ) v=0;
21261 else v=n-1-((-v-1) % n);
21262 } else if ( v>n ) {
21263 if ( left_type(p)==mp_endpoint ) v=n;
21267 while ( v>=unity ) { p=link(p); v=v-unity; };
21269 @<Insert a fractional node by splitting the cubic@>;
21271 @<Set the current expression to the desired path coordinates@>;
21274 @ @<Insert a fractional node...@>=
21275 { mp_split_cubic(mp, p,v*010000); p=link(p); }
21277 @ @<Set the current expression to the desired path coordinates...@>=
21280 mp_pair_value(mp, x_coord(p),y_coord(p));
21282 case precontrol_of:
21283 if ( left_type(p)==mp_endpoint ) mp_pair_value(mp, x_coord(p),y_coord(p));
21284 else mp_pair_value(mp, left_x(p),left_y(p));
21286 case postcontrol_of:
21287 if ( right_type(p)==mp_endpoint ) mp_pair_value(mp, x_coord(p),y_coord(p));
21288 else mp_pair_value(mp, right_x(p),right_y(p));
21290 } /* there are no other cases */
21292 @ @<Additional cases of binary operators@>=
21294 if ( mp->cur_type==mp_pair_type )
21295 mp_pair_to_path(mp);
21296 if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_known) )
21297 mp_flush_cur_exp(mp, mp_get_arc_time(mp, mp->cur_exp,value(p)));
21299 mp_bad_binary(mp, p,c);
21302 @ @<Additional cases of bin...@>=
21304 if ( type(p)==mp_pair_type ) {
21305 q=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, p);
21306 mp_pair_to_path(mp); p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q);
21308 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
21309 if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_path_type) ) {
21310 mp_path_intersection(mp, value(p),mp->cur_exp);
21311 mp_pair_value(mp, mp->cur_t,mp->cur_tt);
21313 mp_bad_binary(mp, p,intersect);
21317 @ @<Additional cases of bin...@>=
21319 if ( (mp->cur_type!=mp_string_type)||(type(p)!=mp_string_type))
21320 mp_bad_binary(mp, p,in_font);
21321 else { mp_do_infont(mp, p); binary_return; }
21324 @ Function |new_text_node| owns the reference count for its second argument
21325 (the text string) but not its first (the font name).
21327 @<Declare binary action...@>=
21328 void mp_do_infont (MP mp,pointer p) {
21330 q=mp_get_node(mp, edge_header_size);
21331 mp_init_edges(mp, q);
21332 link(obj_tail(q))=mp_new_text_node(mp,str(mp->cur_exp),value(p));
21333 obj_tail(q)=link(obj_tail(q));
21334 mp_free_node(mp, p,value_node_size);
21335 mp_flush_cur_exp(mp, q);
21336 mp->cur_type=mp_picture_type;
21339 @* \[40] Statements and commands.
21340 The chief executive of \MP\ is the |do_statement| routine, which
21341 contains the master switch that causes all the various pieces of \MP\
21342 to do their things, in the right order.
21344 In a sense, this is the grand climax of the program: It applies all the
21345 tools that we have worked so hard to construct. In another sense, this is
21346 the messiest part of the program: It necessarily refers to other pieces
21347 of code all over the place, so that a person can't fully understand what is
21348 going on without paging back and forth to be reminded of conventions that
21349 are defined elsewhere. We are now at the hub of the web.
21351 The structure of |do_statement| itself is quite simple. The first token
21352 of the statement is fetched using |get_x_next|. If it can be the first
21353 token of an expression, we look for an equation, an assignment, or a
21354 title. Otherwise we use a \&{case} construction to branch at high speed to
21355 the appropriate routine for various and sundry other types of commands,
21356 each of which has an ``action procedure'' that does the necessary work.
21358 The program uses the fact that
21359 $$\hbox{|min_primary_command=max_statement_command=type_name|}$$
21360 to interpret a statement that starts with, e.g., `\&{string}',
21361 as a type declaration rather than a boolean expression.
21363 @c void mp_do_statement (MP mp) { /* governs \MP's activities */
21364 mp->cur_type=mp_vacuous; mp_get_x_next(mp);
21365 if ( mp->cur_cmd>max_primary_command ) {
21366 @<Worry about bad statement@>;
21367 } else if ( mp->cur_cmd>max_statement_command ) {
21368 @<Do an equation, assignment, title, or
21369 `$\langle\,$expression$\,\rangle\,$\&{endgroup}'@>;
21371 @<Do a statement that doesn't begin with an expression@>;
21373 if ( mp->cur_cmd<semicolon )
21374 @<Flush unparsable junk that was found after the statement@>;
21378 @ @<Declarations@>=
21379 @<Declare action procedures for use by |do_statement|@>
21381 @ The only command codes |>max_primary_command| that can be present
21382 at the beginning of a statement are |semicolon| and higher; these
21383 occur when the statement is null.
21385 @<Worry about bad statement@>=
21387 if ( mp->cur_cmd<semicolon ) {
21388 print_err("A statement can't begin with `");
21389 @.A statement can't begin with x@>
21390 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod); mp_print_char(mp, '\'');
21391 help5("I was looking for the beginning of a new statement.")
21392 ("If you just proceed without changing anything, I'll ignore")
21393 ("everything up to the next `;'. Please insert a semicolon")
21394 ("now in front of anything that you don't want me to delete.")
21395 ("(See Chapter 27 of The METAFONTbook for an example.)");
21396 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
21397 mp_back_error(mp); mp_get_x_next(mp);
21401 @ The help message printed here says that everything is flushed up to
21402 a semicolon, but actually the commands |end_group| and |stop| will
21403 also terminate a statement.
21405 @<Flush unparsable junk that was found after the statement@>=
21407 print_err("Extra tokens will be flushed");
21408 @.Extra tokens will be flushed@>
21409 help6("I've just read as much of that statement as I could fathom,")
21410 ("so a semicolon should have been next. It's very puzzling...")
21411 ("but I'll try to get myself back together, by ignoring")
21412 ("everything up to the next `;'. Please insert a semicolon")
21413 ("now in front of anything that you don't want me to delete.")
21414 ("(See Chapter 27 of The METAFONTbook for an example.)");
21415 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
21416 mp_back_error(mp); mp->scanner_status=flushing;
21419 @<Decrease the string reference count...@>;
21420 } while (! end_of_statement); /* |cur_cmd=semicolon|, |end_group|, or |stop| */
21421 mp->scanner_status=normal;
21424 @ If |do_statement| ends with |cur_cmd=end_group|, we should have
21425 |cur_type=mp_vacuous| unless the statement was simply an expression;
21426 in the latter case, |cur_type| and |cur_exp| should represent that
21429 @<Do a statement that doesn't...@>=
21431 if ( mp->internal[mp_tracing_commands]>0 )
21433 switch (mp->cur_cmd ) {
21434 case type_name:mp_do_type_declaration(mp); break;
21436 if ( mp->cur_mod>var_def ) mp_make_op_def(mp);
21437 else if ( mp->cur_mod>end_def ) mp_scan_def(mp);
21439 @<Cases of |do_statement| that invoke particular commands@>;
21440 } /* there are no other cases */
21441 mp->cur_type=mp_vacuous;
21444 @ The most important statements begin with expressions.
21446 @<Do an equation, assignment, title, or...@>=
21448 mp->var_flag=assignment; mp_scan_expression(mp);
21449 if ( mp->cur_cmd<end_group ) {
21450 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21451 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21452 else if ( mp->cur_type==mp_string_type ) {@<Do a title@> ; }
21453 else if ( mp->cur_type!=mp_vacuous ){
21454 exp_err("Isolated expression");
21455 @.Isolated expression@>
21456 help3("I couldn't find an `=' or `:=' after the")
21457 ("expression that is shown above this error message,")
21458 ("so I guess I'll just ignore it and carry on.");
21459 mp_put_get_error(mp);
21461 mp_flush_cur_exp(mp, 0); mp->cur_type=mp_vacuous;
21467 if ( mp->internal[mp_tracing_titles]>0 ) {
21468 mp_print_nl(mp, ""); mp_print_str(mp, mp->cur_exp); update_terminal;
21472 @ Equations and assignments are performed by the pair of mutually recursive
21474 routines |do_equation| and |do_assignment|. These routines are called when
21475 |cur_cmd=equals| and when |cur_cmd=assignment|, respectively; the left-hand
21476 side is in |cur_type| and |cur_exp|, while the right-hand side is yet
21477 to be scanned. After the routines are finished, |cur_type| and |cur_exp|
21478 will be equal to the right-hand side (which will normally be equal
21479 to the left-hand side).
21481 @<Declare action procedures for use by |do_statement|@>=
21482 @<Declare the procedure called |try_eq|@>
21483 @<Declare the procedure called |make_eq|@>
21484 void mp_do_equation (MP mp) ;
21487 void mp_do_equation (MP mp) {
21488 pointer lhs; /* capsule for the left-hand side */
21489 pointer p; /* temporary register */
21490 lhs=mp_stash_cur_exp(mp); mp_get_x_next(mp);
21491 mp->var_flag=assignment; mp_scan_expression(mp);
21492 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21493 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21494 if ( mp->internal[mp_tracing_commands]>two )
21495 @<Trace the current equation@>;
21496 if ( mp->cur_type==mp_unknown_path ) if ( type(lhs)==mp_pair_type ) {
21497 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, lhs); lhs=p;
21498 }; /* in this case |make_eq| will change the pair to a path */
21499 mp_make_eq(mp, lhs); /* equate |lhs| to |(cur_type,cur_exp)| */
21502 @ And |do_assignment| is similar to |do_equation|:
21505 void mp_do_assignment (MP mp);
21507 @ @<Declare action procedures for use by |do_statement|@>=
21508 void mp_do_assignment (MP mp) ;
21511 void mp_do_assignment (MP mp) {
21512 pointer lhs; /* token list for the left-hand side */
21513 pointer p; /* where the left-hand value is stored */
21514 pointer q; /* temporary capsule for the right-hand value */
21515 if ( mp->cur_type!=mp_token_list ) {
21516 exp_err("Improper `:=' will be changed to `='");
21518 help2("I didn't find a variable name at the left of the `:=',")
21519 ("so I'm going to pretend that you said `=' instead.");
21520 mp_error(mp); mp_do_equation(mp);
21522 lhs=mp->cur_exp; mp->cur_type=mp_vacuous;
21523 mp_get_x_next(mp); mp->var_flag=assignment; mp_scan_expression(mp);
21524 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21525 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21526 if ( mp->internal[mp_tracing_commands]>two )
21527 @<Trace the current assignment@>;
21528 if ( info(lhs)>hash_end ) {
21529 @<Assign the current expression to an internal variable@>;
21531 @<Assign the current expression to the variable |lhs|@>;
21533 mp_flush_node_list(mp, lhs);
21537 @ @<Trace the current equation@>=
21539 mp_begin_diagnostic(mp); mp_print_nl(mp, "{("); mp_print_exp(mp,lhs,0);
21540 mp_print(mp,")=("); mp_print_exp(mp,null,0);
21541 mp_print(mp,")}"); mp_end_diagnostic(mp, false);
21544 @ @<Trace the current assignment@>=
21546 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
21547 if ( info(lhs)>hash_end )
21548 mp_print(mp, mp->int_name[info(lhs)-(hash_end)]);
21550 mp_show_token_list(mp, lhs,null,1000,0);
21551 mp_print(mp, ":="); mp_print_exp(mp, null,0);
21552 mp_print_char(mp, '}'); mp_end_diagnostic(mp, false);
21555 @ @<Assign the current expression to an internal variable@>=
21556 if ( mp->cur_type==mp_known ) {
21557 mp->internal[info(lhs)-(hash_end)]=mp->cur_exp;
21559 exp_err("Internal quantity `");
21560 @.Internal quantity...@>
21561 mp_print(mp, mp->int_name[info(lhs)-(hash_end)]);
21562 mp_print(mp, "' must receive a known value");
21563 help2("I can\'t set an internal quantity to anything but a known")
21564 ("numeric value, so I'll have to ignore this assignment.");
21565 mp_put_get_error(mp);
21568 @ @<Assign the current expression to the variable |lhs|@>=
21570 p=mp_find_variable(mp, lhs);
21572 q=mp_stash_cur_exp(mp); mp->cur_type=mp_und_type(mp, p);
21573 mp_recycle_value(mp, p);
21574 type(p)=mp->cur_type; value(p)=null; mp_make_exp_copy(mp, p);
21575 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q); mp_make_eq(mp, p);
21577 mp_obliterated(mp, lhs); mp_put_get_error(mp);
21582 @ And now we get to the nitty-gritty. The |make_eq| procedure is given
21583 a pointer to a capsule that is to be equated to the current expression.
21585 @<Declare the procedure called |make_eq|@>=
21586 void mp_make_eq (MP mp,pointer lhs) ;
21590 @c void mp_make_eq (MP mp,pointer lhs) {
21591 small_number t; /* type of the left-hand side */
21592 pointer p,q; /* pointers inside of big nodes */
21593 integer v=0; /* value of the left-hand side */
21596 if ( t<=mp_pair_type ) v=value(lhs);
21598 @<For each type |t|, make an equation and |goto done| unless |cur_type|
21599 is incompatible with~|t|@>;
21600 } /* all cases have been listed */
21601 @<Announce that the equation cannot be performed@>;
21603 check_arith; mp_recycle_value(mp, lhs);
21604 mp_free_node(mp, lhs,value_node_size);
21607 @ @<Announce that the equation cannot be performed@>=
21608 mp_disp_err(mp, lhs,"");
21609 exp_err("Equation cannot be performed (");
21610 @.Equation cannot be performed@>
21611 if ( type(lhs)<=mp_pair_type ) mp_print_type(mp, type(lhs));
21612 else mp_print(mp, "numeric");
21613 mp_print_char(mp, '=');
21614 if ( mp->cur_type<=mp_pair_type ) mp_print_type(mp, mp->cur_type);
21615 else mp_print(mp, "numeric");
21616 mp_print_char(mp, ')');
21617 help2("I'm sorry, but I don't know how to make such things equal.")
21618 ("(See the two expressions just above the error message.)");
21619 mp_put_get_error(mp)
21621 @ @<For each type |t|, make an equation and |goto done| unless...@>=
21622 case mp_boolean_type: case mp_string_type: case mp_pen_type:
21623 case mp_path_type: case mp_picture_type:
21624 if ( mp->cur_type==t+unknown_tag ) {
21625 mp_nonlinear_eq(mp, v,mp->cur_exp,false);
21626 mp_unstash_cur_exp(mp, mp->cur_exp); goto DONE;
21627 } else if ( mp->cur_type==t ) {
21628 @<Report redundant or inconsistent equation and |goto done|@>;
21631 case unknown_types:
21632 if ( mp->cur_type==t-unknown_tag ) {
21633 mp_nonlinear_eq(mp, mp->cur_exp,lhs,true); goto DONE;
21634 } else if ( mp->cur_type==t ) {
21635 mp_ring_merge(mp, lhs,mp->cur_exp); goto DONE;
21636 } else if ( mp->cur_type==mp_pair_type ) {
21637 if ( t==mp_unknown_path ) {
21638 mp_pair_to_path(mp); goto RESTART;
21642 case mp_transform_type: case mp_color_type:
21643 case mp_cmykcolor_type: case mp_pair_type:
21644 if ( mp->cur_type==t ) {
21645 @<Do multiple equations and |goto done|@>;
21648 case mp_known: case mp_dependent:
21649 case mp_proto_dependent: case mp_independent:
21650 if ( mp->cur_type>=mp_known ) {
21651 mp_try_eq(mp, lhs,null); goto DONE;
21657 @ @<Report redundant or inconsistent equation and |goto done|@>=
21659 if ( mp->cur_type<=mp_string_type ) {
21660 if ( mp->cur_type==mp_string_type ) {
21661 if ( mp_str_vs_str(mp, v,mp->cur_exp)!=0 ) {
21664 } else if ( v!=mp->cur_exp ) {
21667 @<Exclaim about a redundant equation@>; goto DONE;
21669 print_err("Redundant or inconsistent equation");
21670 @.Redundant or inconsistent equation@>
21671 help2("An equation between already-known quantities can't help.")
21672 ("But don't worry; continue and I'll just ignore it.");
21673 mp_put_get_error(mp); goto DONE;
21675 print_err("Inconsistent equation");
21676 @.Inconsistent equation@>
21677 help2("The equation I just read contradicts what was said before.")
21678 ("But don't worry; continue and I'll just ignore it.");
21679 mp_put_get_error(mp); goto DONE;
21682 @ @<Do multiple equations and |goto done|@>=
21684 p=v+mp->big_node_size[t];
21685 q=value(mp->cur_exp)+mp->big_node_size[t];
21687 p=p-2; q=q-2; mp_try_eq(mp, p,q);
21692 @ The first argument to |try_eq| is the location of a value node
21693 in a capsule that will soon be recycled. The second argument is
21694 either a location within a pair or transform node pointed to by
21695 |cur_exp|, or it is |null| (which means that |cur_exp| itself
21696 serves as the second argument). The idea is to leave |cur_exp| unchanged,
21697 but to equate the two operands.
21699 @<Declare the procedure called |try_eq|@>=
21700 void mp_try_eq (MP mp,pointer l, pointer r) ;
21703 @c void mp_try_eq (MP mp,pointer l, pointer r) {
21704 pointer p; /* dependency list for right operand minus left operand */
21705 int t; /* the type of list |p| */
21706 pointer q; /* the constant term of |p| is here */
21707 pointer pp; /* dependency list for right operand */
21708 int tt; /* the type of list |pp| */
21709 boolean copied; /* have we copied a list that ought to be recycled? */
21710 @<Remove the left operand from its container, negate it, and
21711 put it into dependency list~|p| with constant term~|q|@>;
21712 @<Add the right operand to list |p|@>;
21713 if ( info(p)==null ) {
21714 @<Deal with redundant or inconsistent equation@>;
21716 mp_linear_eq(mp, p,t);
21717 if ( r==null ) if ( mp->cur_type!=mp_known ) {
21718 if ( type(mp->cur_exp)==mp_known ) {
21719 pp=mp->cur_exp; mp->cur_exp=value(mp->cur_exp); mp->cur_type=mp_known;
21720 mp_free_node(mp, pp,value_node_size);
21726 @ @<Remove the left operand from its container, negate it, and...@>=
21728 if ( t==mp_known ) {
21729 t=mp_dependent; p=mp_const_dependency(mp, -value(l)); q=p;
21730 } else if ( t==mp_independent ) {
21731 t=mp_dependent; p=mp_single_dependency(mp, l); negate(value(p));
21734 p=dep_list(l); q=p;
21737 if ( info(q)==null ) break;
21740 link(prev_dep(l))=link(q); prev_dep(link(q))=prev_dep(l);
21744 @ @<Deal with redundant or inconsistent equation@>=
21746 if ( abs(value(p))>64 ) { /* off by .001 or more */
21747 print_err("Inconsistent equation");
21748 @.Inconsistent equation@>
21749 mp_print(mp, " (off by "); mp_print_scaled(mp, value(p));
21750 mp_print_char(mp, ')');
21751 help2("The equation I just read contradicts what was said before.")
21752 ("But don't worry; continue and I'll just ignore it.");
21753 mp_put_get_error(mp);
21754 } else if ( r==null ) {
21755 @<Exclaim about a redundant equation@>;
21757 mp_free_node(mp, p,dep_node_size);
21760 @ @<Add the right operand to list |p|@>=
21762 if ( mp->cur_type==mp_known ) {
21763 value(q)=value(q)+mp->cur_exp; goto DONE1;
21766 if ( tt==mp_independent ) pp=mp_single_dependency(mp, mp->cur_exp);
21767 else pp=dep_list(mp->cur_exp);
21770 if ( type(r)==mp_known ) {
21771 value(q)=value(q)+value(r); goto DONE1;
21774 if ( tt==mp_independent ) pp=mp_single_dependency(mp, r);
21775 else pp=dep_list(r);
21778 if ( tt!=mp_independent ) copied=false;
21779 else { copied=true; tt=mp_dependent; };
21780 @<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>;
21781 if ( copied ) mp_flush_node_list(mp, pp);
21784 @ @<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>=
21785 mp->watch_coefs=false;
21787 p=mp_p_plus_q(mp, p,pp,t);
21788 } else if ( t==mp_proto_dependent ) {
21789 p=mp_p_plus_fq(mp, p,unity,pp,mp_proto_dependent,mp_dependent);
21792 while ( info(q)!=null ) {
21793 value(q)=mp_round_fraction(mp, value(q)); q=link(q);
21795 t=mp_proto_dependent; p=mp_p_plus_q(mp, p,pp,t);
21797 mp->watch_coefs=true;
21799 @ Our next goal is to process type declarations. For this purpose it's
21800 convenient to have a procedure that scans a $\langle\,$declared
21801 variable$\,\rangle$ and returns the corresponding token list. After the
21802 following procedure has acted, the token after the declared variable
21803 will have been scanned, so it will appear in |cur_cmd|, |cur_mod|,
21806 @<Declare the function called |scan_declared_variable|@>=
21807 pointer mp_scan_declared_variable (MP mp) {
21808 pointer x; /* hash address of the variable's root */
21809 pointer h,t; /* head and tail of the token list to be returned */
21810 pointer l; /* hash address of left bracket */
21811 mp_get_symbol(mp); x=mp->cur_sym;
21812 if ( mp->cur_cmd!=tag_token ) mp_clear_symbol(mp, x,false);
21813 h=mp_get_avail(mp); info(h)=x; t=h;
21816 if ( mp->cur_sym==0 ) break;
21817 if ( mp->cur_cmd!=tag_token ) if ( mp->cur_cmd!=internal_quantity) {
21818 if ( mp->cur_cmd==left_bracket ) {
21819 @<Descend past a collective subscript@>;
21824 link(t)=mp_get_avail(mp); t=link(t); info(t)=mp->cur_sym;
21826 if ( (eq_type(x)%outer_tag)!=tag_token ) mp_clear_symbol(mp, x,false);
21827 if ( equiv(x)==null ) mp_new_root(mp, x);
21831 @ If the subscript isn't collective, we don't accept it as part of the
21834 @<Descend past a collective subscript@>=
21836 l=mp->cur_sym; mp_get_x_next(mp);
21837 if ( mp->cur_cmd!=right_bracket ) {
21838 mp_back_input(mp); mp->cur_sym=l; mp->cur_cmd=left_bracket; break;
21840 mp->cur_sym=collective_subscript;
21844 @ Type declarations are introduced by the following primitive operations.
21847 mp_primitive(mp, "numeric",type_name,mp_numeric_type);
21848 @:numeric_}{\&{numeric} primitive@>
21849 mp_primitive(mp, "string",type_name,mp_string_type);
21850 @:string_}{\&{string} primitive@>
21851 mp_primitive(mp, "boolean",type_name,mp_boolean_type);
21852 @:boolean_}{\&{boolean} primitive@>
21853 mp_primitive(mp, "path",type_name,mp_path_type);
21854 @:path_}{\&{path} primitive@>
21855 mp_primitive(mp, "pen",type_name,mp_pen_type);
21856 @:pen_}{\&{pen} primitive@>
21857 mp_primitive(mp, "picture",type_name,mp_picture_type);
21858 @:picture_}{\&{picture} primitive@>
21859 mp_primitive(mp, "transform",type_name,mp_transform_type);
21860 @:transform_}{\&{transform} primitive@>
21861 mp_primitive(mp, "color",type_name,mp_color_type);
21862 @:color_}{\&{color} primitive@>
21863 mp_primitive(mp, "rgbcolor",type_name,mp_color_type);
21864 @:color_}{\&{rgbcolor} primitive@>
21865 mp_primitive(mp, "cmykcolor",type_name,mp_cmykcolor_type);
21866 @:color_}{\&{cmykcolor} primitive@>
21867 mp_primitive(mp, "pair",type_name,mp_pair_type);
21868 @:pair_}{\&{pair} primitive@>
21870 @ @<Cases of |print_cmd...@>=
21871 case type_name: mp_print_type(mp, m); break;
21873 @ Now we are ready to handle type declarations, assuming that a
21874 |type_name| has just been scanned.
21876 @<Declare action procedures for use by |do_statement|@>=
21877 void mp_do_type_declaration (MP mp) ;
21880 void mp_do_type_declaration (MP mp) {
21881 small_number t; /* the type being declared */
21882 pointer p; /* token list for a declared variable */
21883 pointer q; /* value node for the variable */
21884 if ( mp->cur_mod>=mp_transform_type )
21887 t=mp->cur_mod+unknown_tag;
21889 p=mp_scan_declared_variable(mp);
21890 mp_flush_variable(mp, equiv(info(p)),link(p),false);
21891 q=mp_find_variable(mp, p);
21893 type(q)=t; value(q)=null;
21895 print_err("Declared variable conflicts with previous vardef");
21896 @.Declared variable conflicts...@>
21897 help2("You can't use, e.g., `numeric foo[]' after `vardef foo'.")
21898 ("Proceed, and I'll ignore the illegal redeclaration.");
21899 mp_put_get_error(mp);
21901 mp_flush_list(mp, p);
21902 if ( mp->cur_cmd<comma ) {
21903 @<Flush spurious symbols after the declared variable@>;
21905 } while (! end_of_statement);
21908 @ @<Flush spurious symbols after the declared variable@>=
21910 print_err("Illegal suffix of declared variable will be flushed");
21911 @.Illegal suffix...flushed@>
21912 help5("Variables in declarations must consist entirely of")
21913 ("names and collective subscripts, e.g., `x[]a'.")
21914 ("Are you trying to use a reserved word in a variable name?")
21915 ("I'm going to discard the junk I found here,")
21916 ("up to the next comma or the end of the declaration.");
21917 if ( mp->cur_cmd==numeric_token )
21918 mp->help_line[2]="Explicit subscripts like `x15a' aren't permitted.";
21919 mp_put_get_error(mp); mp->scanner_status=flushing;
21922 @<Decrease the string reference count...@>;
21923 } while (mp->cur_cmd<comma); /* either |end_of_statement| or |cur_cmd=comma| */
21924 mp->scanner_status=normal;
21927 @ \MP's |main_control| procedure just calls |do_statement| repeatedly
21928 until coming to the end of the user's program.
21929 Each execution of |do_statement| concludes with
21930 |cur_cmd=semicolon|, |end_group|, or |stop|.
21932 @c void mp_main_control (MP mp) {
21934 mp_do_statement(mp);
21935 if ( mp->cur_cmd==end_group ) {
21936 print_err("Extra `endgroup'");
21937 @.Extra `endgroup'@>
21938 help2("I'm not currently working on a `begingroup',")
21939 ("so I had better not try to end anything.");
21940 mp_flush_error(mp, 0);
21942 } while (mp->cur_cmd!=stop);
21944 int __attribute__((noinline))
21947 if (mp->history < mp_fatal_error_stop ) {
21948 @<Install and test the non-local jump buffer@>;
21949 mp_main_control(mp); /* come to life */
21950 mp_final_cleanup(mp); /* prepare for death */
21951 mp_close_files_and_terminate(mp);
21953 return mp->history;
21955 int __attribute__((noinline))
21956 mp_execute (MP mp) {
21958 if (mp->history < mp_fatal_error_stop ) {
21959 mp->history = mp_spotless;
21960 mp->file_offset = 0;
21961 mp->term_offset = 0;
21963 @<Install and test the non-local jump buffer@>;
21964 if (mp->run_state==0) {
21967 mp_input_ln(mp,mp->term_in);
21968 mp_firm_up_the_line(mp);
21969 mp->buffer[limit]='%';
21974 mp_do_statement(mp);
21975 } while (mp->cur_cmd!=stop);
21977 return mp->history;
21979 int __attribute__((noinline))
21980 mp_finish (MP mp) {
21982 if (mp->history < mp_fatal_error_stop ) {
21983 @<Install and test the non-local jump buffer@>;
21984 mp_final_cleanup(mp); /* prepare for death */
21985 mp_close_files_and_terminate(mp);
21987 return mp->history;
21989 const char * mp_mplib_version (MP mp) {
21991 return mplib_version;
21993 const char * mp_metapost_version (MP mp) {
21995 return metapost_version;
21998 @ @<Exported function headers@>=
21999 int mp_run (MP mp);
22000 int mp_execute (MP mp);
22001 int mp_finish (MP mp);
22002 const char * mp_mplib_version (MP mp);
22003 const char * mp_metapost_version (MP mp);
22006 mp_primitive(mp, "end",stop,0);
22007 @:end_}{\&{end} primitive@>
22008 mp_primitive(mp, "dump",stop,1);
22009 @:dump_}{\&{dump} primitive@>
22011 @ @<Cases of |print_cmd...@>=
22013 if ( m==0 ) mp_print(mp, "end");
22014 else mp_print(mp, "dump");
22018 Let's turn now to statements that are classified as ``commands'' because
22019 of their imperative nature. We'll begin with simple ones, so that it
22020 will be clear how to hook command processing into the |do_statement| routine;
22021 then we'll tackle the tougher commands.
22023 Here's one of the simplest:
22025 @<Cases of |do_statement|...@>=
22026 case mp_random_seed: mp_do_random_seed(mp); break;
22028 @ @<Declare action procedures for use by |do_statement|@>=
22029 void mp_do_random_seed (MP mp) ;
22031 @ @c void mp_do_random_seed (MP mp) {
22033 if ( mp->cur_cmd!=assignment ) {
22034 mp_missing_err(mp, ":=");
22036 help1("Always say `randomseed:=<numeric expression>'.");
22039 mp_get_x_next(mp); mp_scan_expression(mp);
22040 if ( mp->cur_type!=mp_known ) {
22041 exp_err("Unknown value will be ignored");
22042 @.Unknown value...ignored@>
22043 help2("Your expression was too random for me to handle,")
22044 ("so I won't change the random seed just now.");
22045 mp_put_get_flush_error(mp, 0);
22047 @<Initialize the random seed to |cur_exp|@>;
22051 @ @<Initialize the random seed to |cur_exp|@>=
22053 mp_init_randoms(mp, mp->cur_exp);
22054 if ( mp->selector>=log_only && mp->selector<write_file) {
22055 mp->old_setting=mp->selector; mp->selector=log_only;
22056 mp_print_nl(mp, "{randomseed:=");
22057 mp_print_scaled(mp, mp->cur_exp);
22058 mp_print_char(mp, '}');
22059 mp_print_nl(mp, ""); mp->selector=mp->old_setting;
22063 @ And here's another simple one (somewhat different in flavor):
22065 @<Cases of |do_statement|...@>=
22067 mp_print_ln(mp); mp->interaction=mp->cur_mod;
22068 @<Initialize the print |selector| based on |interaction|@>;
22069 if ( mp->log_opened ) mp->selector=mp->selector+2;
22074 mp_primitive(mp, "batchmode",mode_command,mp_batch_mode);
22075 @:mp_batch_mode_}{\&{batchmode} primitive@>
22076 mp_primitive(mp, "nonstopmode",mode_command,mp_nonstop_mode);
22077 @:mp_nonstop_mode_}{\&{nonstopmode} primitive@>
22078 mp_primitive(mp, "scrollmode",mode_command,mp_scroll_mode);
22079 @:mp_scroll_mode_}{\&{scrollmode} primitive@>
22080 mp_primitive(mp, "errorstopmode",mode_command,mp_error_stop_mode);
22081 @:mp_error_stop_mode_}{\&{errorstopmode} primitive@>
22083 @ @<Cases of |print_cmd_mod|...@>=
22086 case mp_batch_mode: mp_print(mp, "batchmode"); break;
22087 case mp_nonstop_mode: mp_print(mp, "nonstopmode"); break;
22088 case mp_scroll_mode: mp_print(mp, "scrollmode"); break;
22089 default: mp_print(mp, "errorstopmode"); break;
22093 @ The `\&{inner}' and `\&{outer}' commands are only slightly harder.
22095 @<Cases of |do_statement|...@>=
22096 case protection_command: mp_do_protection(mp); break;
22099 mp_primitive(mp, "inner",protection_command,0);
22100 @:inner_}{\&{inner} primitive@>
22101 mp_primitive(mp, "outer",protection_command,1);
22102 @:outer_}{\&{outer} primitive@>
22104 @ @<Cases of |print_cmd...@>=
22105 case protection_command:
22106 if ( m==0 ) mp_print(mp, "inner");
22107 else mp_print(mp, "outer");
22110 @ @<Declare action procedures for use by |do_statement|@>=
22111 void mp_do_protection (MP mp) ;
22113 @ @c void mp_do_protection (MP mp) {
22114 int m; /* 0 to unprotect, 1 to protect */
22115 halfword t; /* the |eq_type| before we change it */
22118 mp_get_symbol(mp); t=eq_type(mp->cur_sym);
22120 if ( t>=outer_tag )
22121 eq_type(mp->cur_sym)=t-outer_tag;
22122 } else if ( t<outer_tag ) {
22123 eq_type(mp->cur_sym)=t+outer_tag;
22126 } while (mp->cur_cmd==comma);
22129 @ \MP\ never defines the tokens `\.(' and `\.)' to be primitives, but
22130 plain \MP\ begins with the declaration `\&{delimiters} \.{()}'. Such a
22131 declaration assigns the command code |left_delimiter| to `\.{(}' and
22132 |right_delimiter| to `\.{)}'; the |equiv| of each delimiter is the
22133 hash address of its mate.
22135 @<Cases of |do_statement|...@>=
22136 case delimiters: mp_def_delims(mp); break;
22138 @ @<Declare action procedures for use by |do_statement|@>=
22139 void mp_def_delims (MP mp) ;
22141 @ @c void mp_def_delims (MP mp) {
22142 pointer l_delim,r_delim; /* the new delimiter pair */
22143 mp_get_clear_symbol(mp); l_delim=mp->cur_sym;
22144 mp_get_clear_symbol(mp); r_delim=mp->cur_sym;
22145 eq_type(l_delim)=left_delimiter; equiv(l_delim)=r_delim;
22146 eq_type(r_delim)=right_delimiter; equiv(r_delim)=l_delim;
22150 @ Here is a procedure that is called when \MP\ has reached a point
22151 where some right delimiter is mandatory.
22153 @<Declare the procedure called |check_delimiter|@>=
22154 void mp_check_delimiter (MP mp,pointer l_delim, pointer r_delim) {
22155 if ( mp->cur_cmd==right_delimiter )
22156 if ( mp->cur_mod==l_delim )
22158 if ( mp->cur_sym!=r_delim ) {
22159 mp_missing_err(mp, str(text(r_delim)));
22161 help2("I found no right delimiter to match a left one. So I've")
22162 ("put one in, behind the scenes; this may fix the problem.");
22165 print_err("The token `"); mp_print_text(r_delim);
22166 @.The token...delimiter@>
22167 mp_print(mp, "' is no longer a right delimiter");
22168 help3("Strange: This token has lost its former meaning!")
22169 ("I'll read it as a right delimiter this time;")
22170 ("but watch out, I'll probably miss it later.");
22175 @ The next four commands save or change the values associated with tokens.
22177 @<Cases of |do_statement|...@>=
22180 mp_get_symbol(mp); mp_save_variable(mp, mp->cur_sym); mp_get_x_next(mp);
22181 } while (mp->cur_cmd==comma);
22183 case interim_command: mp_do_interim(mp); break;
22184 case let_command: mp_do_let(mp); break;
22185 case new_internal: mp_do_new_internal(mp); break;
22187 @ @<Declare action procedures for use by |do_statement|@>=
22188 void mp_do_statement (MP mp);
22189 void mp_do_interim (MP mp);
22191 @ @c void mp_do_interim (MP mp) {
22193 if ( mp->cur_cmd!=internal_quantity ) {
22194 print_err("The token `");
22195 @.The token...quantity@>
22196 if ( mp->cur_sym==0 ) mp_print(mp, "(%CAPSULE)");
22197 else mp_print_text(mp->cur_sym);
22198 mp_print(mp, "' isn't an internal quantity");
22199 help1("Something like `tracingonline' should follow `interim'.");
22202 mp_save_internal(mp, mp->cur_mod); mp_back_input(mp);
22204 mp_do_statement(mp);
22207 @ The following procedure is careful not to undefine the left-hand symbol
22208 too soon, lest commands like `{\tt let x=x}' have a surprising effect.
22210 @<Declare action procedures for use by |do_statement|@>=
22211 void mp_do_let (MP mp) ;
22213 @ @c void mp_do_let (MP mp) {
22214 pointer l; /* hash location of the left-hand symbol */
22215 mp_get_symbol(mp); l=mp->cur_sym; mp_get_x_next(mp);
22216 if ( mp->cur_cmd!=equals ) if ( mp->cur_cmd!=assignment ) {
22217 mp_missing_err(mp, "=");
22219 help3("You should have said `let symbol = something'.")
22220 ("But don't worry; I'll pretend that an equals sign")
22221 ("was present. The next token I read will be `something'.");
22225 switch (mp->cur_cmd) {
22226 case defined_macro: case secondary_primary_macro:
22227 case tertiary_secondary_macro: case expression_tertiary_macro:
22228 add_mac_ref(mp->cur_mod);
22233 mp_clear_symbol(mp, l,false); eq_type(l)=mp->cur_cmd;
22234 if ( mp->cur_cmd==tag_token ) equiv(l)=null;
22235 else equiv(l)=mp->cur_mod;
22239 @ @<Declarations@>=
22240 void mp_grow_internals (MP mp, int l);
22241 void mp_do_new_internal (MP mp) ;
22244 void mp_grow_internals (MP mp, int l) {
22248 if ( hash_end+l>max_halfword ) {
22249 mp_confusion(mp, "out of memory space"); /* can't be reached */
22251 int_name = xmalloc ((l+1),sizeof(char *));
22252 internal = xmalloc ((l+1),sizeof(scaled));
22253 for (k=0;k<=l; k++ ) {
22254 if (k<=mp->max_internal) {
22255 internal[k]=mp->internal[k];
22256 int_name[k]=mp->int_name[k];
22262 xfree(mp->internal); xfree(mp->int_name);
22263 mp->int_name = int_name;
22264 mp->internal = internal;
22265 mp->max_internal = l;
22269 void mp_do_new_internal (MP mp) {
22271 if ( mp->int_ptr==mp->max_internal ) {
22272 mp_grow_internals(mp, (mp->max_internal + (mp->max_internal>>2)));
22274 mp_get_clear_symbol(mp); incr(mp->int_ptr);
22275 eq_type(mp->cur_sym)=internal_quantity;
22276 equiv(mp->cur_sym)=mp->int_ptr;
22277 if(mp->int_name[mp->int_ptr]!=NULL)
22278 xfree(mp->int_name[mp->int_ptr]);
22279 mp->int_name[mp->int_ptr]=str(text(mp->cur_sym));
22280 mp->internal[mp->int_ptr]=0;
22282 } while (mp->cur_cmd==comma);
22285 @ @<Dealloc variables@>=
22286 for (k=0;k<=mp->max_internal;k++) {
22287 xfree(mp->int_name[k]);
22289 xfree(mp->internal);
22290 xfree(mp->int_name);
22293 @ The various `\&{show}' commands are distinguished by modifier fields
22296 @d show_token_code 0 /* show the meaning of a single token */
22297 @d show_stats_code 1 /* show current memory and string usage */
22298 @d show_code 2 /* show a list of expressions */
22299 @d show_var_code 3 /* show a variable and its descendents */
22300 @d show_dependencies_code 4 /* show dependent variables in terms of independents */
22303 mp_primitive(mp, "showtoken",show_command,show_token_code);
22304 @:show_token_}{\&{showtoken} primitive@>
22305 mp_primitive(mp, "showstats",show_command,show_stats_code);
22306 @:show_stats_}{\&{showstats} primitive@>
22307 mp_primitive(mp, "show",show_command,show_code);
22308 @:show_}{\&{show} primitive@>
22309 mp_primitive(mp, "showvariable",show_command,show_var_code);
22310 @:show_var_}{\&{showvariable} primitive@>
22311 mp_primitive(mp, "showdependencies",show_command,show_dependencies_code);
22312 @:show_dependencies_}{\&{showdependencies} primitive@>
22314 @ @<Cases of |print_cmd...@>=
22317 case show_token_code:mp_print(mp, "showtoken"); break;
22318 case show_stats_code:mp_print(mp, "showstats"); break;
22319 case show_code:mp_print(mp, "show"); break;
22320 case show_var_code:mp_print(mp, "showvariable"); break;
22321 default: mp_print(mp, "showdependencies"); break;
22325 @ @<Cases of |do_statement|...@>=
22326 case show_command:mp_do_show_whatever(mp); break;
22328 @ The value of |cur_mod| controls the |verbosity| in the |print_exp| routine:
22329 if it's |show_code|, complicated structures are abbreviated, otherwise
22332 @<Declare action procedures for use by |do_statement|@>=
22333 void mp_do_show (MP mp) ;
22335 @ @c void mp_do_show (MP mp) {
22337 mp_get_x_next(mp); mp_scan_expression(mp);
22338 mp_print_nl(mp, ">> ");
22340 mp_print_exp(mp, null,2); mp_flush_cur_exp(mp, 0);
22341 } while (mp->cur_cmd==comma);
22344 @ @<Declare action procedures for use by |do_statement|@>=
22345 void mp_disp_token (MP mp) ;
22347 @ @c void mp_disp_token (MP mp) {
22348 mp_print_nl(mp, "> ");
22350 if ( mp->cur_sym==0 ) {
22351 @<Show a numeric or string or capsule token@>;
22353 mp_print_text(mp->cur_sym); mp_print_char(mp, '=');
22354 if ( eq_type(mp->cur_sym)>=outer_tag ) mp_print(mp, "(outer) ");
22355 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod);
22356 if ( mp->cur_cmd==defined_macro ) {
22357 mp_print_ln(mp); mp_show_macro(mp, mp->cur_mod,null,100000);
22358 } /* this avoids recursion between |show_macro| and |print_cmd_mod| */
22363 @ @<Show a numeric or string or capsule token@>=
22365 if ( mp->cur_cmd==numeric_token ) {
22366 mp_print_scaled(mp, mp->cur_mod);
22367 } else if ( mp->cur_cmd==capsule_token ) {
22368 mp_print_capsule(mp,mp->cur_mod);
22370 mp_print_char(mp, '"');
22371 mp_print_str(mp, mp->cur_mod); mp_print_char(mp, '"');
22372 delete_str_ref(mp->cur_mod);
22376 @ The following cases of |print_cmd_mod| might arise in connection
22377 with |disp_token|, although they don't necessarily correspond to
22380 @<Cases of |print_cmd_...@>=
22381 case left_delimiter:
22382 case right_delimiter:
22383 if ( c==left_delimiter ) mp_print(mp, "left");
22384 else mp_print(mp, "right");
22385 mp_print(mp, " delimiter that matches ");
22389 if ( m==null ) mp_print(mp, "tag");
22390 else mp_print(mp, "variable");
22392 case defined_macro:
22393 mp_print(mp, "macro:");
22395 case secondary_primary_macro:
22396 case tertiary_secondary_macro:
22397 case expression_tertiary_macro:
22398 mp_print_cmd_mod(mp, macro_def,c);
22399 mp_print(mp, "'d macro:");
22400 mp_print_ln(mp); mp_show_token_list(mp, link(link(m)),null,1000,0);
22403 mp_print(mp, "[repeat the loop]");
22405 case internal_quantity:
22406 mp_print(mp, mp->int_name[m]);
22409 @ @<Declare action procedures for use by |do_statement|@>=
22410 void mp_do_show_token (MP mp) ;
22412 @ @c void mp_do_show_token (MP mp) {
22414 get_t_next; mp_disp_token(mp);
22416 } while (mp->cur_cmd==comma);
22419 @ @<Declare action procedures for use by |do_statement|@>=
22420 void mp_do_show_stats (MP mp) ;
22422 @ @c void mp_do_show_stats (MP mp) {
22423 mp_print_nl(mp, "Memory usage ");
22424 @.Memory usage...@>
22425 mp_print_int(mp, mp->var_used); mp_print_char(mp, '&'); mp_print_int(mp, mp->dyn_used);
22426 mp_print(mp, " ("); mp_print_int(mp, mp->hi_mem_min-mp->lo_mem_max-1);
22427 mp_print(mp, " still untouched)"); mp_print_ln(mp);
22428 mp_print_nl(mp, "String usage ");
22429 mp_print_int(mp, mp->strs_in_use-mp->init_str_use);
22430 mp_print_char(mp, '&'); mp_print_int(mp, mp->pool_in_use-mp->init_pool_ptr);
22431 mp_print(mp, " (");
22432 mp_print_int(mp, mp->max_strings-1-mp->strs_used_up); mp_print_char(mp, '&');
22433 mp_print_int(mp, mp->pool_size-mp->pool_ptr);
22434 mp_print(mp, " now untouched)"); mp_print_ln(mp);
22438 @ Here's a recursive procedure that gives an abbreviated account
22439 of a variable, for use by |do_show_var|.
22441 @<Declare action procedures for use by |do_statement|@>=
22442 void mp_disp_var (MP mp,pointer p) ;
22444 @ @c void mp_disp_var (MP mp,pointer p) {
22445 pointer q; /* traverses attributes and subscripts */
22446 int n; /* amount of macro text to show */
22447 if ( type(p)==mp_structured ) {
22448 @<Descend the structure@>;
22449 } else if ( type(p)>=mp_unsuffixed_macro ) {
22450 @<Display a variable macro@>;
22451 } else if ( type(p)!=undefined ){
22452 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22453 mp_print_char(mp, '=');
22454 mp_print_exp(mp, p,0);
22458 @ @<Descend the structure@>=
22461 do { mp_disp_var(mp, q); q=link(q); } while (q!=end_attr);
22463 while ( name_type(q)==mp_subscr ) {
22464 mp_disp_var(mp, q); q=link(q);
22468 @ @<Display a variable macro@>=
22470 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22471 if ( type(p)>mp_unsuffixed_macro )
22472 mp_print(mp, "@@#"); /* |suffixed_macro| */
22473 mp_print(mp, "=macro:");
22474 if ( (int)mp->file_offset>=mp->max_print_line-20 ) n=5;
22475 else n=mp->max_print_line-mp->file_offset-15;
22476 mp_show_macro(mp, value(p),null,n);
22479 @ @<Declare action procedures for use by |do_statement|@>=
22480 void mp_do_show_var (MP mp) ;
22482 @ @c void mp_do_show_var (MP mp) {
22485 if ( mp->cur_sym>0 ) if ( mp->cur_sym<=hash_end )
22486 if ( mp->cur_cmd==tag_token ) if ( mp->cur_mod!=null ) {
22487 mp_disp_var(mp, mp->cur_mod); goto DONE;
22492 } while (mp->cur_cmd==comma);
22495 @ @<Declare action procedures for use by |do_statement|@>=
22496 void mp_do_show_dependencies (MP mp) ;
22498 @ @c void mp_do_show_dependencies (MP mp) {
22499 pointer p; /* link that runs through all dependencies */
22501 while ( p!=dep_head ) {
22502 if ( mp_interesting(mp, p) ) {
22503 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22504 if ( type(p)==mp_dependent ) mp_print_char(mp, '=');
22505 else mp_print(mp, " = "); /* extra spaces imply proto-dependency */
22506 mp_print_dependency(mp, dep_list(p),type(p));
22509 while ( info(p)!=null ) p=link(p);
22515 @ Finally we are ready for the procedure that governs all of the
22518 @<Declare action procedures for use by |do_statement|@>=
22519 void mp_do_show_whatever (MP mp) ;
22521 @ @c void mp_do_show_whatever (MP mp) {
22522 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
22523 switch (mp->cur_mod) {
22524 case show_token_code:mp_do_show_token(mp); break;
22525 case show_stats_code:mp_do_show_stats(mp); break;
22526 case show_code:mp_do_show(mp); break;
22527 case show_var_code:mp_do_show_var(mp); break;
22528 case show_dependencies_code:mp_do_show_dependencies(mp); break;
22529 } /* there are no other cases */
22530 if ( mp->internal[mp_showstopping]>0 ){
22533 if ( mp->interaction<mp_error_stop_mode ) {
22534 help0; decr(mp->error_count);
22536 help1("This isn't an error message; I'm just showing something.");
22538 if ( mp->cur_cmd==semicolon ) mp_error(mp);
22539 else mp_put_get_error(mp);
22543 @ The `\&{addto}' command needs the following additional primitives:
22545 @d double_path_code 0 /* command modifier for `\&{doublepath}' */
22546 @d contour_code 1 /* command modifier for `\&{contour}' */
22547 @d also_code 2 /* command modifier for `\&{also}' */
22549 @ Pre and postscripts need two new identifiers:
22551 @d with_pre_script 11
22552 @d with_post_script 13
22555 mp_primitive(mp, "doublepath",thing_to_add,double_path_code);
22556 @:double_path_}{\&{doublepath} primitive@>
22557 mp_primitive(mp, "contour",thing_to_add,contour_code);
22558 @:contour_}{\&{contour} primitive@>
22559 mp_primitive(mp, "also",thing_to_add,also_code);
22560 @:also_}{\&{also} primitive@>
22561 mp_primitive(mp, "withpen",with_option,mp_pen_type);
22562 @:with_pen_}{\&{withpen} primitive@>
22563 mp_primitive(mp, "dashed",with_option,mp_picture_type);
22564 @:dashed_}{\&{dashed} primitive@>
22565 mp_primitive(mp, "withprescript",with_option,with_pre_script);
22566 @:with_pre_script_}{\&{withprescript} primitive@>
22567 mp_primitive(mp, "withpostscript",with_option,with_post_script);
22568 @:with_post_script_}{\&{withpostscript} primitive@>
22569 mp_primitive(mp, "withoutcolor",with_option,mp_no_model);
22570 @:with_color_}{\&{withoutcolor} primitive@>
22571 mp_primitive(mp, "withgreyscale",with_option,mp_grey_model);
22572 @:with_color_}{\&{withgreyscale} primitive@>
22573 mp_primitive(mp, "withcolor",with_option,mp_uninitialized_model);
22574 @:with_color_}{\&{withcolor} primitive@>
22575 /* \&{withrgbcolor} is an alias for \&{withcolor} */
22576 mp_primitive(mp, "withrgbcolor",with_option,mp_rgb_model);
22577 @:with_color_}{\&{withrgbcolor} primitive@>
22578 mp_primitive(mp, "withcmykcolor",with_option,mp_cmyk_model);
22579 @:with_color_}{\&{withcmykcolor} primitive@>
22581 @ @<Cases of |print_cmd...@>=
22583 if ( m==contour_code ) mp_print(mp, "contour");
22584 else if ( m==double_path_code ) mp_print(mp, "doublepath");
22585 else mp_print(mp, "also");
22588 if ( m==mp_pen_type ) mp_print(mp, "withpen");
22589 else if ( m==with_pre_script ) mp_print(mp, "withprescript");
22590 else if ( m==with_post_script ) mp_print(mp, "withpostscript");
22591 else if ( m==mp_no_model ) mp_print(mp, "withoutcolor");
22592 else if ( m==mp_rgb_model ) mp_print(mp, "withrgbcolor");
22593 else if ( m==mp_uninitialized_model ) mp_print(mp, "withcolor");
22594 else if ( m==mp_cmyk_model ) mp_print(mp, "withcmykcolor");
22595 else if ( m==mp_grey_model ) mp_print(mp, "withgreyscale");
22596 else mp_print(mp, "dashed");
22599 @ The |scan_with_list| procedure parses a $\langle$with list$\rangle$ and
22600 updates the list of graphical objects starting at |p|. Each $\langle$with
22601 clause$\rangle$ updates all graphical objects whose |type| is compatible.
22602 Other objects are ignored.
22604 @<Declare action procedures for use by |do_statement|@>=
22605 void mp_scan_with_list (MP mp,pointer p) ;
22607 @ @c void mp_scan_with_list (MP mp,pointer p) {
22608 small_number t; /* |cur_mod| of the |with_option| (should match |cur_type|) */
22609 pointer q; /* for list manipulation */
22610 int old_setting; /* saved |selector| setting */
22611 pointer k; /* for finding the near-last item in a list */
22612 str_number s; /* for string cleanup after combining */
22613 pointer cp,pp,dp,ap,bp;
22614 /* objects being updated; |void| initially; |null| to suppress update */
22615 cp=mp_void; pp=mp_void; dp=mp_void; ap=mp_void; bp=mp_void;
22617 while ( mp->cur_cmd==with_option ){
22620 if ( t!=mp_no_model ) mp_scan_expression(mp);
22621 if (((t==with_pre_script)&&(mp->cur_type!=mp_string_type))||
22622 ((t==with_post_script)&&(mp->cur_type!=mp_string_type))||
22623 ((t==mp_uninitialized_model)&&
22624 ((mp->cur_type!=mp_cmykcolor_type)&&(mp->cur_type!=mp_color_type)
22625 &&(mp->cur_type!=mp_known)&&(mp->cur_type!=mp_boolean_type)))||
22626 ((t==mp_cmyk_model)&&(mp->cur_type!=mp_cmykcolor_type))||
22627 ((t==mp_rgb_model)&&(mp->cur_type!=mp_color_type))||
22628 ((t==mp_grey_model)&&(mp->cur_type!=mp_known))||
22629 ((t==mp_pen_type)&&(mp->cur_type!=t))||
22630 ((t==mp_picture_type)&&(mp->cur_type!=t)) ) {
22631 @<Complain about improper type@>;
22632 } else if ( t==mp_uninitialized_model ) {
22633 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22635 @<Transfer a color from the current expression to object~|cp|@>;
22636 mp_flush_cur_exp(mp, 0);
22637 } else if ( t==mp_rgb_model ) {
22638 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22640 @<Transfer a rgbcolor from the current expression to object~|cp|@>;
22641 mp_flush_cur_exp(mp, 0);
22642 } else if ( t==mp_cmyk_model ) {
22643 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22645 @<Transfer a cmykcolor from the current expression to object~|cp|@>;
22646 mp_flush_cur_exp(mp, 0);
22647 } else if ( t==mp_grey_model ) {
22648 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22650 @<Transfer a greyscale from the current expression to object~|cp|@>;
22651 mp_flush_cur_exp(mp, 0);
22652 } else if ( t==mp_no_model ) {
22653 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22655 @<Transfer a noncolor from the current expression to object~|cp|@>;
22656 } else if ( t==mp_pen_type ) {
22657 if ( pp==mp_void ) @<Make |pp| an object in list~|p| that needs a pen@>;
22659 if ( pen_p(pp)!=null ) mp_toss_knot_list(mp, pen_p(pp));
22660 pen_p(pp)=mp->cur_exp; mp->cur_type=mp_vacuous;
22662 } else if ( t==with_pre_script ) {
22665 while ( (ap!=null)&&(! has_color(ap)) )
22668 if ( pre_script(ap)!=null ) { /* build a new,combined string */
22670 old_setting=mp->selector;
22671 mp->selector=new_string;
22672 str_room(length(pre_script(ap))+length(mp->cur_exp)+2);
22673 mp_print_str(mp, mp->cur_exp);
22674 append_char(13); /* a forced \ps\ newline */
22675 mp_print_str(mp, pre_script(ap));
22676 pre_script(ap)=mp_make_string(mp);
22678 mp->selector=old_setting;
22680 pre_script(ap)=mp->cur_exp;
22682 mp->cur_type=mp_vacuous;
22684 } else if ( t==with_post_script ) {
22688 while ( link(k)!=null ) {
22690 if ( has_color(k) ) bp=k;
22693 if ( post_script(bp)!=null ) {
22695 old_setting=mp->selector;
22696 mp->selector=new_string;
22697 str_room(length(post_script(bp))+length(mp->cur_exp)+2);
22698 mp_print_str(mp, post_script(bp));
22699 append_char(13); /* a forced \ps\ newline */
22700 mp_print_str(mp, mp->cur_exp);
22701 post_script(bp)=mp_make_string(mp);
22703 mp->selector=old_setting;
22705 post_script(bp)=mp->cur_exp;
22707 mp->cur_type=mp_vacuous;
22710 if ( dp==mp_void ) {
22711 @<Make |dp| a stroked node in list~|p|@>;
22714 if ( dash_p(dp)!=null ) delete_edge_ref(dash_p(dp));
22715 dash_p(dp)=mp_make_dashes(mp, mp->cur_exp);
22716 dash_scale(dp)=unity;
22717 mp->cur_type=mp_vacuous;
22721 @<Copy the information from objects |cp|, |pp|, and |dp| into the rest
22725 @ @<Complain about improper type@>=
22726 { exp_err("Improper type");
22728 help2("Next time say `withpen <known pen expression>';")
22729 ("I'll ignore the bad `with' clause and look for another.");
22730 if ( t==with_pre_script )
22731 mp->help_line[1]="Next time say `withprescript <known string expression>';";
22732 else if ( t==with_post_script )
22733 mp->help_line[1]="Next time say `withpostscript <known string expression>';";
22734 else if ( t==mp_picture_type )
22735 mp->help_line[1]="Next time say `dashed <known picture expression>';";
22736 else if ( t==mp_uninitialized_model )
22737 mp->help_line[1]="Next time say `withcolor <known color expression>';";
22738 else if ( t==mp_rgb_model )
22739 mp->help_line[1]="Next time say `withrgbcolor <known color expression>';";
22740 else if ( t==mp_cmyk_model )
22741 mp->help_line[1]="Next time say `withcmykcolor <known cmykcolor expression>';";
22742 else if ( t==mp_grey_model )
22743 mp->help_line[1]="Next time say `withgreyscale <known numeric expression>';";;
22744 mp_put_get_flush_error(mp, 0);
22747 @ Forcing the color to be between |0| and |unity| here guarantees that no
22748 picture will ever contain a color outside the legal range for \ps\ graphics.
22750 @<Transfer a color from the current expression to object~|cp|@>=
22751 { if ( mp->cur_type==mp_color_type )
22752 @<Transfer a rgbcolor from the current expression to object~|cp|@>
22753 else if ( mp->cur_type==mp_cmykcolor_type )
22754 @<Transfer a cmykcolor from the current expression to object~|cp|@>
22755 else if ( mp->cur_type==mp_known )
22756 @<Transfer a greyscale from the current expression to object~|cp|@>
22757 else if ( mp->cur_exp==false_code )
22758 @<Transfer a noncolor from the current expression to object~|cp|@>;
22761 @ @<Transfer a rgbcolor from the current expression to object~|cp|@>=
22762 { q=value(mp->cur_exp);
22767 red_val(cp)=value(red_part_loc(q));
22768 green_val(cp)=value(green_part_loc(q));
22769 blue_val(cp)=value(blue_part_loc(q));
22770 color_model(cp)=mp_rgb_model;
22771 if ( red_val(cp)<0 ) red_val(cp)=0;
22772 if ( green_val(cp)<0 ) green_val(cp)=0;
22773 if ( blue_val(cp)<0 ) blue_val(cp)=0;
22774 if ( red_val(cp)>unity ) red_val(cp)=unity;
22775 if ( green_val(cp)>unity ) green_val(cp)=unity;
22776 if ( blue_val(cp)>unity ) blue_val(cp)=unity;
22779 @ @<Transfer a cmykcolor from the current expression to object~|cp|@>=
22780 { q=value(mp->cur_exp);
22781 cyan_val(cp)=value(cyan_part_loc(q));
22782 magenta_val(cp)=value(magenta_part_loc(q));
22783 yellow_val(cp)=value(yellow_part_loc(q));
22784 black_val(cp)=value(black_part_loc(q));
22785 color_model(cp)=mp_cmyk_model;
22786 if ( cyan_val(cp)<0 ) cyan_val(cp)=0;
22787 if ( magenta_val(cp)<0 ) magenta_val(cp)=0;
22788 if ( yellow_val(cp)<0 ) yellow_val(cp)=0;
22789 if ( black_val(cp)<0 ) black_val(cp)=0;
22790 if ( cyan_val(cp)>unity ) cyan_val(cp)=unity;
22791 if ( magenta_val(cp)>unity ) magenta_val(cp)=unity;
22792 if ( yellow_val(cp)>unity ) yellow_val(cp)=unity;
22793 if ( black_val(cp)>unity ) black_val(cp)=unity;
22796 @ @<Transfer a greyscale from the current expression to object~|cp|@>=
22803 color_model(cp)=mp_grey_model;
22804 if ( grey_val(cp)<0 ) grey_val(cp)=0;
22805 if ( grey_val(cp)>unity ) grey_val(cp)=unity;
22808 @ @<Transfer a noncolor from the current expression to object~|cp|@>=
22815 color_model(cp)=mp_no_model;
22818 @ @<Make |cp| a colored object in object list~|p|@>=
22820 while ( cp!=null ){
22821 if ( has_color(cp) ) break;
22826 @ @<Make |pp| an object in list~|p| that needs a pen@>=
22828 while ( pp!=null ) {
22829 if ( has_pen(pp) ) break;
22834 @ @<Make |dp| a stroked node in list~|p|@>=
22836 while ( dp!=null ) {
22837 if ( type(dp)==mp_stroked_code ) break;
22842 @ @<Copy the information from objects |cp|, |pp|, and |dp| into...@>=
22843 @<Copy |cp|'s color into the colored objects linked to~|cp|@>;
22844 if ( pp>mp_void ) {
22845 @<Copy |pen_p(pp)| into stroked and filled nodes linked to |pp|@>;
22847 if ( dp>mp_void ) {
22848 @<Make stroked nodes linked to |dp| refer to |dash_p(dp)|@>;
22852 @ @<Copy |cp|'s color into the colored objects linked to~|cp|@>=
22854 while ( q!=null ) {
22855 if ( has_color(q) ) {
22856 red_val(q)=red_val(cp);
22857 green_val(q)=green_val(cp);
22858 blue_val(q)=blue_val(cp);
22859 black_val(q)=black_val(cp);
22860 color_model(q)=color_model(cp);
22866 @ @<Copy |pen_p(pp)| into stroked and filled nodes linked to |pp|@>=
22868 while ( q!=null ) {
22869 if ( has_pen(q) ) {
22870 if ( pen_p(q)!=null ) mp_toss_knot_list(mp, pen_p(q));
22871 pen_p(q)=copy_pen(pen_p(pp));
22877 @ @<Make stroked nodes linked to |dp| refer to |dash_p(dp)|@>=
22879 while ( q!=null ) {
22880 if ( type(q)==mp_stroked_code ) {
22881 if ( dash_p(q)!=null ) delete_edge_ref(dash_p(q));
22882 dash_p(q)=dash_p(dp);
22883 dash_scale(q)=unity;
22884 if ( dash_p(q)!=null ) add_edge_ref(dash_p(q));
22890 @ One of the things we need to do when we've parsed an \&{addto} or
22891 similar command is find the header of a supposed \&{picture} variable, given
22892 a token list for that variable. Since the edge structure is about to be
22893 updated, we use |private_edges| to make sure that this is possible.
22895 @<Declare action procedures for use by |do_statement|@>=
22896 pointer mp_find_edges_var (MP mp, pointer t) ;
22898 @ @c pointer mp_find_edges_var (MP mp, pointer t) {
22900 pointer cur_edges; /* the return value */
22901 p=mp_find_variable(mp, t); cur_edges=null;
22903 mp_obliterated(mp, t); mp_put_get_error(mp);
22904 } else if ( type(p)!=mp_picture_type ) {
22905 print_err("Variable "); mp_show_token_list(mp, t,null,1000,0);
22906 @.Variable x is the wrong type@>
22907 mp_print(mp, " is the wrong type (");
22908 mp_print_type(mp, type(p)); mp_print_char(mp, ')');
22909 help2("I was looking for a \"known\" picture variable.")
22910 ("So I'll not change anything just now.");
22911 mp_put_get_error(mp);
22913 value(p)=mp_private_edges(mp, value(p));
22914 cur_edges=value(p);
22916 mp_flush_node_list(mp, t);
22920 @ @<Cases of |do_statement|...@>=
22921 case add_to_command: mp_do_add_to(mp); break;
22922 case bounds_command:mp_do_bounds(mp); break;
22925 mp_primitive(mp, "clip",bounds_command,mp_start_clip_code);
22926 @:clip_}{\&{clip} primitive@>
22927 mp_primitive(mp, "setbounds",bounds_command,mp_start_bounds_code);
22928 @:set_bounds_}{\&{setbounds} primitive@>
22930 @ @<Cases of |print_cmd...@>=
22931 case bounds_command:
22932 if ( m==mp_start_clip_code ) mp_print(mp, "clip");
22933 else mp_print(mp, "setbounds");
22936 @ The following function parses the beginning of an \&{addto} or \&{clip}
22937 command: it expects a variable name followed by a token with |cur_cmd=sep|
22938 and then an expression. The function returns the token list for the variable
22939 and stores the command modifier for the separator token in the global variable
22940 |last_add_type|. We must be careful because this variable might get overwritten
22941 any time we call |get_x_next|.
22944 quarterword last_add_type;
22945 /* command modifier that identifies the last \&{addto} command */
22947 @ @<Declare action procedures for use by |do_statement|@>=
22948 pointer mp_start_draw_cmd (MP mp,quarterword sep) ;
22950 @ @c pointer mp_start_draw_cmd (MP mp,quarterword sep) {
22951 pointer lhv; /* variable to add to left */
22952 quarterword add_type=0; /* value to be returned in |last_add_type| */
22954 mp_get_x_next(mp); mp->var_flag=sep; mp_scan_primary(mp);
22955 if ( mp->cur_type!=mp_token_list ) {
22956 @<Abandon edges command because there's no variable@>;
22958 lhv=mp->cur_exp; add_type=mp->cur_mod;
22959 mp->cur_type=mp_vacuous; mp_get_x_next(mp); mp_scan_expression(mp);
22961 mp->last_add_type=add_type;
22965 @ @<Abandon edges command because there's no variable@>=
22966 { exp_err("Not a suitable variable");
22967 @.Not a suitable variable@>
22968 help4("At this point I needed to see the name of a picture variable.")
22969 ("(Or perhaps you have indeed presented me with one; I might")
22970 ("have missed it, if it wasn't followed by the proper token.)")
22971 ("So I'll not change anything just now.");
22972 mp_put_get_flush_error(mp, 0);
22975 @ Here is an example of how to use |start_draw_cmd|.
22977 @<Declare action procedures for use by |do_statement|@>=
22978 void mp_do_bounds (MP mp) ;
22980 @ @c void mp_do_bounds (MP mp) {
22981 pointer lhv,lhe; /* variable on left, the corresponding edge structure */
22982 pointer p; /* for list manipulation */
22983 integer m; /* initial value of |cur_mod| */
22985 lhv=mp_start_draw_cmd(mp, to_token);
22987 lhe=mp_find_edges_var(mp, lhv);
22989 mp_flush_cur_exp(mp, 0);
22990 } else if ( mp->cur_type!=mp_path_type ) {
22991 exp_err("Improper `clip'");
22992 @.Improper `addto'@>
22993 help2("This expression should have specified a known path.")
22994 ("So I'll not change anything just now.");
22995 mp_put_get_flush_error(mp, 0);
22996 } else if ( left_type(mp->cur_exp)==mp_endpoint ) {
22997 @<Complain about a non-cycle@>;
22999 @<Make |cur_exp| into a \&{setbounds} or clipping path and add it to |lhe|@>;
23004 @ @<Complain about a non-cycle@>=
23005 { print_err("Not a cycle");
23007 help2("That contour should have ended with `..cycle' or `&cycle'.")
23008 ("So I'll not change anything just now."); mp_put_get_error(mp);
23011 @ @<Make |cur_exp| into a \&{setbounds} or clipping path and add...@>=
23012 { p=mp_new_bounds_node(mp, mp->cur_exp,m);
23013 link(p)=link(dummy_loc(lhe));
23014 link(dummy_loc(lhe))=p;
23015 if ( obj_tail(lhe)==dummy_loc(lhe) ) obj_tail(lhe)=p;
23016 p=mp_get_node(mp, mp->gr_object_size[stop_type(m)]);
23017 type(p)=stop_type(m);
23018 link(obj_tail(lhe))=p;
23020 mp_init_bbox(mp, lhe);
23023 @ The |do_add_to| procedure is a little like |do_clip| but there are a lot more
23024 cases to deal with.
23026 @<Declare action procedures for use by |do_statement|@>=
23027 void mp_do_add_to (MP mp) ;
23029 @ @c void mp_do_add_to (MP mp) {
23030 pointer lhv,lhe; /* variable on left, the corresponding edge structure */
23031 pointer p; /* the graphical object or list for |scan_with_list| to update */
23032 pointer e; /* an edge structure to be merged */
23033 quarterword add_type; /* |also_code|, |contour_code|, or |double_path_code| */
23034 lhv=mp_start_draw_cmd(mp, thing_to_add); add_type=mp->last_add_type;
23036 if ( add_type==also_code ) {
23037 @<Make sure the current expression is a suitable picture and set |e| and |p|
23040 @<Create a graphical object |p| based on |add_type| and the current
23043 mp_scan_with_list(mp, p);
23044 @<Use |p|, |e|, and |add_type| to augment |lhv| as requested@>;
23048 @ Setting |p:=null| causes the $\langle$with list$\rangle$ to be ignored;
23049 setting |e:=null| prevents anything from being added to |lhe|.
23051 @ @<Make sure the current expression is a suitable picture and set |e|...@>=
23054 if ( mp->cur_type!=mp_picture_type ) {
23055 exp_err("Improper `addto'");
23056 @.Improper `addto'@>
23057 help2("This expression should have specified a known picture.")
23058 ("So I'll not change anything just now."); mp_put_get_flush_error(mp, 0);
23060 e=mp_private_edges(mp, mp->cur_exp); mp->cur_type=mp_vacuous;
23061 p=link(dummy_loc(e));
23065 @ In this case |add_type<>also_code| so setting |p:=null| suppresses future
23066 attempts to add to the edge structure.
23068 @<Create a graphical object |p| based on |add_type| and the current...@>=
23070 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
23071 if ( mp->cur_type!=mp_path_type ) {
23072 exp_err("Improper `addto'");
23073 @.Improper `addto'@>
23074 help2("This expression should have specified a known path.")
23075 ("So I'll not change anything just now.");
23076 mp_put_get_flush_error(mp, 0);
23077 } else if ( add_type==contour_code ) {
23078 if ( left_type(mp->cur_exp)==mp_endpoint ) {
23079 @<Complain about a non-cycle@>;
23081 p=mp_new_fill_node(mp, mp->cur_exp);
23082 mp->cur_type=mp_vacuous;
23085 p=mp_new_stroked_node(mp, mp->cur_exp);
23086 mp->cur_type=mp_vacuous;
23090 @ @<Use |p|, |e|, and |add_type| to augment |lhv| as requested@>=
23091 lhe=mp_find_edges_var(mp, lhv);
23093 if ( (e==null)&&(p!=null) ) e=mp_toss_gr_object(mp, p);
23094 if ( e!=null ) delete_edge_ref(e);
23095 } else if ( add_type==also_code ) {
23097 @<Merge |e| into |lhe| and delete |e|@>;
23101 } else if ( p!=null ) {
23102 link(obj_tail(lhe))=p;
23104 if ( add_type==double_path_code )
23105 if ( pen_p(p)==null )
23106 pen_p(p)=mp_get_pen_circle(mp, 0);
23109 @ @<Merge |e| into |lhe| and delete |e|@>=
23110 { if ( link(dummy_loc(e))!=null ) {
23111 link(obj_tail(lhe))=link(dummy_loc(e));
23112 obj_tail(lhe)=obj_tail(e);
23113 obj_tail(e)=dummy_loc(e);
23114 link(dummy_loc(e))=null;
23115 mp_flush_dash_list(mp, lhe);
23117 mp_toss_edges(mp, e);
23120 @ @<Cases of |do_statement|...@>=
23121 case ship_out_command: mp_do_ship_out(mp); break;
23123 @ @<Declare action procedures for use by |do_statement|@>=
23124 @<Declare the function called |tfm_check|@>
23125 @<Declare the \ps\ output procedures@>
23126 void mp_do_ship_out (MP mp) ;
23128 @ @c void mp_do_ship_out (MP mp) {
23129 integer c; /* the character code */
23130 mp_get_x_next(mp); mp_scan_expression(mp);
23131 if ( mp->cur_type!=mp_picture_type ) {
23132 @<Complain that it's not a known picture@>;
23134 c=mp_round_unscaled(mp, mp->internal[mp_char_code]) % 256;
23135 if ( c<0 ) c=c+256;
23136 @<Store the width information for character code~|c|@>;
23137 mp_ship_out(mp, mp->cur_exp);
23138 mp_flush_cur_exp(mp, 0);
23142 @ @<Complain that it's not a known picture@>=
23144 exp_err("Not a known picture");
23145 help1("I can only output known pictures.");
23146 mp_put_get_flush_error(mp, 0);
23149 @ The \&{everyjob} command simply assigns a nonzero value to the global variable
23152 @<Cases of |do_statement|...@>=
23153 case every_job_command:
23154 mp_get_symbol(mp); mp->start_sym=mp->cur_sym; mp_get_x_next(mp);
23158 halfword start_sym; /* a symbolic token to insert at beginning of job */
23163 @ Finally, we have only the ``message'' commands remaining.
23166 @d err_message_code 1
23168 @d filename_template_code 3
23169 @d print_with_leading_zeroes(A) g = mp->pool_ptr;
23170 mp_print_int(mp, (A)); g = mp->pool_ptr-g;
23172 mp->pool_ptr = mp->pool_ptr - g;
23174 mp_print_char(mp, '0');
23177 mp_print_int(mp, (A));
23182 mp_primitive(mp, "message",message_command,message_code);
23183 @:message_}{\&{message} primitive@>
23184 mp_primitive(mp, "errmessage",message_command,err_message_code);
23185 @:err_message_}{\&{errmessage} primitive@>
23186 mp_primitive(mp, "errhelp",message_command,err_help_code);
23187 @:err_help_}{\&{errhelp} primitive@>
23188 mp_primitive(mp, "filenametemplate",message_command,filename_template_code);
23189 @:filename_template_}{\&{filenametemplate} primitive@>
23191 @ @<Cases of |print_cmd...@>=
23192 case message_command:
23193 if ( m<err_message_code ) mp_print(mp, "message");
23194 else if ( m==err_message_code ) mp_print(mp, "errmessage");
23195 else if ( m==filename_template_code ) mp_print(mp, "filenametemplate");
23196 else mp_print(mp, "errhelp");
23199 @ @<Cases of |do_statement|...@>=
23200 case message_command: mp_do_message(mp); break;
23202 @ @<Declare action procedures for use by |do_statement|@>=
23203 @<Declare a procedure called |no_string_err|@>
23204 void mp_do_message (MP mp) ;
23207 @c void mp_do_message (MP mp) {
23208 int m; /* the type of message */
23209 m=mp->cur_mod; mp_get_x_next(mp); mp_scan_expression(mp);
23210 if ( mp->cur_type!=mp_string_type )
23211 mp_no_string_err(mp, "A message should be a known string expression.");
23215 mp_print_nl(mp, ""); mp_print_str(mp, mp->cur_exp);
23217 case err_message_code:
23218 @<Print string |cur_exp| as an error message@>;
23220 case err_help_code:
23221 @<Save string |cur_exp| as the |err_help|@>;
23223 case filename_template_code:
23224 @<Save the filename template@>;
23226 } /* there are no other cases */
23228 mp_flush_cur_exp(mp, 0);
23231 @ @<Declare a procedure called |no_string_err|@>=
23232 void mp_no_string_err (MP mp, const char *s) {
23233 exp_err("Not a string");
23236 mp_put_get_error(mp);
23239 @ The global variable |err_help| is zero when the user has most recently
23240 given an empty help string, or if none has ever been given.
23242 @<Save string |cur_exp| as the |err_help|@>=
23244 if ( mp->err_help!=0 ) delete_str_ref(mp->err_help);
23245 if ( length(mp->cur_exp)==0 ) mp->err_help=0;
23246 else { mp->err_help=mp->cur_exp; add_str_ref(mp->err_help); }
23249 @ If \&{errmessage} occurs often in |mp_scroll_mode|, without user-defined
23250 \&{errhelp}, we don't want to give a long help message each time. So we
23251 give a verbose explanation only once.
23254 boolean long_help_seen; /* has the long \.{\\errmessage} help been used? */
23256 @ @<Set init...@>=mp->long_help_seen=false;
23258 @ @<Print string |cur_exp| as an error message@>=
23260 print_err(""); mp_print_str(mp, mp->cur_exp);
23261 if ( mp->err_help!=0 ) {
23262 mp->use_err_help=true;
23263 } else if ( mp->long_help_seen ) {
23264 help1("(That was another `errmessage'.)") ;
23266 if ( mp->interaction<mp_error_stop_mode ) mp->long_help_seen=true;
23267 help4("This error message was generated by an `errmessage'")
23268 ("command, so I can\'t give any explicit help.")
23269 ("Pretend that you're Miss Marple: Examine all clues,")
23271 ("and deduce the truth by inspired guesses.");
23273 mp_put_get_error(mp); mp->use_err_help=false;
23276 @ @<Cases of |do_statement|...@>=
23277 case write_command: mp_do_write(mp); break;
23279 @ @<Declare action procedures for use by |do_statement|@>=
23280 void mp_do_write (MP mp) ;
23282 @ @c void mp_do_write (MP mp) {
23283 str_number t; /* the line of text to be written */
23284 write_index n,n0; /* for searching |wr_fname| and |wr_file| arrays */
23285 int old_setting; /* for saving |selector| during output */
23287 mp_scan_expression(mp);
23288 if ( mp->cur_type!=mp_string_type ) {
23289 mp_no_string_err(mp, "The text to be written should be a known string expression");
23290 } else if ( mp->cur_cmd!=to_token ) {
23291 print_err("Missing `to' clause");
23292 help1("A write command should end with `to <filename>'");
23293 mp_put_get_error(mp);
23295 t=mp->cur_exp; mp->cur_type=mp_vacuous;
23297 mp_scan_expression(mp);
23298 if ( mp->cur_type!=mp_string_type )
23299 mp_no_string_err(mp, "I can\'t write to that file name. It isn't a known string");
23301 @<Write |t| to the file named by |cur_exp|@>;
23305 mp_flush_cur_exp(mp, 0);
23308 @ @<Write |t| to the file named by |cur_exp|@>=
23310 @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if
23311 |cur_exp| must be inserted@>;
23312 if ( mp_str_vs_str(mp, t,mp->eof_line)==0 ) {
23313 @<Record the end of file on |wr_file[n]|@>;
23315 old_setting=mp->selector;
23316 mp->selector=n+write_file;
23317 mp_print_str(mp, t); mp_print_ln(mp);
23318 mp->selector = old_setting;
23322 @ @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if...@>=
23324 char *fn = str(mp->cur_exp);
23326 n0=mp->write_files;
23327 while (mp_xstrcmp(fn,mp->wr_fname[n])!=0) {
23328 if ( n==0 ) { /* bottom reached */
23329 if ( n0==mp->write_files ) {
23330 if ( mp->write_files<mp->max_write_files ) {
23331 incr(mp->write_files);
23336 l = mp->max_write_files + (mp->max_write_files>>2);
23337 wr_file = xmalloc((l+1),sizeof(void *));
23338 wr_fname = xmalloc((l+1),sizeof(char *));
23339 for (k=0;k<=l;k++) {
23340 if (k<=mp->max_write_files) {
23341 wr_file[k]=mp->wr_file[k];
23342 wr_fname[k]=mp->wr_fname[k];
23348 xfree(mp->wr_file); xfree(mp->wr_fname);
23349 mp->max_write_files = l;
23350 mp->wr_file = wr_file;
23351 mp->wr_fname = wr_fname;
23355 mp_open_write_file(mp, fn ,n);
23358 if ( mp->wr_fname[n]==NULL ) n0=n;
23363 @ @<Record the end of file on |wr_file[n]|@>=
23364 { (mp->close_file)(mp,mp->wr_file[n]);
23365 xfree(mp->wr_fname[n]);
23366 if ( n==mp->write_files-1 ) mp->write_files=n;
23370 @* \[42] Writing font metric data.
23371 \TeX\ gets its knowledge about fonts from font metric files, also called
23372 \.{TFM} files; the `\.T' in `\.{TFM}' stands for \TeX,
23373 but other programs know about them too. One of \MP's duties is to
23374 write \.{TFM} files so that the user's fonts can readily be
23375 applied to typesetting.
23376 @:TFM files}{\.{TFM} files@>
23377 @^font metric files@>
23379 The information in a \.{TFM} file appears in a sequence of 8-bit bytes.
23380 Since the number of bytes is always a multiple of~4, we could
23381 also regard the file as a sequence of 32-bit words, but \MP\ uses the
23382 byte interpretation. The format of \.{TFM} files was designed by
23383 Lyle Ramshaw in 1980. The intent is to convey a lot of different kinds
23384 @^Ramshaw, Lyle Harold@>
23385 of information in a compact but useful form.
23388 void * tfm_file; /* the font metric output goes here */
23389 char * metric_file_name; /* full name of the font metric file */
23391 @ The first 24 bytes (6 words) of a \.{TFM} file contain twelve 16-bit
23392 integers that give the lengths of the various subsequent portions
23393 of the file. These twelve integers are, in order:
23394 $$\vbox{\halign{\hfil#&$\null=\null$#\hfil\cr
23395 |lf|&length of the entire file, in words;\cr
23396 |lh|&length of the header data, in words;\cr
23397 |bc|&smallest character code in the font;\cr
23398 |ec|&largest character code in the font;\cr
23399 |nw|&number of words in the width table;\cr
23400 |nh|&number of words in the height table;\cr
23401 |nd|&number of words in the depth table;\cr
23402 |ni|&number of words in the italic correction table;\cr
23403 |nl|&number of words in the lig/kern table;\cr
23404 |nk|&number of words in the kern table;\cr
23405 |ne|&number of words in the extensible character table;\cr
23406 |np|&number of font parameter words.\cr}}$$
23407 They are all nonnegative and less than $2^{15}$. We must have |bc-1<=ec<=255|,
23409 $$\hbox{|lf=6+lh+(ec-bc+1)+nw+nh+nd+ni+nl+nk+ne+np|.}$$
23410 Note that a font may contain as many as 256 characters (if |bc=0| and |ec=255|),
23411 and as few as 0 characters (if |bc=ec+1|).
23413 Incidentally, when two or more 8-bit bytes are combined to form an integer of
23414 16 or more bits, the most significant bytes appear first in the file.
23415 This is called BigEndian order.
23416 @^BigEndian order@>
23418 @ The rest of the \.{TFM} file may be regarded as a sequence of ten data
23421 The most important data type used here is a |fix_word|, which is
23422 a 32-bit representation of a binary fraction. A |fix_word| is a signed
23423 quantity, with the two's complement of the entire word used to represent
23424 negation. Of the 32 bits in a |fix_word|, exactly 12 are to the left of the
23425 binary point; thus, the largest |fix_word| value is $2048-2^{-20}$, and
23426 the smallest is $-2048$. We will see below, however, that all but two of
23427 the |fix_word| values must lie between $-16$ and $+16$.
23429 @ The first data array is a block of header information, which contains
23430 general facts about the font. The header must contain at least two words,
23431 |header[0]| and |header[1]|, whose meaning is explained below. Additional
23432 header information of use to other software routines might also be
23433 included, and \MP\ will generate it if the \.{headerbyte} command occurs.
23434 For example, 16 more words of header information are in use at the Xerox
23435 Palo Alto Research Center; the first ten specify the character coding
23436 scheme used (e.g., `\.{XEROX TEXT}' or `\.{TEX MATHSY}'), the next five
23437 give the font family name (e.g., `\.{HELVETICA}' or `\.{CMSY}'), and the
23438 last gives the ``face byte.''
23440 \yskip\hang|header[0]| is a 32-bit check sum that \MP\ will copy into
23441 the \.{GF} output file. This helps ensure consistency between files,
23442 since \TeX\ records the check sums from the \.{TFM}'s it reads, and these
23443 should match the check sums on actual fonts that are used. The actual
23444 relation between this check sum and the rest of the \.{TFM} file is not
23445 important; the check sum is simply an identification number with the
23446 property that incompatible fonts almost always have distinct check sums.
23449 \yskip\hang|header[1]| is a |fix_word| containing the design size of the
23450 font, in units of \TeX\ points. This number must be at least 1.0; it is
23451 fairly arbitrary, but usually the design size is 10.0 for a ``10 point''
23452 font, i.e., a font that was designed to look best at a 10-point size,
23453 whatever that really means. When a \TeX\ user asks for a font `\.{at}
23454 $\delta$ \.{pt}', the effect is to override the design size and replace it
23455 by $\delta$, and to multiply the $x$ and~$y$ coordinates of the points in
23456 the font image by a factor of $\delta$ divided by the design size. {\sl
23457 All other dimensions in the\/ \.{TFM} file are |fix_word|\kern-1pt\
23458 numbers in design-size units.} Thus, for example, the value of |param[6]|,
23459 which defines the \.{em} unit, is often the |fix_word| value $2^{20}=1.0$,
23460 since many fonts have a design size equal to one em. The other dimensions
23461 must be less than 16 design-size units in absolute value; thus,
23462 |header[1]| and |param[1]| are the only |fix_word| entries in the whole
23463 \.{TFM} file whose first byte might be something besides 0 or 255.
23466 @ Next comes the |char_info| array, which contains one |char_info_word|
23467 per character. Each word in this part of the file contains six fields
23468 packed into four bytes as follows.
23470 \yskip\hang first byte: |width_index| (8 bits)\par
23471 \hang second byte: |height_index| (4 bits) times 16, plus |depth_index|
23473 \hang third byte: |italic_index| (6 bits) times 4, plus |tag|
23475 \hang fourth byte: |remainder| (8 bits)\par
23477 The actual width of a character is \\{width}|[width_index]|, in design-size
23478 units; this is a device for compressing information, since many characters
23479 have the same width. Since it is quite common for many characters
23480 to have the same height, depth, or italic correction, the \.{TFM} format
23481 imposes a limit of 16 different heights, 16 different depths, and
23482 64 different italic corrections.
23484 Incidentally, the relation $\\{width}[0]=\\{height}[0]=\\{depth}[0]=
23485 \\{italic}[0]=0$ should always hold, so that an index of zero implies a
23486 value of zero. The |width_index| should never be zero unless the
23487 character does not exist in the font, since a character is valid if and
23488 only if it lies between |bc| and |ec| and has a nonzero |width_index|.
23490 @ The |tag| field in a |char_info_word| has four values that explain how to
23491 interpret the |remainder| field.
23493 \yskip\hang|tag=0| (|no_tag|) means that |remainder| is unused.\par
23494 \hang|tag=1| (|lig_tag|) means that this character has a ligature/kerning
23495 program starting at location |remainder| in the |lig_kern| array.\par
23496 \hang|tag=2| (|list_tag|) means that this character is part of a chain of
23497 characters of ascending sizes, and not the largest in the chain. The
23498 |remainder| field gives the character code of the next larger character.\par
23499 \hang|tag=3| (|ext_tag|) means that this character code represents an
23500 extensible character, i.e., a character that is built up of smaller pieces
23501 so that it can be made arbitrarily large. The pieces are specified in
23502 |exten[remainder]|.\par
23504 Characters with |tag=2| and |tag=3| are treated as characters with |tag=0|
23505 unless they are used in special circumstances in math formulas. For example,
23506 \TeX's \.{\\sum} operation looks for a |list_tag|, and the \.{\\left}
23507 operation looks for both |list_tag| and |ext_tag|.
23509 @d no_tag 0 /* vanilla character */
23510 @d lig_tag 1 /* character has a ligature/kerning program */
23511 @d list_tag 2 /* character has a successor in a charlist */
23512 @d ext_tag 3 /* character is extensible */
23514 @ The |lig_kern| array contains instructions in a simple programming language
23515 that explains what to do for special letter pairs. Each word in this array is a
23516 |lig_kern_command| of four bytes.
23518 \yskip\hang first byte: |skip_byte|, indicates that this is the final program
23519 step if the byte is 128 or more, otherwise the next step is obtained by
23520 skipping this number of intervening steps.\par
23521 \hang second byte: |next_char|, ``if |next_char| follows the current character,
23522 then perform the operation and stop, otherwise continue.''\par
23523 \hang third byte: |op_byte|, indicates a ligature step if less than~128,
23524 a kern step otherwise.\par
23525 \hang fourth byte: |remainder|.\par
23528 additional space equal to |kern[256*(op_byte-128)+remainder]| is inserted
23529 between the current character and |next_char|. This amount is
23530 often negative, so that the characters are brought closer together
23531 by kerning; but it might be positive.
23533 There are eight kinds of ligature steps, having |op_byte| codes $4a+2b+c$ where
23534 $0\le a\le b+c$ and $0\le b,c\le1$. The character whose code is
23535 |remainder| is inserted between the current character and |next_char|;
23536 then the current character is deleted if $b=0$, and |next_char| is
23537 deleted if $c=0$; then we pass over $a$~characters to reach the next
23538 current character (which may have a ligature/kerning program of its own).
23540 If the very first instruction of the |lig_kern| array has |skip_byte=255|,
23541 the |next_char| byte is the so-called right boundary character of this font;
23542 the value of |next_char| need not lie between |bc| and~|ec|.
23543 If the very last instruction of the |lig_kern| array has |skip_byte=255|,
23544 there is a special ligature/kerning program for a left boundary character,
23545 beginning at location |256*op_byte+remainder|.
23546 The interpretation is that \TeX\ puts implicit boundary characters
23547 before and after each consecutive string of characters from the same font.
23548 These implicit characters do not appear in the output, but they can affect
23549 ligatures and kerning.
23551 If the very first instruction of a character's |lig_kern| program has
23552 |skip_byte>128|, the program actually begins in location
23553 |256*op_byte+remainder|. This feature allows access to large |lig_kern|
23554 arrays, because the first instruction must otherwise
23555 appear in a location |<=255|.
23557 Any instruction with |skip_byte>128| in the |lig_kern| array must satisfy
23559 $$\hbox{|256*op_byte+remainder<nl|.}$$
23560 If such an instruction is encountered during
23561 normal program execution, it denotes an unconditional halt; no ligature
23562 command is performed.
23565 /* value indicating `\.{STOP}' in a lig/kern program */
23566 @d kern_flag (128) /* op code for a kern step */
23567 @d skip_byte(A) mp->lig_kern[(A)].b0
23568 @d next_char(A) mp->lig_kern[(A)].b1
23569 @d op_byte(A) mp->lig_kern[(A)].b2
23570 @d rem_byte(A) mp->lig_kern[(A)].b3
23572 @ Extensible characters are specified by an |extensible_recipe|, which
23573 consists of four bytes called |top|, |mid|, |bot|, and |rep| (in this
23574 order). These bytes are the character codes of individual pieces used to
23575 build up a large symbol. If |top|, |mid|, or |bot| are zero, they are not
23576 present in the built-up result. For example, an extensible vertical line is
23577 like an extensible bracket, except that the top and bottom pieces are missing.
23579 Let $T$, $M$, $B$, and $R$ denote the respective pieces, or an empty box
23580 if the piece isn't present. Then the extensible characters have the form
23581 $TR^kMR^kB$ from top to bottom, for some |k>=0|, unless $M$ is absent;
23582 in the latter case we can have $TR^kB$ for both even and odd values of~|k|.
23583 The width of the extensible character is the width of $R$; and the
23584 height-plus-depth is the sum of the individual height-plus-depths of the
23585 components used, since the pieces are butted together in a vertical list.
23587 @d ext_top(A) mp->exten[(A)].b0 /* |top| piece in a recipe */
23588 @d ext_mid(A) mp->exten[(A)].b1 /* |mid| piece in a recipe */
23589 @d ext_bot(A) mp->exten[(A)].b2 /* |bot| piece in a recipe */
23590 @d ext_rep(A) mp->exten[(A)].b3 /* |rep| piece in a recipe */
23592 @ The final portion of a \.{TFM} file is the |param| array, which is another
23593 sequence of |fix_word| values.
23595 \yskip\hang|param[1]=slant| is the amount of italic slant, which is used
23596 to help position accents. For example, |slant=.25| means that when you go
23597 up one unit, you also go .25 units to the right. The |slant| is a pure
23598 number; it is the only |fix_word| other than the design size itself that is
23599 not scaled by the design size.
23602 \hang|param[2]=space| is the normal spacing between words in text.
23603 Note that character 040 in the font need not have anything to do with
23606 \hang|param[3]=space_stretch| is the amount of glue stretching between words.
23608 \hang|param[4]=space_shrink| is the amount of glue shrinking between words.
23610 \hang|param[5]=x_height| is the size of one ex in the font; it is also
23611 the height of letters for which accents don't have to be raised or lowered.
23613 \hang|param[6]=quad| is the size of one em in the font.
23615 \hang|param[7]=extra_space| is the amount added to |param[2]| at the
23619 If fewer than seven parameters are present, \TeX\ sets the missing parameters
23624 @d space_stretch_code 3
23625 @d space_shrink_code 4
23628 @d extra_space_code 7
23630 @ So that is what \.{TFM} files hold. One of \MP's duties is to output such
23631 information, and it does this all at once at the end of a job.
23632 In order to prepare for such frenetic activity, it squirrels away the
23633 necessary facts in various arrays as information becomes available.
23635 Character dimensions (\&{charwd}, \&{charht}, \&{chardp}, and \&{charic})
23636 are stored respectively in |tfm_width|, |tfm_height|, |tfm_depth|, and
23637 |tfm_ital_corr|. Other information about a character (e.g., about
23638 its ligatures or successors) is accessible via the |char_tag| and
23639 |char_remainder| arrays. Other information about the font as a whole
23640 is kept in additional arrays called |header_byte|, |lig_kern|,
23641 |kern|, |exten|, and |param|.
23643 @d max_tfm_int 32510
23644 @d undefined_label max_tfm_int /* an undefined local label */
23647 #define TFM_ITEMS 257
23649 eight_bits ec; /* smallest and largest character codes shipped out */
23650 scaled tfm_width[TFM_ITEMS]; /* \&{charwd} values */
23651 scaled tfm_height[TFM_ITEMS]; /* \&{charht} values */
23652 scaled tfm_depth[TFM_ITEMS]; /* \&{chardp} values */
23653 scaled tfm_ital_corr[TFM_ITEMS]; /* \&{charic} values */
23654 boolean char_exists[TFM_ITEMS]; /* has this code been shipped out? */
23655 int char_tag[TFM_ITEMS]; /* |remainder| category */
23656 int char_remainder[TFM_ITEMS]; /* the |remainder| byte */
23657 char *header_byte; /* bytes of the \.{TFM} header */
23658 int header_last; /* last initialized \.{TFM} header byte */
23659 int header_size; /* size of the \.{TFM} header */
23660 four_quarters *lig_kern; /* the ligature/kern table */
23661 short nl; /* the number of ligature/kern steps so far */
23662 scaled *kern; /* distinct kerning amounts */
23663 short nk; /* the number of distinct kerns so far */
23664 four_quarters exten[TFM_ITEMS]; /* extensible character recipes */
23665 short ne; /* the number of extensible characters so far */
23666 scaled *param; /* \&{fontinfo} parameters */
23667 short np; /* the largest \&{fontinfo} parameter specified so far */
23668 short nw;short nh;short nd;short ni; /* sizes of \.{TFM} subtables */
23669 short skip_table[TFM_ITEMS]; /* local label status */
23670 boolean lk_started; /* has there been a lig/kern step in this command yet? */
23671 integer bchar; /* right boundary character */
23672 short bch_label; /* left boundary starting location */
23673 short ll;short lll; /* registers used for lig/kern processing */
23674 short label_loc[257]; /* lig/kern starting addresses */
23675 eight_bits label_char[257]; /* characters for |label_loc| */
23676 short label_ptr; /* highest position occupied in |label_loc| */
23678 @ @<Allocate or initialize ...@>=
23679 mp->header_last = 0; mp->header_size = 128; /* just for init */
23680 mp->header_byte = xmalloc(mp->header_size, sizeof(char));
23681 mp->lig_kern = NULL; /* allocated when needed */
23682 mp->kern = NULL; /* allocated when needed */
23683 mp->param = NULL; /* allocated when needed */
23685 @ @<Dealloc variables@>=
23686 xfree(mp->header_byte);
23687 xfree(mp->lig_kern);
23692 for (k=0;k<= 255;k++ ) {
23693 mp->tfm_width[k]=0; mp->tfm_height[k]=0; mp->tfm_depth[k]=0; mp->tfm_ital_corr[k]=0;
23694 mp->char_exists[k]=false; mp->char_tag[k]=no_tag; mp->char_remainder[k]=0;
23695 mp->skip_table[k]=undefined_label;
23697 memset(mp->header_byte,0,mp->header_size);
23698 mp->bc=255; mp->ec=0; mp->nl=0; mp->nk=0; mp->ne=0; mp->np=0;
23699 mp->internal[mp_boundary_char]=-unity;
23700 mp->bch_label=undefined_label;
23701 mp->label_loc[0]=-1; mp->label_ptr=0;
23703 @ @<Declarations@>=
23704 scaled mp_tfm_check (MP mp,small_number m) ;
23706 @ @<Declare the function called |tfm_check|@>=
23707 scaled mp_tfm_check (MP mp,small_number m) {
23708 if ( abs(mp->internal[m])>=fraction_half ) {
23709 print_err("Enormous "); mp_print(mp, mp->int_name[m]);
23710 @.Enormous charwd...@>
23711 @.Enormous chardp...@>
23712 @.Enormous charht...@>
23713 @.Enormous charic...@>
23714 @.Enormous designsize...@>
23715 mp_print(mp, " has been reduced");
23716 help1("Font metric dimensions must be less than 2048pt.");
23717 mp_put_get_error(mp);
23718 if ( mp->internal[m]>0 ) return (fraction_half-1);
23719 else return (1-fraction_half);
23721 return mp->internal[m];
23725 @ @<Store the width information for character code~|c|@>=
23726 if ( c<mp->bc ) mp->bc=c;
23727 if ( c>mp->ec ) mp->ec=c;
23728 mp->char_exists[c]=true;
23729 mp->tfm_width[c]=mp_tfm_check(mp, mp_char_wd);
23730 mp->tfm_height[c]=mp_tfm_check(mp, mp_char_ht);
23731 mp->tfm_depth[c]=mp_tfm_check(mp, mp_char_dp);
23732 mp->tfm_ital_corr[c]=mp_tfm_check(mp, mp_char_ic)
23734 @ Now let's consider \MP's special \.{TFM}-oriented commands.
23736 @<Cases of |do_statement|...@>=
23737 case tfm_command: mp_do_tfm_command(mp); break;
23739 @ @d char_list_code 0
23740 @d lig_table_code 1
23741 @d extensible_code 2
23742 @d header_byte_code 3
23743 @d font_dimen_code 4
23746 mp_primitive(mp, "charlist",tfm_command,char_list_code);
23747 @:char_list_}{\&{charlist} primitive@>
23748 mp_primitive(mp, "ligtable",tfm_command,lig_table_code);
23749 @:lig_table_}{\&{ligtable} primitive@>
23750 mp_primitive(mp, "extensible",tfm_command,extensible_code);
23751 @:extensible_}{\&{extensible} primitive@>
23752 mp_primitive(mp, "headerbyte",tfm_command,header_byte_code);
23753 @:header_byte_}{\&{headerbyte} primitive@>
23754 mp_primitive(mp, "fontdimen",tfm_command,font_dimen_code);
23755 @:font_dimen_}{\&{fontdimen} primitive@>
23757 @ @<Cases of |print_cmd...@>=
23760 case char_list_code:mp_print(mp, "charlist"); break;
23761 case lig_table_code:mp_print(mp, "ligtable"); break;
23762 case extensible_code:mp_print(mp, "extensible"); break;
23763 case header_byte_code:mp_print(mp, "headerbyte"); break;
23764 default: mp_print(mp, "fontdimen"); break;
23768 @ @<Declare action procedures for use by |do_statement|@>=
23769 eight_bits mp_get_code (MP mp) ;
23771 @ @c eight_bits mp_get_code (MP mp) { /* scans a character code value */
23772 integer c; /* the code value found */
23773 mp_get_x_next(mp); mp_scan_expression(mp);
23774 if ( mp->cur_type==mp_known ) {
23775 c=mp_round_unscaled(mp, mp->cur_exp);
23776 if ( c>=0 ) if ( c<256 ) return c;
23777 } else if ( mp->cur_type==mp_string_type ) {
23778 if ( length(mp->cur_exp)==1 ) {
23779 c=mp->str_pool[mp->str_start[mp->cur_exp]];
23783 exp_err("Invalid code has been replaced by 0");
23784 @.Invalid code...@>
23785 help2("I was looking for a number between 0 and 255, or for a")
23786 ("string of length 1. Didn't find it; will use 0 instead.");
23787 mp_put_get_flush_error(mp, 0); c=0;
23791 @ @<Declare action procedures for use by |do_statement|@>=
23792 void mp_set_tag (MP mp,halfword c, small_number t, halfword r) ;
23794 @ @c void mp_set_tag (MP mp,halfword c, small_number t, halfword r) {
23795 if ( mp->char_tag[c]==no_tag ) {
23796 mp->char_tag[c]=t; mp->char_remainder[c]=r;
23798 incr(mp->label_ptr); mp->label_loc[mp->label_ptr]=r;
23799 mp->label_char[mp->label_ptr]=c;
23802 @<Complain about a character tag conflict@>;
23806 @ @<Complain about a character tag conflict@>=
23808 print_err("Character ");
23809 if ( (c>' ')&&(c<127) ) mp_print_char(mp,c);
23810 else if ( c==256 ) mp_print(mp, "||");
23811 else { mp_print(mp, "code "); mp_print_int(mp, c); };
23812 mp_print(mp, " is already ");
23813 @.Character c is already...@>
23814 switch (mp->char_tag[c]) {
23815 case lig_tag: mp_print(mp, "in a ligtable"); break;
23816 case list_tag: mp_print(mp, "in a charlist"); break;
23817 case ext_tag: mp_print(mp, "extensible"); break;
23818 } /* there are no other cases */
23819 help2("It's not legal to label a character more than once.")
23820 ("So I'll not change anything just now.");
23821 mp_put_get_error(mp);
23824 @ @<Declare action procedures for use by |do_statement|@>=
23825 void mp_do_tfm_command (MP mp) ;
23827 @ @c void mp_do_tfm_command (MP mp) {
23828 int c,cc; /* character codes */
23829 int k; /* index into the |kern| array */
23830 int j; /* index into |header_byte| or |param| */
23831 switch (mp->cur_mod) {
23832 case char_list_code:
23834 /* we will store a list of character successors */
23835 while ( mp->cur_cmd==colon ) {
23836 cc=mp_get_code(mp); mp_set_tag(mp, c,list_tag,cc); c=cc;
23839 case lig_table_code:
23840 if (mp->lig_kern==NULL)
23841 mp->lig_kern = xmalloc((max_tfm_int+1),sizeof(four_quarters));
23842 if (mp->kern==NULL)
23843 mp->kern = xmalloc((max_tfm_int+1),sizeof(scaled));
23844 @<Store a list of ligature/kern steps@>;
23846 case extensible_code:
23847 @<Define an extensible recipe@>;
23849 case header_byte_code:
23850 case font_dimen_code:
23851 c=mp->cur_mod; mp_get_x_next(mp);
23852 mp_scan_expression(mp);
23853 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<half_unit) ) {
23854 exp_err("Improper location");
23855 @.Improper location@>
23856 help2("I was looking for a known, positive number.")
23857 ("For safety's sake I'll ignore the present command.");
23858 mp_put_get_error(mp);
23860 j=mp_round_unscaled(mp, mp->cur_exp);
23861 if ( mp->cur_cmd!=colon ) {
23862 mp_missing_err(mp, ":");
23864 help1("A colon should follow a headerbyte or fontinfo location.");
23867 if ( c==header_byte_code ) {
23868 @<Store a list of header bytes@>;
23870 if (mp->param==NULL)
23871 mp->param = xmalloc((max_tfm_int+1),sizeof(scaled));
23872 @<Store a list of font dimensions@>;
23876 } /* there are no other cases */
23879 @ @<Store a list of ligature/kern steps@>=
23881 mp->lk_started=false;
23884 if ((mp->cur_cmd==skip_to)&& mp->lk_started )
23885 @<Process a |skip_to| command and |goto done|@>;
23886 if ( mp->cur_cmd==bchar_label ) { c=256; mp->cur_cmd=colon; }
23887 else { mp_back_input(mp); c=mp_get_code(mp); };
23888 if ((mp->cur_cmd==colon)||(mp->cur_cmd==double_colon)) {
23889 @<Record a label in a lig/kern subprogram and |goto continue|@>;
23891 if ( mp->cur_cmd==lig_kern_token ) {
23892 @<Compile a ligature/kern command@>;
23894 print_err("Illegal ligtable step");
23895 @.Illegal ligtable step@>
23896 help1("I was looking for `=:' or `kern' here.");
23897 mp_back_error(mp); next_char(mp->nl)=qi(0);
23898 op_byte(mp->nl)=qi(0); rem_byte(mp->nl)=qi(0);
23899 skip_byte(mp->nl)=stop_flag+1; /* this specifies an unconditional stop */
23901 if ( mp->nl==max_tfm_int) mp_fatal_error(mp, "ligtable too large");
23903 if ( mp->cur_cmd==comma ) goto CONTINUE;
23904 if ( skip_byte(mp->nl-1)<stop_flag ) skip_byte(mp->nl-1)=stop_flag;
23909 mp_primitive(mp, "=:",lig_kern_token,0);
23910 @:=:_}{\.{=:} primitive@>
23911 mp_primitive(mp, "=:|",lig_kern_token,1);
23912 @:=:/_}{\.{=:\char'174} primitive@>
23913 mp_primitive(mp, "=:|>",lig_kern_token,5);
23914 @:=:/>_}{\.{=:\char'174>} primitive@>
23915 mp_primitive(mp, "|=:",lig_kern_token,2);
23916 @:=:/_}{\.{\char'174=:} primitive@>
23917 mp_primitive(mp, "|=:>",lig_kern_token,6);
23918 @:=:/>_}{\.{\char'174=:>} primitive@>
23919 mp_primitive(mp, "|=:|",lig_kern_token,3);
23920 @:=:/_}{\.{\char'174=:\char'174} primitive@>
23921 mp_primitive(mp, "|=:|>",lig_kern_token,7);
23922 @:=:/>_}{\.{\char'174=:\char'174>} primitive@>
23923 mp_primitive(mp, "|=:|>>",lig_kern_token,11);
23924 @:=:/>_}{\.{\char'174=:\char'174>>} primitive@>
23925 mp_primitive(mp, "kern",lig_kern_token,128);
23926 @:kern_}{\&{kern} primitive@>
23928 @ @<Cases of |print_cmd...@>=
23929 case lig_kern_token:
23931 case 0:mp_print(mp, "=:"); break;
23932 case 1:mp_print(mp, "=:|"); break;
23933 case 2:mp_print(mp, "|=:"); break;
23934 case 3:mp_print(mp, "|=:|"); break;
23935 case 5:mp_print(mp, "=:|>"); break;
23936 case 6:mp_print(mp, "|=:>"); break;
23937 case 7:mp_print(mp, "|=:|>"); break;
23938 case 11:mp_print(mp, "|=:|>>"); break;
23939 default: mp_print(mp, "kern"); break;
23943 @ Local labels are implemented by maintaining the |skip_table| array,
23944 where |skip_table[c]| is either |undefined_label| or the address of the
23945 most recent lig/kern instruction that skips to local label~|c|. In the
23946 latter case, the |skip_byte| in that instruction will (temporarily)
23947 be zero if there were no prior skips to this label, or it will be the
23948 distance to the prior skip.
23950 We may need to cancel skips that span more than 127 lig/kern steps.
23952 @d cancel_skips(A) mp->ll=(A);
23954 mp->lll=qo(skip_byte(mp->ll));
23955 skip_byte(mp->ll)=stop_flag; mp->ll=mp->ll-mp->lll;
23956 } while (mp->lll!=0)
23957 @d skip_error(A) { print_err("Too far to skip");
23958 @.Too far to skip@>
23959 help1("At most 127 lig/kern steps can separate skipto1 from 1::.");
23960 mp_error(mp); cancel_skips((A));
23963 @<Process a |skip_to| command and |goto done|@>=
23966 if ( mp->nl-mp->skip_table[c]>128 ) {
23967 skip_error(mp->skip_table[c]); mp->skip_table[c]=undefined_label;
23969 if ( mp->skip_table[c]==undefined_label ) skip_byte(mp->nl-1)=qi(0);
23970 else skip_byte(mp->nl-1)=qi(mp->nl-mp->skip_table[c]-1);
23971 mp->skip_table[c]=mp->nl-1; goto DONE;
23974 @ @<Record a label in a lig/kern subprogram and |goto continue|@>=
23976 if ( mp->cur_cmd==colon ) {
23977 if ( c==256 ) mp->bch_label=mp->nl;
23978 else mp_set_tag(mp, c,lig_tag,mp->nl);
23979 } else if ( mp->skip_table[c]<undefined_label ) {
23980 mp->ll=mp->skip_table[c]; mp->skip_table[c]=undefined_label;
23982 mp->lll=qo(skip_byte(mp->ll));
23983 if ( mp->nl-mp->ll>128 ) {
23984 skip_error(mp->ll); goto CONTINUE;
23986 skip_byte(mp->ll)=qi(mp->nl-mp->ll-1); mp->ll=mp->ll-mp->lll;
23987 } while (mp->lll!=0);
23992 @ @<Compile a ligature/kern...@>=
23994 next_char(mp->nl)=qi(c); skip_byte(mp->nl)=qi(0);
23995 if ( mp->cur_mod<128 ) { /* ligature op */
23996 op_byte(mp->nl)=qi(mp->cur_mod); rem_byte(mp->nl)=qi(mp_get_code(mp));
23998 mp_get_x_next(mp); mp_scan_expression(mp);
23999 if ( mp->cur_type!=mp_known ) {
24000 exp_err("Improper kern");
24002 help2("The amount of kern should be a known numeric value.")
24003 ("I'm zeroing this one. Proceed, with fingers crossed.");
24004 mp_put_get_flush_error(mp, 0);
24006 mp->kern[mp->nk]=mp->cur_exp;
24008 while ( mp->kern[k]!=mp->cur_exp ) incr(k);
24010 if ( mp->nk==max_tfm_int ) mp_fatal_error(mp, "too many TFM kerns");
24013 op_byte(mp->nl)=kern_flag+(k / 256);
24014 rem_byte(mp->nl)=qi((k % 256));
24016 mp->lk_started=true;
24019 @ @d missing_extensible_punctuation(A)
24020 { mp_missing_err(mp, (A));
24021 @.Missing `\char`\#'@>
24022 help1("I'm processing `extensible c: t,m,b,r'."); mp_back_error(mp);
24025 @<Define an extensible recipe@>=
24027 if ( mp->ne==256 ) mp_fatal_error(mp, "too many extensible recipies");
24028 c=mp_get_code(mp); mp_set_tag(mp, c,ext_tag,mp->ne);
24029 if ( mp->cur_cmd!=colon ) missing_extensible_punctuation(":");
24030 ext_top(mp->ne)=qi(mp_get_code(mp));
24031 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
24032 ext_mid(mp->ne)=qi(mp_get_code(mp));
24033 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
24034 ext_bot(mp->ne)=qi(mp_get_code(mp));
24035 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
24036 ext_rep(mp->ne)=qi(mp_get_code(mp));
24040 @ The header could contain ASCII zeroes, so can't use |strdup|.
24042 @<Store a list of header bytes@>=
24044 if ( j>=mp->header_size ) {
24045 int l = mp->header_size + (mp->header_size >> 2);
24046 char *t = xmalloc(l,sizeof(char));
24048 memcpy(t,mp->header_byte,mp->header_size);
24049 xfree (mp->header_byte);
24050 mp->header_byte = t;
24051 mp->header_size = l;
24053 mp->header_byte[j]=mp_get_code(mp);
24054 incr(j); incr(mp->header_last);
24055 } while (mp->cur_cmd==comma)
24057 @ @<Store a list of font dimensions@>=
24059 if ( j>max_tfm_int ) mp_fatal_error(mp, "too many fontdimens");
24060 while ( j>mp->np ) { incr(mp->np); mp->param[mp->np]=0; };
24061 mp_get_x_next(mp); mp_scan_expression(mp);
24062 if ( mp->cur_type!=mp_known ){
24063 exp_err("Improper font parameter");
24064 @.Improper font parameter@>
24065 help1("I'm zeroing this one. Proceed, with fingers crossed.");
24066 mp_put_get_flush_error(mp, 0);
24068 mp->param[j]=mp->cur_exp; incr(j);
24069 } while (mp->cur_cmd==comma)
24071 @ OK: We've stored all the data that is needed for the \.{TFM} file.
24072 All that remains is to output it in the correct format.
24074 An interesting problem needs to be solved in this connection, because
24075 the \.{TFM} format allows at most 256~widths, 16~heights, 16~depths,
24076 and 64~italic corrections. If the data has more distinct values than
24077 this, we want to meet the necessary restrictions by perturbing the
24078 given values as little as possible.
24080 \MP\ solves this problem in two steps. First the values of a given
24081 kind (widths, heights, depths, or italic corrections) are sorted;
24082 then the list of sorted values is perturbed, if necessary.
24084 The sorting operation is facilitated by having a special node of
24085 essentially infinite |value| at the end of the current list.
24087 @<Initialize table entries...@>=
24088 value(inf_val)=fraction_four;
24090 @ Straight linear insertion is good enough for sorting, since the lists
24091 are usually not terribly long. As we work on the data, the current list
24092 will start at |link(temp_head)| and end at |inf_val|; the nodes in this
24093 list will be in increasing order of their |value| fields.
24095 Given such a list, the |sort_in| function takes a value and returns a pointer
24096 to where that value can be found in the list. The value is inserted in
24097 the proper place, if necessary.
24099 At the time we need to do these operations, most of \MP's work has been
24100 completed, so we will have plenty of memory to play with. The value nodes
24101 that are allocated for sorting will never be returned to free storage.
24103 @d clear_the_list link(temp_head)=inf_val
24105 @c pointer mp_sort_in (MP mp,scaled v) {
24106 pointer p,q,r; /* list manipulation registers */
24110 if ( v<=value(q) ) break;
24113 if ( v<value(q) ) {
24114 r=mp_get_node(mp, value_node_size); value(r)=v; link(r)=q; link(p)=r;
24119 @ Now we come to the interesting part, where we reduce the list if necessary
24120 until it has the required size. The |min_cover| routine is basic to this
24121 process; it computes the minimum number~|m| such that the values of the
24122 current sorted list can be covered by |m|~intervals of width~|d|. It
24123 also sets the global value |perturbation| to the smallest value $d'>d$
24124 such that the covering found by this algorithm would be different.
24126 In particular, |min_cover(0)| returns the number of distinct values in the
24127 current list and sets |perturbation| to the minimum distance between
24130 @c integer mp_min_cover (MP mp,scaled d) {
24131 pointer p; /* runs through the current list */
24132 scaled l; /* the least element covered by the current interval */
24133 integer m; /* lower bound on the size of the minimum cover */
24134 m=0; p=link(temp_head); mp->perturbation=el_gordo;
24135 while ( p!=inf_val ){
24136 incr(m); l=value(p);
24137 do { p=link(p); } while (value(p)<=l+d);
24138 if ( value(p)-l<mp->perturbation )
24139 mp->perturbation=value(p)-l;
24145 scaled perturbation; /* quantity related to \.{TFM} rounding */
24146 integer excess; /* the list is this much too long */
24148 @ The smallest |d| such that a given list can be covered with |m| intervals
24149 is determined by the |threshold| routine, which is sort of an inverse
24150 to |min_cover|. The idea is to increase the interval size rapidly until
24151 finding the range, then to go sequentially until the exact borderline has
24154 @c scaled mp_threshold (MP mp,integer m) {
24155 scaled d; /* lower bound on the smallest interval size */
24156 mp->excess=mp_min_cover(mp, 0)-m;
24157 if ( mp->excess<=0 ) {
24161 d=mp->perturbation;
24162 } while (mp_min_cover(mp, d+d)>m);
24163 while ( mp_min_cover(mp, d)>m )
24164 d=mp->perturbation;
24169 @ The |skimp| procedure reduces the current list to at most |m| entries,
24170 by changing values if necessary. It also sets |info(p):=k| if |value(p)|
24171 is the |k|th distinct value on the resulting list, and it sets
24172 |perturbation| to the maximum amount by which a |value| field has
24173 been changed. The size of the resulting list is returned as the
24176 @c integer mp_skimp (MP mp,integer m) {
24177 scaled d; /* the size of intervals being coalesced */
24178 pointer p,q,r; /* list manipulation registers */
24179 scaled l; /* the least value in the current interval */
24180 scaled v; /* a compromise value */
24181 d=mp_threshold(mp, m); mp->perturbation=0;
24182 q=temp_head; m=0; p=link(temp_head);
24183 while ( p!=inf_val ) {
24184 incr(m); l=value(p); info(p)=m;
24185 if ( value(link(p))<=l+d ) {
24186 @<Replace an interval of values by its midpoint@>;
24193 @ @<Replace an interval...@>=
24196 p=link(p); info(p)=m;
24197 decr(mp->excess); if ( mp->excess==0 ) d=0;
24198 } while (value(link(p))<=l+d);
24199 v=l+halfp(value(p)-l);
24200 if ( value(p)-v>mp->perturbation )
24201 mp->perturbation=value(p)-v;
24204 r=link(r); value(r)=v;
24206 link(q)=p; /* remove duplicate values from the current list */
24209 @ A warning message is issued whenever something is perturbed by
24210 more than 1/16\thinspace pt.
24212 @c void mp_tfm_warning (MP mp,small_number m) {
24213 mp_print_nl(mp, "(some ");
24214 mp_print(mp, mp->int_name[m]);
24215 @.some charwds...@>
24216 @.some chardps...@>
24217 @.some charhts...@>
24218 @.some charics...@>
24219 mp_print(mp, " values had to be adjusted by as much as ");
24220 mp_print_scaled(mp, mp->perturbation); mp_print(mp, "pt)");
24223 @ Here's an example of how we use these routines.
24224 The width data needs to be perturbed only if there are 256 distinct
24225 widths, but \MP\ must check for this case even though it is
24228 An integer variable |k| will be defined when we use this code.
24229 The |dimen_head| array will contain pointers to the sorted
24230 lists of dimensions.
24232 @<Massage the \.{TFM} widths@>=
24234 for (k=mp->bc;k<=mp->ec;k++) {
24235 if ( mp->char_exists[k] )
24236 mp->tfm_width[k]=mp_sort_in(mp, mp->tfm_width[k]);
24238 mp->nw=mp_skimp(mp, 255)+1; mp->dimen_head[1]=link(temp_head);
24239 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_wd)
24242 pointer dimen_head[5]; /* lists of \.{TFM} dimensions */
24244 @ Heights, depths, and italic corrections are different from widths
24245 not only because their list length is more severely restricted, but
24246 also because zero values do not need to be put into the lists.
24248 @<Massage the \.{TFM} heights, depths, and italic corrections@>=
24250 for (k=mp->bc;k<=mp->ec;k++) {
24251 if ( mp->char_exists[k] ) {
24252 if ( mp->tfm_height[k]==0 ) mp->tfm_height[k]=zero_val;
24253 else mp->tfm_height[k]=mp_sort_in(mp, mp->tfm_height[k]);
24256 mp->nh=mp_skimp(mp, 15)+1; mp->dimen_head[2]=link(temp_head);
24257 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_ht);
24259 for (k=mp->bc;k<=mp->ec;k++) {
24260 if ( mp->char_exists[k] ) {
24261 if ( mp->tfm_depth[k]==0 ) mp->tfm_depth[k]=zero_val;
24262 else mp->tfm_depth[k]=mp_sort_in(mp, mp->tfm_depth[k]);
24265 mp->nd=mp_skimp(mp, 15)+1; mp->dimen_head[3]=link(temp_head);
24266 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_dp);
24268 for (k=mp->bc;k<=mp->ec;k++) {
24269 if ( mp->char_exists[k] ) {
24270 if ( mp->tfm_ital_corr[k]==0 ) mp->tfm_ital_corr[k]=zero_val;
24271 else mp->tfm_ital_corr[k]=mp_sort_in(mp, mp->tfm_ital_corr[k]);
24274 mp->ni=mp_skimp(mp, 63)+1; mp->dimen_head[4]=link(temp_head);
24275 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_ic)
24277 @ @<Initialize table entries...@>=
24278 value(zero_val)=0; info(zero_val)=0;
24280 @ Bytes 5--8 of the header are set to the design size, unless the user has
24281 some crazy reason for specifying them differently.
24284 Error messages are not allowed at the time this procedure is called,
24285 so a warning is printed instead.
24287 The value of |max_tfm_dimen| is calculated so that
24288 $$\hbox{|make_scaled(16*max_tfm_dimen,internal[mp_design_size])|}
24289 < \\{three\_bytes}.$$
24291 @d three_bytes 0100000000 /* $2^{24}$ */
24294 void mp_fix_design_size (MP mp) {
24295 scaled d; /* the design size */
24296 d=mp->internal[mp_design_size];
24297 if ( (d<unity)||(d>=fraction_half) ) {
24299 mp_print_nl(mp, "(illegal design size has been changed to 128pt)");
24300 @.illegal design size...@>
24301 d=040000000; mp->internal[mp_design_size]=d;
24303 if ( mp->header_byte[4]<0 ) if ( mp->header_byte[5]<0 )
24304 if ( mp->header_byte[6]<0 ) if ( mp->header_byte[7]<0 ) {
24305 mp->header_byte[4]=d / 04000000;
24306 mp->header_byte[5]=(d / 4096) % 256;
24307 mp->header_byte[6]=(d / 16) % 256;
24308 mp->header_byte[7]=(d % 16)*16;
24310 mp->max_tfm_dimen=16*mp->internal[mp_design_size]-1-mp->internal[mp_design_size] / 010000000;
24311 if ( mp->max_tfm_dimen>=fraction_half ) mp->max_tfm_dimen=fraction_half-1;
24314 @ The |dimen_out| procedure computes a |fix_word| relative to the
24315 design size. If the data was out of range, it is corrected and the
24316 global variable |tfm_changed| is increased by~one.
24318 @c integer mp_dimen_out (MP mp,scaled x) {
24319 if ( abs(x)>mp->max_tfm_dimen ) {
24320 incr(mp->tfm_changed);
24321 if ( x>0 ) x=mp->max_tfm_dimen; else x=-mp->max_tfm_dimen;
24323 x=mp_make_scaled(mp, x*16,mp->internal[mp_design_size]);
24328 scaled max_tfm_dimen; /* bound on widths, heights, kerns, etc. */
24329 integer tfm_changed; /* the number of data entries that were out of bounds */
24331 @ If the user has not specified any of the first four header bytes,
24332 the |fix_check_sum| procedure replaces them by a ``check sum'' computed
24333 from the |tfm_width| data relative to the design size.
24336 @c void mp_fix_check_sum (MP mp) {
24337 eight_bits k; /* runs through character codes */
24338 eight_bits B1,B2,B3,B4; /* bytes of the check sum */
24339 integer x; /* hash value used in check sum computation */
24340 if ( mp->header_byte[0]==0 && mp->header_byte[1]==0 &&
24341 mp->header_byte[2]==0 && mp->header_byte[3]==0 ) {
24342 @<Compute a check sum in |(b1,b2,b3,b4)|@>;
24343 mp->header_byte[0]=B1; mp->header_byte[1]=B2;
24344 mp->header_byte[2]=B3; mp->header_byte[3]=B4;
24349 @ @<Compute a check sum in |(b1,b2,b3,b4)|@>=
24350 B1=mp->bc; B2=mp->ec; B3=mp->bc; B4=mp->ec; mp->tfm_changed=0;
24351 for (k=mp->bc;k<=mp->ec;k++) {
24352 if ( mp->char_exists[k] ) {
24353 x=mp_dimen_out(mp, value(mp->tfm_width[k]))+(k+4)*020000000; /* this is positive */
24354 B1=(B1+B1+x) % 255;
24355 B2=(B2+B2+x) % 253;
24356 B3=(B3+B3+x) % 251;
24357 B4=(B4+B4+x) % 247;
24361 @ Finally we're ready to actually write the \.{TFM} information.
24362 Here are some utility routines for this purpose.
24364 @d tfm_out(A) do { /* output one byte to |tfm_file| */
24365 unsigned char s=(A);
24366 (mp->write_binary_file)(mp,mp->tfm_file,(void *)&s,1);
24369 @c void mp_tfm_two (MP mp,integer x) { /* output two bytes to |tfm_file| */
24370 tfm_out(x / 256); tfm_out(x % 256);
24372 void mp_tfm_four (MP mp,integer x) { /* output four bytes to |tfm_file| */
24373 if ( x>=0 ) tfm_out(x / three_bytes);
24375 x=x+010000000000; /* use two's complement for negative values */
24377 tfm_out((x / three_bytes) + 128);
24379 x=x % three_bytes; tfm_out(x / unity);
24380 x=x % unity; tfm_out(x / 0400);
24383 void mp_tfm_qqqq (MP mp,four_quarters x) { /* output four quarterwords to |tfm_file| */
24384 tfm_out(qo(x.b0)); tfm_out(qo(x.b1));
24385 tfm_out(qo(x.b2)); tfm_out(qo(x.b3));
24388 @ @<Finish the \.{TFM} file@>=
24389 if ( mp->job_name==NULL ) mp_open_log_file(mp);
24390 mp_pack_job_name(mp, ".tfm");
24391 while ( ! mp_b_open_out(mp, &mp->tfm_file, mp_filetype_metrics) )
24392 mp_prompt_file_name(mp, "file name for font metrics",".tfm");
24393 mp->metric_file_name=xstrdup(mp->name_of_file);
24394 @<Output the subfile sizes and header bytes@>;
24395 @<Output the character information bytes, then
24396 output the dimensions themselves@>;
24397 @<Output the ligature/kern program@>;
24398 @<Output the extensible character recipes and the font metric parameters@>;
24399 if ( mp->internal[mp_tracing_stats]>0 )
24400 @<Log the subfile sizes of the \.{TFM} file@>;
24401 mp_print_nl(mp, "Font metrics written on ");
24402 mp_print(mp, mp->metric_file_name); mp_print_char(mp, '.');
24403 @.Font metrics written...@>
24404 (mp->close_file)(mp,mp->tfm_file)
24406 @ Integer variables |lh|, |k|, and |lk_offset| will be defined when we use
24409 @<Output the subfile sizes and header bytes@>=
24411 LH=(k+3) / 4; /* this is the number of header words */
24412 if ( mp->bc>mp->ec ) mp->bc=1; /* if there are no characters, |ec=0| and |bc=1| */
24413 @<Compute the ligature/kern program offset and implant the
24414 left boundary label@>;
24415 mp_tfm_two(mp,6+LH+(mp->ec-mp->bc+1)+mp->nw+mp->nh+mp->nd+mp->ni+mp->nl
24416 +lk_offset+mp->nk+mp->ne+mp->np);
24417 /* this is the total number of file words that will be output */
24418 mp_tfm_two(mp, LH); mp_tfm_two(mp, mp->bc); mp_tfm_two(mp, mp->ec);
24419 mp_tfm_two(mp, mp->nw); mp_tfm_two(mp, mp->nh);
24420 mp_tfm_two(mp, mp->nd); mp_tfm_two(mp, mp->ni); mp_tfm_two(mp, mp->nl+lk_offset);
24421 mp_tfm_two(mp, mp->nk); mp_tfm_two(mp, mp->ne);
24422 mp_tfm_two(mp, mp->np);
24423 for (k=0;k< 4*LH;k++) {
24424 tfm_out(mp->header_byte[k]);
24427 @ @<Output the character information bytes...@>=
24428 for (k=mp->bc;k<=mp->ec;k++) {
24429 if ( ! mp->char_exists[k] ) {
24430 mp_tfm_four(mp, 0);
24432 tfm_out(info(mp->tfm_width[k])); /* the width index */
24433 tfm_out((info(mp->tfm_height[k]))*16+info(mp->tfm_depth[k]));
24434 tfm_out((info(mp->tfm_ital_corr[k]))*4+mp->char_tag[k]);
24435 tfm_out(mp->char_remainder[k]);
24439 for (k=1;k<=4;k++) {
24440 mp_tfm_four(mp, 0); p=mp->dimen_head[k];
24441 while ( p!=inf_val ) {
24442 mp_tfm_four(mp, mp_dimen_out(mp, value(p))); p=link(p);
24447 @ We need to output special instructions at the beginning of the
24448 |lig_kern| array in order to specify the right boundary character
24449 and/or to handle starting addresses that exceed 255. The |label_loc|
24450 and |label_char| arrays have been set up to record all the
24451 starting addresses; we have $-1=|label_loc|[0]<|label_loc|[1]\le\cdots
24452 \le|label_loc|[|label_ptr]|$.
24454 @<Compute the ligature/kern program offset...@>=
24455 mp->bchar=mp_round_unscaled(mp, mp->internal[mp_boundary_char]);
24456 if ((mp->bchar<0)||(mp->bchar>255))
24457 { mp->bchar=-1; mp->lk_started=false; lk_offset=0; }
24458 else { mp->lk_started=true; lk_offset=1; };
24459 @<Find the minimum |lk_offset| and adjust all remainders@>;
24460 if ( mp->bch_label<undefined_label )
24461 { skip_byte(mp->nl)=qi(255); next_char(mp->nl)=qi(0);
24462 op_byte(mp->nl)=qi(((mp->bch_label+lk_offset)/ 256));
24463 rem_byte(mp->nl)=qi(((mp->bch_label+lk_offset)% 256));
24464 incr(mp->nl); /* possibly |nl=lig_table_size+1| */
24467 @ @<Find the minimum |lk_offset|...@>=
24468 k=mp->label_ptr; /* pointer to the largest unallocated label */
24469 if ( mp->label_loc[k]+lk_offset>255 ) {
24470 lk_offset=0; mp->lk_started=false; /* location 0 can do double duty */
24472 mp->char_remainder[mp->label_char[k]]=lk_offset;
24473 while ( mp->label_loc[k-1]==mp->label_loc[k] ) {
24474 decr(k); mp->char_remainder[mp->label_char[k]]=lk_offset;
24476 incr(lk_offset); decr(k);
24477 } while (! (lk_offset+mp->label_loc[k]<256));
24478 /* N.B.: |lk_offset=256| satisfies this when |k=0| */
24480 if ( lk_offset>0 ) {
24482 mp->char_remainder[mp->label_char[k]]
24483 =mp->char_remainder[mp->label_char[k]]+lk_offset;
24488 @ @<Output the ligature/kern program@>=
24489 for (k=0;k<= 255;k++ ) {
24490 if ( mp->skip_table[k]<undefined_label ) {
24491 mp_print_nl(mp, "(local label "); mp_print_int(mp, k); mp_print(mp, ":: was missing)");
24492 @.local label l:: was missing@>
24493 cancel_skips(mp->skip_table[k]);
24496 if ( mp->lk_started ) { /* |lk_offset=1| for the special |bchar| */
24497 tfm_out(255); tfm_out(mp->bchar); mp_tfm_two(mp, 0);
24499 for (k=1;k<=lk_offset;k++) {/* output the redirection specs */
24500 mp->ll=mp->label_loc[mp->label_ptr];
24501 if ( mp->bchar<0 ) { tfm_out(254); tfm_out(0); }
24502 else { tfm_out(255); tfm_out(mp->bchar); };
24503 mp_tfm_two(mp, mp->ll+lk_offset);
24505 decr(mp->label_ptr);
24506 } while (! (mp->label_loc[mp->label_ptr]<mp->ll));
24509 for (k=0;k<=mp->nl-1;k++) mp_tfm_qqqq(mp, mp->lig_kern[k]);
24510 for (k=0;k<=mp->nk-1;k++) mp_tfm_four(mp, mp_dimen_out(mp, mp->kern[k]))
24512 @ @<Output the extensible character recipes...@>=
24513 for (k=0;k<=mp->ne-1;k++)
24514 mp_tfm_qqqq(mp, mp->exten[k]);
24515 for (k=1;k<=mp->np;k++) {
24517 if ( abs(mp->param[1])<fraction_half ) {
24518 mp_tfm_four(mp, mp->param[1]*16);
24520 incr(mp->tfm_changed);
24521 if ( mp->param[1]>0 ) mp_tfm_four(mp, el_gordo);
24522 else mp_tfm_four(mp, -el_gordo);
24525 mp_tfm_four(mp, mp_dimen_out(mp, mp->param[k]));
24528 if ( mp->tfm_changed>0 ) {
24529 if ( mp->tfm_changed==1 ) mp_print_nl(mp, "(a font metric dimension");
24530 @.a font metric dimension...@>
24532 mp_print_nl(mp, "("); mp_print_int(mp, mp->tfm_changed);
24533 @.font metric dimensions...@>
24534 mp_print(mp, " font metric dimensions");
24536 mp_print(mp, " had to be decreased)");
24539 @ @<Log the subfile sizes of the \.{TFM} file@>=
24543 if ( mp->bch_label<undefined_label ) decr(mp->nl);
24544 mp_snprintf(s,128,"(You used %iw,%ih,%id,%ii,%il,%ik,%ie,%ip metric file positions)",
24545 mp->nw, mp->nh, mp->nd, mp->ni, mp->nl, mp->nk, mp->ne,mp->np);
24549 @* \[43] Reading font metric data.
24551 \MP\ isn't a typesetting program but it does need to find the bounding box
24552 of a sequence of typeset characters. Thus it needs to read \.{TFM} files as
24553 well as write them.
24558 @ All the width, height, and depth information is stored in an array called
24559 |font_info|. This array is allocated sequentially and each font is stored
24560 as a series of |char_info| words followed by the width, height, and depth
24561 tables. Since |font_name| entries are permanent, their |str_ref| values are
24562 set to |max_str_ref|.
24565 typedef unsigned int font_number; /* |0..font_max| */
24567 @ The |font_info| array is indexed via a group directory arrays.
24568 For example, the |char_info| data for character~|c| in font~|f| will be
24569 in |font_info[char_base[f]+c].qqqq|.
24572 font_number font_max; /* maximum font number for included text fonts */
24573 size_t font_mem_size; /* number of words for \.{TFM} information for text fonts */
24574 memory_word *font_info; /* height, width, and depth data */
24575 char **font_enc_name; /* encoding names, if any */
24576 boolean *font_ps_name_fixed; /* are the postscript names fixed already? */
24577 int next_fmem; /* next unused entry in |font_info| */
24578 font_number last_fnum; /* last font number used so far */
24579 scaled *font_dsize; /* 16 times the ``design'' size in \ps\ points */
24580 char **font_name; /* name as specified in the \&{infont} command */
24581 char **font_ps_name; /* PostScript name for use when |internal[mp_prologues]>0| */
24582 font_number last_ps_fnum; /* last valid |font_ps_name| index */
24583 eight_bits *font_bc;
24584 eight_bits *font_ec; /* first and last character code */
24585 int *char_base; /* base address for |char_info| */
24586 int *width_base; /* index for zeroth character width */
24587 int *height_base; /* index for zeroth character height */
24588 int *depth_base; /* index for zeroth character depth */
24589 pointer *font_sizes;
24591 @ @<Allocate or initialize ...@>=
24592 mp->font_mem_size = 10000;
24593 mp->font_info = xmalloc ((mp->font_mem_size+1),sizeof(memory_word));
24594 memset (mp->font_info,0,sizeof(memory_word)*(mp->font_mem_size+1));
24595 mp->font_enc_name = NULL;
24596 mp->font_ps_name_fixed = NULL;
24597 mp->font_dsize = NULL;
24598 mp->font_name = NULL;
24599 mp->font_ps_name = NULL;
24600 mp->font_bc = NULL;
24601 mp->font_ec = NULL;
24602 mp->last_fnum = null_font;
24603 mp->char_base = NULL;
24604 mp->width_base = NULL;
24605 mp->height_base = NULL;
24606 mp->depth_base = NULL;
24607 mp->font_sizes = null;
24609 @ @<Dealloc variables@>=
24610 for (k=1;k<=(int)mp->last_fnum;k++) {
24611 xfree(mp->font_enc_name[k]);
24612 xfree(mp->font_name[k]);
24613 xfree(mp->font_ps_name[k]);
24615 xfree(mp->font_info);
24616 xfree(mp->font_enc_name);
24617 xfree(mp->font_ps_name_fixed);
24618 xfree(mp->font_dsize);
24619 xfree(mp->font_name);
24620 xfree(mp->font_ps_name);
24621 xfree(mp->font_bc);
24622 xfree(mp->font_ec);
24623 xfree(mp->char_base);
24624 xfree(mp->width_base);
24625 xfree(mp->height_base);
24626 xfree(mp->depth_base);
24627 xfree(mp->font_sizes);
24631 void mp_reallocate_fonts (MP mp, font_number l) {
24633 XREALLOC(mp->font_enc_name, l, char *);
24634 XREALLOC(mp->font_ps_name_fixed, l, boolean);
24635 XREALLOC(mp->font_dsize, l, scaled);
24636 XREALLOC(mp->font_name, l, char *);
24637 XREALLOC(mp->font_ps_name, l, char *);
24638 XREALLOC(mp->font_bc, l, eight_bits);
24639 XREALLOC(mp->font_ec, l, eight_bits);
24640 XREALLOC(mp->char_base, l, int);
24641 XREALLOC(mp->width_base, l, int);
24642 XREALLOC(mp->height_base, l, int);
24643 XREALLOC(mp->depth_base, l, int);
24644 XREALLOC(mp->font_sizes, l, pointer);
24645 for (f=(mp->last_fnum+1);f<=l;f++) {
24646 mp->font_enc_name[f]=NULL;
24647 mp->font_ps_name_fixed[f] = false;
24648 mp->font_name[f]=NULL;
24649 mp->font_ps_name[f]=NULL;
24650 mp->font_sizes[f]=null;
24655 @ @<Declare |mp_reallocate| functions@>=
24656 void mp_reallocate_fonts (MP mp, font_number l);
24659 @ A |null_font| containing no characters is useful for error recovery. Its
24660 |font_name| entry starts out empty but is reset each time an erroneous font is
24661 found. This helps to cut down on the number of duplicate error messages without
24662 wasting a lot of space.
24664 @d null_font 0 /* the |font_number| for an empty font */
24666 @<Set initial...@>=
24667 mp->font_dsize[null_font]=0;
24668 mp->font_bc[null_font]=1;
24669 mp->font_ec[null_font]=0;
24670 mp->char_base[null_font]=0;
24671 mp->width_base[null_font]=0;
24672 mp->height_base[null_font]=0;
24673 mp->depth_base[null_font]=0;
24675 mp->last_fnum=null_font;
24676 mp->last_ps_fnum=null_font;
24677 mp->font_name[null_font]=(char *)"nullfont";
24678 mp->font_ps_name[null_font]=(char *)"";
24679 mp->font_ps_name_fixed[null_font] = false;
24680 mp->font_enc_name[null_font]=NULL;
24681 mp->font_sizes[null_font]=null;
24683 @ Each |char_info| word is of type |four_quarters|. The |b0| field contains
24684 the |width index|; the |b1| field contains the height
24685 index; the |b2| fields contains the depth index, and the |b3| field used only
24686 for temporary storage. (It is used to keep track of which characters occur in
24687 an edge structure that is being shipped out.)
24688 The corresponding words in the width, height, and depth tables are stored as
24689 |scaled| values in units of \ps\ points.
24691 With the macros below, the |char_info| word for character~|c| in font~|f| is
24692 |char_info(f)(c)| and the width is
24693 $$\hbox{|char_width(f)(char_info(f)(c)).sc|.}$$
24695 @d char_info_end(A) (A)].qqqq
24696 @d char_info(A) mp->font_info[mp->char_base[(A)]+char_info_end
24697 @d char_width_end(A) (A).b0].sc
24698 @d char_width(A) mp->font_info[mp->width_base[(A)]+char_width_end
24699 @d char_height_end(A) (A).b1].sc
24700 @d char_height(A) mp->font_info[mp->height_base[(A)]+char_height_end
24701 @d char_depth_end(A) (A).b2].sc
24702 @d char_depth(A) mp->font_info[mp->depth_base[(A)]+char_depth_end
24703 @d ichar_exists(A) ((A).b0>0)
24705 @ The |font_ps_name| for a built-in font should be what PostScript expects.
24706 A preliminary name is obtained here from the \.{TFM} name as given in the
24707 |fname| argument. This gets updated later from an external table if necessary.
24709 @<Declare text measuring subroutines@>=
24710 @<Declare subroutines for parsing file names@>
24711 font_number mp_read_font_info (MP mp, char *fname) {
24712 boolean file_opened; /* has |tfm_infile| been opened? */
24713 font_number n; /* the number to return */
24714 halfword lf,tfm_lh,bc,ec,nw,nh,nd; /* subfile size parameters */
24715 size_t whd_size; /* words needed for heights, widths, and depths */
24716 int i,ii; /* |font_info| indices */
24717 int jj; /* counts bytes to be ignored */
24718 scaled z; /* used to compute the design size */
24720 /* height, width, or depth as a fraction of design size times $2^{-8}$ */
24721 eight_bits h_and_d; /* height and depth indices being unpacked */
24722 unsigned char tfbyte; /* a byte read from the file */
24724 @<Open |tfm_infile| for input@>;
24725 @<Read data from |tfm_infile|; if there is no room, say so and |goto done|;
24726 otherwise |goto bad_tfm| or |goto done| as appropriate@>;
24728 @<Complain that the \.{TFM} file is bad@>;
24730 if ( file_opened ) (mp->close_file)(mp,mp->tfm_infile);
24731 if ( n!=null_font ) {
24732 mp->font_ps_name[n]=mp_xstrdup(mp,fname);
24733 mp->font_name[n]=mp_xstrdup(mp,fname);
24738 @ \MP\ doesn't bother to check the entire \.{TFM} file for errors or explain
24739 precisely what is wrong if it does find a problem. Programs called \.{TFtoPL}
24740 @.TFtoPL@> @.PLtoTF@>
24741 and \.{PLtoTF} can be used to debug \.{TFM} files.
24743 @<Complain that the \.{TFM} file is bad@>=
24744 print_err("Font ");
24745 mp_print(mp, fname);
24746 if ( file_opened ) mp_print(mp, " not usable: TFM file is bad");
24747 else mp_print(mp, " not usable: TFM file not found");
24748 help3("I wasn't able to read the size data for this font so this")
24749 ("`infont' operation won't produce anything. If the font name")
24750 ("is right, you might ask an expert to make a TFM file");
24752 mp->help_line[0]="is right, try asking an expert to fix the TFM file";
24755 @ @<Read data from |tfm_infile|; if there is no room, say so...@>=
24756 @<Read the \.{TFM} size fields@>;
24757 @<Use the size fields to allocate space in |font_info|@>;
24758 @<Read the \.{TFM} header@>;
24759 @<Read the character data and the width, height, and depth tables and
24762 @ A bad \.{TFM} file can be shorter than it claims to be. The code given here
24763 might try to read past the end of the file if this happens. Changes will be
24764 needed if it causes a system error to refer to |tfm_infile^| or call
24765 |get_tfm_infile| when |eof(tfm_infile)| is true. For example, the definition
24766 @^system dependencies@>
24767 of |tfget| could be changed to
24768 ``|begin get(tfm_infile); if eof(tfm_infile) then goto bad_tfm; end|.''
24772 void *tfbyte_ptr = &tfbyte;
24773 (mp->read_binary_file)(mp,mp->tfm_infile,&tfbyte_ptr,&wanted);
24774 if (wanted==0) goto BAD_TFM;
24776 @d read_two(A) { (A)=tfbyte;
24777 if ( (A)>127 ) goto BAD_TFM;
24778 tfget; (A)=(A)*0400+tfbyte;
24780 @d tf_ignore(A) { for (jj=(A);jj>=1;jj--) tfget; }
24782 @<Read the \.{TFM} size fields@>=
24783 tfget; read_two(lf);
24784 tfget; read_two(tfm_lh);
24785 tfget; read_two(bc);
24786 tfget; read_two(ec);
24787 if ( (bc>1+ec)||(ec>255) ) goto BAD_TFM;
24788 tfget; read_two(nw);
24789 tfget; read_two(nh);
24790 tfget; read_two(nd);
24791 whd_size=(ec+1-bc)+nw+nh+nd;
24792 if ( lf<(int)(6+tfm_lh+whd_size) ) goto BAD_TFM;
24795 @ Offsets are added to |char_base[n]| and |width_base[n]| so that is not
24796 necessary to apply the |so| and |qo| macros when looking up the width of a
24797 character in the string pool. In order to ensure nonnegative |char_base|
24798 values when |bc>0|, it may be necessary to reserve a few unused |font_info|
24801 @<Use the size fields to allocate space in |font_info|@>=
24802 if ( mp->next_fmem<bc) mp->next_fmem=bc; /* ensure nonnegative |char_base| */
24803 if (mp->last_fnum==mp->font_max)
24804 mp_reallocate_fonts(mp,(mp->font_max+(mp->font_max>>2)));
24805 while (mp->next_fmem+whd_size>=mp->font_mem_size) {
24806 size_t l = mp->font_mem_size+(mp->font_mem_size>>2);
24807 memory_word *font_info;
24808 font_info = xmalloc ((l+1),sizeof(memory_word));
24809 memset (font_info,0,sizeof(memory_word)*(l+1));
24810 memcpy (font_info,mp->font_info,sizeof(memory_word)*(mp->font_mem_size+1));
24811 xfree(mp->font_info);
24812 mp->font_info = font_info;
24813 mp->font_mem_size = l;
24815 incr(mp->last_fnum);
24819 mp->char_base[n]=mp->next_fmem-bc;
24820 mp->width_base[n]=mp->next_fmem+ec-bc+1;
24821 mp->height_base[n]=mp->width_base[n]+nw;
24822 mp->depth_base[n]=mp->height_base[n]+nh;
24823 mp->next_fmem=mp->next_fmem+whd_size;
24826 @ @<Read the \.{TFM} header@>=
24827 if ( tfm_lh<2 ) goto BAD_TFM;
24829 tfget; read_two(z);
24830 tfget; z=z*0400+tfbyte;
24831 tfget; z=z*0400+tfbyte; /* now |z| is 16 times the design size */
24832 mp->font_dsize[n]=mp_take_fraction(mp, z,267432584);
24833 /* times ${72\over72.27}2^{28}$ to convert from \TeX\ points */
24834 tf_ignore(4*(tfm_lh-2))
24836 @ @<Read the character data and the width, height, and depth tables...@>=
24837 ii=mp->width_base[n];
24838 i=mp->char_base[n]+bc;
24840 tfget; mp->font_info[i].qqqq.b0=qi(tfbyte);
24841 tfget; h_and_d=tfbyte;
24842 mp->font_info[i].qqqq.b1=h_and_d / 16;
24843 mp->font_info[i].qqqq.b2=h_and_d % 16;
24847 while ( i<mp->next_fmem ) {
24848 @<Read a four byte dimension, scale it by the design size, store it in
24849 |font_info[i]|, and increment |i|@>;
24853 @ The raw dimension read into |d| should have magnitude at most $2^{24}$ when
24854 interpreted as an integer, and this includes a scale factor of $2^{20}$. Thus
24855 we can multiply it by sixteen and think of it as a |fraction| that has been
24856 divided by sixteen. This cancels the extra scale factor contained in
24859 @<Read a four byte dimension, scale it by the design size, store it in...@>=
24862 if ( d>=0200 ) d=d-0400;
24863 tfget; d=d*0400+tfbyte;
24864 tfget; d=d*0400+tfbyte;
24865 tfget; d=d*0400+tfbyte;
24866 mp->font_info[i].sc=mp_take_fraction(mp, d*16,mp->font_dsize[n]);
24870 @ This function does no longer use the file name parser, because |fname| is
24871 a C string already.
24872 @<Open |tfm_infile| for input@>=
24874 mp_ptr_scan_file(mp, fname);
24875 if ( strlen(mp->cur_area)==0 ) { xfree(mp->cur_area); }
24876 if ( strlen(mp->cur_ext)==0 ) { xfree(mp->cur_ext); mp->cur_ext=xstrdup(".tfm"); }
24878 mp->tfm_infile = (mp->open_file)(mp, mp->name_of_file, "r",mp_filetype_metrics);
24879 if ( !mp->tfm_infile ) goto BAD_TFM;
24882 @ When we have a font name and we don't know whether it has been loaded yet,
24883 we scan the |font_name| array before calling |read_font_info|.
24885 @<Declare text measuring subroutines@>=
24886 font_number mp_find_font (MP mp, char *f) {
24888 for (n=0;n<=mp->last_fnum;n++) {
24889 if (mp_xstrcmp(f,mp->font_name[n])==0 ) {
24894 n = mp_read_font_info(mp, f);
24899 @ This is an interface function for getting the width of character,
24900 as a double in ps units
24902 @c double mp_get_char_width (MP mp, char *fname, int c) {
24907 for (n=0;n<=mp->last_fnum;n++) {
24908 if (mp_xstrcmp(fname,mp->font_name[n])==0 ) {
24915 cc = char_info(f)(c);
24916 if (! ichar_exists(cc) )
24918 w = char_width(f)(cc);
24919 return w/655.35*(72.27/72);
24922 @ @<Exported function ...@>=
24923 double mp_get_char_width (MP mp, char *fname, int n);
24926 @ One simple application of |find_font| is the implementation of the |font_size|
24927 operator that gets the design size for a given font name.
24929 @<Find the design size of the font whose name is |cur_exp|@>=
24930 mp_flush_cur_exp(mp, (mp->font_dsize[mp_find_font(mp, str(mp->cur_exp))]+8) / 16)
24932 @ If we discover that the font doesn't have a requested character, we omit it
24933 from the bounding box computation and expect the \ps\ interpreter to drop it.
24934 This routine issues a warning message if the user has asked for it.
24936 @<Declare text measuring subroutines@>=
24937 void mp_lost_warning (MP mp,font_number f, pool_pointer k) {
24938 if ( mp->internal[mp_tracing_lost_chars]>0 ) {
24939 mp_begin_diagnostic(mp);
24940 if ( mp->selector==log_only ) incr(mp->selector);
24941 mp_print_nl(mp, "Missing character: There is no ");
24942 @.Missing character@>
24943 mp_print_str(mp, mp->str_pool[k]);
24944 mp_print(mp, " in font ");
24945 mp_print(mp, mp->font_name[f]); mp_print_char(mp, '!');
24946 mp_end_diagnostic(mp, false);
24950 @ The whole purpose of saving the height, width, and depth information is to be
24951 able to find the bounding box of an item of text in an edge structure. The
24952 |set_text_box| procedure takes a text node and adds this information.
24954 @<Declare text measuring subroutines@>=
24955 void mp_set_text_box (MP mp,pointer p) {
24956 font_number f; /* |font_n(p)| */
24957 ASCII_code bc,ec; /* range of valid characters for font |f| */
24958 pool_pointer k,kk; /* current character and character to stop at */
24959 four_quarters cc; /* the |char_info| for the current character */
24960 scaled h,d; /* dimensions of the current character */
24962 height_val(p)=-el_gordo;
24963 depth_val(p)=-el_gordo;
24967 kk=str_stop(text_p(p));
24968 k=mp->str_start[text_p(p)];
24970 @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>;
24972 @<Set the height and depth to zero if the bounding box is empty@>;
24975 @ @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>=
24977 if ( (mp->str_pool[k]<bc)||(mp->str_pool[k]>ec) ) {
24978 mp_lost_warning(mp, f,k);
24980 cc=char_info(f)(mp->str_pool[k]);
24981 if ( ! ichar_exists(cc) ) {
24982 mp_lost_warning(mp, f,k);
24984 width_val(p)=width_val(p)+char_width(f)(cc);
24985 h=char_height(f)(cc);
24986 d=char_depth(f)(cc);
24987 if ( h>height_val(p) ) height_val(p)=h;
24988 if ( d>depth_val(p) ) depth_val(p)=d;
24994 @ Let's hope modern compilers do comparisons correctly when the difference would
24997 @<Set the height and depth to zero if the bounding box is empty@>=
24998 if ( height_val(p)<-depth_val(p) ) {
25003 @ The new primitives fontmapfile and fontmapline.
25005 @<Declare action procedures for use by |do_statement|@>=
25006 void mp_do_mapfile (MP mp) ;
25007 void mp_do_mapline (MP mp) ;
25009 @ @c void mp_do_mapfile (MP mp) {
25010 mp_get_x_next(mp); mp_scan_expression(mp);
25011 if ( mp->cur_type!=mp_string_type ) {
25012 @<Complain about improper map operation@>;
25014 mp_map_file(mp,mp->cur_exp);
25017 void mp_do_mapline (MP mp) {
25018 mp_get_x_next(mp); mp_scan_expression(mp);
25019 if ( mp->cur_type!=mp_string_type ) {
25020 @<Complain about improper map operation@>;
25022 mp_map_line(mp,mp->cur_exp);
25026 @ @<Complain about improper map operation@>=
25028 exp_err("Unsuitable expression");
25029 help1("Only known strings can be map files or map lines.");
25030 mp_put_get_error(mp);
25033 @ To print |scaled| value to PDF output we need some subroutines to ensure
25036 @d max_integer 0x7FFFFFFF /* $2^{31}-1$ */
25039 scaled one_bp; /* scaled value corresponds to 1bp */
25040 scaled one_hundred_bp; /* scaled value corresponds to 100bp */
25041 scaled one_hundred_inch; /* scaled value corresponds to 100in */
25042 integer ten_pow[10]; /* $10^0..10^9$ */
25043 integer scaled_out; /* amount of |scaled| that was taken out in |divide_scaled| */
25046 mp->one_bp = 65782; /* 65781.76 */
25047 mp->one_hundred_bp = 6578176;
25048 mp->one_hundred_inch = 473628672;
25049 mp->ten_pow[0] = 1;
25050 for (i = 1;i<= 9; i++ ) {
25051 mp->ten_pow[i] = 10*mp->ten_pow[i - 1];
25054 @ The following function divides |s| by |m|. |dd| is number of decimal digits.
25056 @c scaled mp_divide_scaled (MP mp,scaled s, scaled m, integer dd) {
25060 if ( s < 0 ) { sign = -sign; s = -s; }
25061 if ( m < 0 ) { sign = -sign; m = -m; }
25063 mp_confusion(mp, "arithmetic: divided by zero");
25064 else if ( m >= (max_integer / 10) )
25065 mp_confusion(mp, "arithmetic: number too big");
25068 for (i = 1;i<=dd;i++) {
25069 q = 10*q + (10*r) / m;
25072 if ( 2*r >= m ) { incr(q); r = r - m; }
25073 mp->scaled_out = sign*(s - (r / mp->ten_pow[dd]));
25077 @* \[44] Shipping pictures out.
25078 The |ship_out| procedure, to be described below, is given a pointer to
25079 an edge structure. Its mission is to output a file containing the \ps\
25080 description of an edge structure.
25082 @ Each time an edge structure is shipped out we write a new \ps\ output
25083 file named according to the current \&{charcode}.
25084 @:char_code_}{\&{charcode} primitive@>
25086 This is the only backend function that remains in the main |mpost.w| file.
25087 There are just too many variable accesses needed for status reporting
25088 etcetera to make it worthwile to move the code to |psout.w|.
25090 @<Internal library declarations@>=
25091 void mp_open_output_file (MP mp) ;
25094 char *mp_set_output_file_name (MP mp, integer c) {
25095 char *ss = NULL; /* filename extension proposal */
25096 char *nn = NULL; /* temp string for str() */
25097 int old_setting; /* previous |selector| setting */
25098 pool_pointer i; /* indexes into |filename_template| */
25099 integer cc; /* a temporary integer for template building */
25100 integer f,g=0; /* field widths */
25101 if ( mp->job_name==NULL ) mp_open_log_file(mp);
25102 if ( mp->filename_template==0 ) {
25103 char *s; /* a file extension derived from |c| */
25107 @<Use |c| to compute the file extension |s|@>;
25108 mp_pack_job_name(mp, s);
25110 } else { /* initializations */
25111 str_number s, n; /* a file extension derived from |c| */
25112 old_setting=mp->selector;
25113 mp->selector=new_string;
25115 i = mp->str_start[mp->filename_template];
25116 n = rts(""); /* initialize */
25117 while ( i<str_stop(mp->filename_template) ) {
25118 if ( mp->str_pool[i]=='%' ) {
25121 if ( i<str_stop(mp->filename_template) ) {
25122 if ( mp->str_pool[i]=='j' ) {
25123 mp_print(mp, mp->job_name);
25124 } else if ( mp->str_pool[i]=='d' ) {
25125 cc= mp_round_unscaled(mp, mp->internal[mp_day]);
25126 print_with_leading_zeroes(cc);
25127 } else if ( mp->str_pool[i]=='m' ) {
25128 cc= mp_round_unscaled(mp, mp->internal[mp_month]);
25129 print_with_leading_zeroes(cc);
25130 } else if ( mp->str_pool[i]=='y' ) {
25131 cc= mp_round_unscaled(mp, mp->internal[mp_year]);
25132 print_with_leading_zeroes(cc);
25133 } else if ( mp->str_pool[i]=='H' ) {
25134 cc= mp_round_unscaled(mp, mp->internal[mp_time]) / 60;
25135 print_with_leading_zeroes(cc);
25136 } else if ( mp->str_pool[i]=='M' ) {
25137 cc= mp_round_unscaled(mp, mp->internal[mp_time]) % 60;
25138 print_with_leading_zeroes(cc);
25139 } else if ( mp->str_pool[i]=='c' ) {
25140 if ( c<0 ) mp_print(mp, "ps");
25141 else print_with_leading_zeroes(c);
25142 } else if ( (mp->str_pool[i]>='0') &&
25143 (mp->str_pool[i]<='9') ) {
25145 f = (f*10) + mp->str_pool[i]-'0';
25148 mp_print_str(mp, mp->str_pool[i]);
25152 if ( mp->str_pool[i]=='.' )
25154 n = mp_make_string(mp);
25155 mp_print_str(mp, mp->str_pool[i]);
25159 s = mp_make_string(mp);
25160 mp->selector= old_setting;
25161 if (length(n)==0) {
25167 mp_pack_file_name(mp, nn,"",ss);
25175 char * mp_get_output_file_name (MP mp) {
25177 char *saved_name; /* saved |name_of_file| */
25178 saved_name = mp_xstrdup(mp, mp->name_of_file);
25179 junk = mp_set_output_file_name(mp, mp_round_unscaled(mp, mp->internal[mp_char_code]));
25181 mp_pack_file_name(mp, saved_name,NULL,NULL);
25183 return mp->name_of_file;
25186 void mp_open_output_file (MP mp) {
25187 char *ss; /* filename extension proposal */
25188 integer c; /* \&{charcode} rounded to the nearest integer */
25189 c=mp_round_unscaled(mp, mp->internal[mp_char_code]);
25190 ss = mp_set_output_file_name(mp, c);
25191 while ( ! mp_a_open_out(mp, (void *)&mp->ps_file, mp_filetype_postscript) )
25192 mp_prompt_file_name(mp, "file name for output",ss);
25194 @<Store the true output file name if appropriate@>;
25197 @ The file extension created here could be up to five characters long in
25198 extreme cases so it may have to be shortened on some systems.
25199 @^system dependencies@>
25201 @<Use |c| to compute the file extension |s|@>=
25204 mp_snprintf(s,7,".%i",(int)c);
25207 @ The user won't want to see all the output file names so we only save the
25208 first and last ones and a count of how many there were. For this purpose
25209 files are ordered primarily by \&{charcode} and secondarily by order of
25211 @:char_code_}{\&{charcode} primitive@>
25213 @<Store the true output file name if appropriate@>=
25214 if ((c<mp->first_output_code)&&(mp->first_output_code>=0)) {
25215 mp->first_output_code=c;
25216 xfree(mp->first_file_name);
25217 mp->first_file_name=xstrdup(mp->name_of_file);
25219 if ( c>=mp->last_output_code ) {
25220 mp->last_output_code=c;
25221 xfree(mp->last_file_name);
25222 mp->last_file_name=xstrdup(mp->name_of_file);
25226 char * first_file_name;
25227 char * last_file_name; /* full file names */
25228 integer first_output_code;integer last_output_code; /* rounded \&{charcode} values */
25229 @:char_code_}{\&{charcode} primitive@>
25230 integer total_shipped; /* total number of |ship_out| operations completed */
25233 mp->first_file_name=xstrdup("");
25234 mp->last_file_name=xstrdup("");
25235 mp->first_output_code=32768;
25236 mp->last_output_code=-32768;
25237 mp->total_shipped=0;
25239 @ @<Dealloc variables@>=
25240 xfree(mp->first_file_name);
25241 xfree(mp->last_file_name);
25243 @ @<Begin the progress report for the output of picture~|c|@>=
25244 if ( (int)mp->term_offset>mp->max_print_line-6 ) mp_print_ln(mp);
25245 else if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_char(mp, ' ');
25246 mp_print_char(mp, '[');
25247 if ( c>=0 ) mp_print_int(mp, c)
25249 @ @<End progress report@>=
25250 mp_print_char(mp, ']');
25252 incr(mp->total_shipped)
25254 @ @<Explain what output files were written@>=
25255 if ( mp->total_shipped>0 ) {
25256 mp_print_nl(mp, "");
25257 mp_print_int(mp, mp->total_shipped);
25258 mp_print(mp, " output file");
25259 if ( mp->total_shipped>1 ) mp_print_char(mp, 's');
25260 mp_print(mp, " written: ");
25261 mp_print(mp, mp->first_file_name);
25262 if ( mp->total_shipped>1 ) {
25263 if ( 31+strlen(mp->first_file_name)+
25264 strlen(mp->last_file_name)> (unsigned)mp->max_print_line)
25266 mp_print(mp, " .. ");
25267 mp_print(mp, mp->last_file_name);
25271 @ @<Internal library declarations@>=
25272 boolean mp_has_font_size(MP mp, font_number f );
25275 boolean mp_has_font_size(MP mp, font_number f ) {
25276 return (mp->font_sizes[f]!=null);
25279 @ The \&{special} command saves up lines of text to be printed during the next
25280 |ship_out| operation. The saved items are stored as a list of capsule tokens.
25283 pointer last_pending; /* the last token in a list of pending specials */
25286 mp->last_pending=spec_head;
25288 @ @<Cases of |do_statement|...@>=
25289 case special_command:
25290 if ( mp->cur_mod==0 ) mp_do_special(mp); else
25291 if ( mp->cur_mod==1 ) mp_do_mapfile(mp); else
25295 @ @<Declare action procedures for use by |do_statement|@>=
25296 void mp_do_special (MP mp) ;
25298 @ @c void mp_do_special (MP mp) {
25299 mp_get_x_next(mp); mp_scan_expression(mp);
25300 if ( mp->cur_type!=mp_string_type ) {
25301 @<Complain about improper special operation@>;
25303 link(mp->last_pending)=mp_stash_cur_exp(mp);
25304 mp->last_pending=link(mp->last_pending);
25305 link(mp->last_pending)=null;
25309 @ @<Complain about improper special operation@>=
25311 exp_err("Unsuitable expression");
25312 help1("Only known strings are allowed for output as specials.");
25313 mp_put_get_error(mp);
25316 @ On the export side, we need an extra object type for special strings.
25318 @<Graphical object codes@>=
25321 @ @<Export pending specials@>=
25323 while ( p!=null ) {
25324 mp_special_object *tp;
25325 tp = (mp_special_object *)mp_new_graphic_object(mp,mp_special_code);
25326 gr_pre_script(tp) = str(value(p));
25327 if (hh->body==NULL) hh->body = (mp_graphic_object *)tp;
25328 else gr_link(hp) = (mp_graphic_object *)tp;
25329 hp = (mp_graphic_object *)tp;
25332 mp_flush_token_list(mp, link(spec_head));
25333 link(spec_head)=null;
25334 mp->last_pending=spec_head
25336 @ We are now ready for the main output procedure. Note that the |selector|
25337 setting is saved in a global variable so that |begin_diagnostic| can access it.
25339 @<Declare the \ps\ output procedures@>=
25340 void mp_ship_out (MP mp, pointer h) ;
25342 @ Once again, the |gr_XXXX| macros are defined in |mppsout.h|
25344 @d export_color(q,p)
25345 if ( color_model(p)==mp_uninitialized_model ) {
25346 gr_color_model(q) = (mp->internal[mp_default_color_model]>>16);
25347 gr_cyan_val(q) = 0;
25348 gr_magenta_val(q) = 0;
25349 gr_yellow_val(q) = 0;
25350 gr_black_val(q) = (gr_color_model(q)==mp_cmyk_model ? unity : 0);
25352 gr_color_model(q) = color_model(p);
25353 gr_cyan_val(q) = cyan_val(p);
25354 gr_magenta_val(q) = magenta_val(p);
25355 gr_yellow_val(q) = yellow_val(p);
25356 gr_black_val(q) = black_val(p);
25359 @d export_scripts(q,p)
25360 if (pre_script(p)!=null) gr_pre_script(q) = str(pre_script(p));
25361 if (post_script(p)!=null) gr_post_script(q) = str(post_script(p));
25364 struct mp_edge_object *mp_gr_export(MP mp, pointer h) {
25365 pointer p; /* the current graphical object */
25366 integer t; /* a temporary value */
25367 scaled d_width; /* the current pen width */
25368 mp_edge_object *hh; /* the first graphical object */
25369 struct mp_graphic_object *hq; /* something |hp| points to */
25370 struct mp_text_object *tt;
25371 struct mp_fill_object *tf;
25372 struct mp_stroked_object *ts;
25373 struct mp_clip_object *tc;
25374 struct mp_bounds_object *tb;
25375 struct mp_graphic_object *hp = NULL; /* the current graphical object */
25376 mp_set_bbox(mp, h, true);
25377 hh = mp_xmalloc(mp,1,sizeof(mp_edge_object));
25381 hh->_minx = minx_val(h);
25382 hh->_miny = miny_val(h);
25383 hh->_maxx = maxx_val(h);
25384 hh->_maxy = maxy_val(h);
25385 hh->_filename = mp_get_output_file_name(mp);
25386 @<Export pending specials@>;
25387 p=link(dummy_loc(h));
25388 while ( p!=null ) {
25389 hq = mp_new_graphic_object(mp,type(p));
25392 tf = (mp_fill_object *)hq;
25393 gr_pen_p(tf) = mp_export_knot_list(mp,pen_p(p));
25394 d_width = mp_get_pen_scale(mp, pen_p(p));
25395 if ((pen_p(p)==null) || pen_is_elliptical(pen_p(p))) {
25396 gr_path_p(tf) = mp_export_knot_list(mp,path_p(p));
25399 pc = mp_copy_path(mp, path_p(p));
25400 pp = mp_make_envelope(mp, pc, pen_p(p),ljoin_val(p),0,miterlim_val(p));
25401 gr_path_p(tf) = mp_export_knot_list(mp,pp);
25402 mp_toss_knot_list(mp, pp);
25403 pc = mp_htap_ypoc(mp, path_p(p));
25404 pp = mp_make_envelope(mp, pc, pen_p(p),ljoin_val(p),0,miterlim_val(p));
25405 gr_htap_p(tf) = mp_export_knot_list(mp,pp);
25406 mp_toss_knot_list(mp, pp);
25408 export_color(tf,p) ;
25409 export_scripts(tf,p);
25410 gr_ljoin_val(tf) = ljoin_val(p);
25411 gr_miterlim_val(tf) = miterlim_val(p);
25413 case mp_stroked_code:
25414 ts = (mp_stroked_object *)hq;
25415 gr_pen_p(ts) = mp_export_knot_list(mp,pen_p(p));
25416 d_width = mp_get_pen_scale(mp, pen_p(p));
25417 if (pen_is_elliptical(pen_p(p))) {
25418 gr_path_p(ts) = mp_export_knot_list(mp,path_p(p));
25421 pc=mp_copy_path(mp, path_p(p));
25423 if ( left_type(pc)!=mp_endpoint ) {
25424 left_type(mp_insert_knot(mp, pc,x_coord(pc),y_coord(pc)))=mp_endpoint;
25425 right_type(pc)=mp_endpoint;
25429 pc=mp_make_envelope(mp,pc,pen_p(p),ljoin_val(p),t,miterlim_val(p));
25430 gr_path_p(ts) = mp_export_knot_list(mp,pc);
25431 mp_toss_knot_list(mp, pc);
25433 export_color(ts,p) ;
25434 export_scripts(ts,p);
25435 gr_ljoin_val(ts) = ljoin_val(p);
25436 gr_miterlim_val(ts) = miterlim_val(p);
25437 gr_lcap_val(ts) = lcap_val(p);
25438 gr_dash_p(ts) = mp_export_dashes(mp,p,&d_width);
25441 tt = (mp_text_object *)hq;
25442 gr_text_p(tt) = str(text_p(p));
25443 gr_font_n(tt) = font_n(p);
25444 gr_font_name(tt) = mp_xstrdup(mp,mp->font_name[font_n(p)]);
25445 gr_font_dsize(tt) = mp->font_dsize[font_n(p)];
25446 export_color(tt,p) ;
25447 export_scripts(tt,p);
25448 gr_width_val(tt) = width_val(p);
25449 gr_height_val(tt) = height_val(p);
25450 gr_depth_val(tt) = depth_val(p);
25451 gr_tx_val(tt) = tx_val(p);
25452 gr_ty_val(tt) = ty_val(p);
25453 gr_txx_val(tt) = txx_val(p);
25454 gr_txy_val(tt) = txy_val(p);
25455 gr_tyx_val(tt) = tyx_val(p);
25456 gr_tyy_val(tt) = tyy_val(p);
25458 case mp_start_clip_code:
25459 tc = (mp_clip_object *)hq;
25460 gr_path_p(tc) = mp_export_knot_list(mp,path_p(p));
25462 case mp_start_bounds_code:
25463 tb = (mp_bounds_object *)hq;
25464 gr_path_p(tb) = mp_export_knot_list(mp,path_p(p));
25466 case mp_stop_clip_code:
25467 case mp_stop_bounds_code:
25468 /* nothing to do here */
25471 if (hh->body==NULL) hh->body=hq; else gr_link(hp) = hq;
25478 @ @<Exported function ...@>=
25479 struct mp_edge_object *mp_gr_export(MP mp, int h);
25481 @ This function is now nearly trivial.
25484 void mp_ship_out (MP mp, pointer h) { /* output edge structure |h| */
25485 integer c; /* \&{charcode} rounded to the nearest integer */
25486 c=mp_round_unscaled(mp, mp->internal[mp_char_code]);
25487 @<Begin the progress report for the output of picture~|c|@>;
25488 (mp->shipout_backend) (mp, h);
25489 @<End progress report@>;
25490 if ( mp->internal[mp_tracing_output]>0 )
25491 mp_print_edges(mp, h," (just shipped out)",true);
25494 @ @<Declarations@>=
25495 void mp_shipout_backend (MP mp, pointer h);
25498 void mp_shipout_backend (MP mp, pointer h) {
25499 mp_edge_object *hh; /* the first graphical object */
25500 hh = mp_gr_export(mp,h);
25501 mp_gr_ship_out (hh,
25502 (mp->internal[mp_prologues]>>16),
25503 (mp->internal[mp_procset]>>16));
25504 mp_gr_toss_objects(hh);
25507 @ @<Exported types@>=
25508 typedef void (*mp_backend_writer)(MP, int);
25510 @ @<Option variables@>=
25511 mp_backend_writer shipout_backend;
25513 @ @<Allocate or initialize ...@>=
25514 set_callback_option(shipout_backend);
25516 @ Now that we've finished |ship_out|, let's look at the other commands
25517 by which a user can send things to the \.{GF} file.
25519 @ @<Determine if a character has been shipped out@>=
25521 mp->cur_exp=mp_round_unscaled(mp, mp->cur_exp) % 256;
25522 if ( mp->cur_exp<0 ) mp->cur_exp=mp->cur_exp+256;
25523 boolean_reset(mp->char_exists[mp->cur_exp]);
25524 mp->cur_type=mp_boolean_type;
25530 @ @<Allocate or initialize ...@>=
25531 mp_backend_initialize(mp);
25534 mp_backend_free(mp);
25537 @* \[45] Dumping and undumping the tables.
25538 After \.{INIMP} has seen a collection of macros, it
25539 can write all the necessary information on an auxiliary file so
25540 that production versions of \MP\ are able to initialize their
25541 memory at high speed. The present section of the program takes
25542 care of such output and input. We shall consider simultaneously
25543 the processes of storing and restoring,
25544 so that the inverse relation between them is clear.
25547 The global variable |mem_ident| is a string that is printed right
25548 after the |banner| line when \MP\ is ready to start. For \.{INIMP} this
25549 string says simply `\.{(INIMP)}'; for other versions of \MP\ it says,
25550 for example, `\.{(mem=plain 1990.4.14)}', showing the year,
25551 month, and day that the mem file was created. We have |mem_ident=0|
25552 before \MP's tables are loaded.
25558 mp->mem_ident=NULL;
25560 @ @<Initialize table entries...@>=
25561 mp->mem_ident=xstrdup(" (INIMP)");
25563 @ @<Declare act...@>=
25564 void mp_store_mem_file (MP mp) ;
25566 @ @c void mp_store_mem_file (MP mp) {
25567 integer k; /* all-purpose index */
25568 pointer p,q; /* all-purpose pointers */
25569 integer x; /* something to dump */
25570 four_quarters w; /* four ASCII codes */
25572 @<Create the |mem_ident|, open the mem file,
25573 and inform the user that dumping has begun@>;
25574 @<Dump constants for consistency check@>;
25575 @<Dump the string pool@>;
25576 @<Dump the dynamic memory@>;
25577 @<Dump the table of equivalents and the hash table@>;
25578 @<Dump a few more things and the closing check word@>;
25579 @<Close the mem file@>;
25582 @ Corresponding to the procedure that dumps a mem file, we also have a function
25583 that reads~one~in. The function returns |false| if the dumped mem is
25584 incompatible with the present \MP\ table sizes, etc.
25586 @d off_base 6666 /* go here if the mem file is unacceptable */
25587 @d too_small(A) { wake_up_terminal;
25588 wterm_ln("---! Must increase the "); wterm((A));
25589 @.Must increase the x@>
25594 boolean mp_load_mem_file (MP mp) {
25595 integer k; /* all-purpose index */
25596 pointer p,q; /* all-purpose pointers */
25597 integer x; /* something undumped */
25598 str_number s; /* some temporary string */
25599 four_quarters w; /* four ASCII codes */
25601 @<Undump constants for consistency check@>;
25602 @<Undump the string pool@>;
25603 @<Undump the dynamic memory@>;
25604 @<Undump the table of equivalents and the hash table@>;
25605 @<Undump a few more things and the closing check word@>;
25606 return true; /* it worked! */
25609 wterm_ln("(Fatal mem file error; I'm stymied)\n");
25610 @.Fatal mem file error@>
25614 @ @<Declarations@>=
25615 boolean mp_load_mem_file (MP mp) ;
25617 @ Mem files consist of |memory_word| items, and we use the following
25618 macros to dump words of different types:
25620 @d dump_wd(A) { WW=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
25621 @d dump_int(A) { int cint=(A); (mp->write_binary_file)(mp,mp->mem_file,&cint,sizeof(cint)); }
25622 @d dump_hh(A) { WW.hh=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
25623 @d dump_qqqq(A) { WW.qqqq=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
25624 @d dump_string(A) { dump_int(strlen(A)+1);
25625 (mp->write_binary_file)(mp,mp->mem_file,A,strlen(A)+1); }
25628 void * mem_file; /* for input or output of mem information */
25630 @ The inverse macros are slightly more complicated, since we need to check
25631 the range of the values we are reading in. We say `|undump(a)(b)(x)|' to
25632 read an integer value |x| that is supposed to be in the range |a<=x<=b|.
25635 size_t wanted = sizeof(A);
25637 (mp->read_binary_file)(mp, mp->mem_file,&A_ptr,&wanted);
25638 if (wanted!=sizeof(A)) goto OFF_BASE;
25642 size_t wanted = sizeof(A);
25644 (mp->read_binary_file)(mp, mp->mem_file,&A_ptr,&wanted);
25645 if (wanted!=sizeof(A)) goto OFF_BASE;
25648 @d undump_wd(A) { mgetw(WW); A=WW; }
25649 @d undump_int(A) { int cint; mgeti(cint); A=cint; }
25650 @d undump_hh(A) { mgetw(WW); A=WW.hh; }
25651 @d undump_qqqq(A) { mgetw(WW); A=WW.qqqq; }
25652 @d undump_strings(A,B,C) {
25653 undump_int(x); if ( (x<(A)) || (x>(B)) ) goto OFF_BASE; else C=str(x); }
25654 @d undump(A,B,C) { undump_int(x); if ( (x<(A)) || (x>(int)(B)) ) goto OFF_BASE; else C=x; }
25655 @d undump_size(A,B,C,D) { undump_int(x);
25656 if (x<(A)) goto OFF_BASE;
25657 if (x>(B)) { too_small((C)); } else { D=x;} }
25658 @d undump_string(A) do {
25664 the_string = xmalloc(XX,sizeof(char));
25665 (mp->read_binary_file)(mp,mp->mem_file,&the_string,&the_wanted);
25666 A = (char *)the_string;
25667 if (the_wanted!=(size_t)XX) goto OFF_BASE;
25670 @ The next few sections of the program should make it clear how we use the
25671 dump/undump macros.
25673 @<Dump constants for consistency check@>=
25674 dump_int(mp->mem_top);
25675 dump_int(mp->hash_size);
25676 dump_int(mp->hash_prime)
25677 dump_int(mp->param_size);
25678 dump_int(mp->max_in_open);
25680 @ Sections of a \.{WEB} program that are ``commented out'' still contribute
25681 strings to the string pool; therefore \.{INIMP} and \MP\ will have
25682 the same strings. (And it is, of course, a good thing that they do.)
25686 @<Undump constants for consistency check@>=
25687 undump_int(x); mp->mem_top = x;
25688 undump_int(x); if (mp->hash_size != x) goto OFF_BASE;
25689 undump_int(x); if (mp->hash_prime != x) goto OFF_BASE;
25690 undump_int(x); if (mp->param_size != x) goto OFF_BASE;
25691 undump_int(x); if (mp->max_in_open != x) goto OFF_BASE
25693 @ We do string pool compaction to avoid dumping unused strings.
25696 w.b0=qi(mp->str_pool[k]); w.b1=qi(mp->str_pool[k+1]);
25697 w.b2=qi(mp->str_pool[k+2]); w.b3=qi(mp->str_pool[k+3]);
25700 @<Dump the string pool@>=
25701 mp_do_compaction(mp, mp->pool_size);
25702 dump_int(mp->pool_ptr);
25703 dump_int(mp->max_str_ptr);
25704 dump_int(mp->str_ptr);
25706 while ( (mp->next_str[k]==k+1) && (k<=mp->max_str_ptr) )
25709 while ( k<=mp->max_str_ptr ) {
25710 dump_int(mp->next_str[k]); incr(k);
25714 dump_int(mp->str_start[k]); /* TODO: valgrind warning here */
25715 if ( k==mp->str_ptr ) {
25722 while (k+4<mp->pool_ptr ) {
25723 dump_four_ASCII; k=k+4;
25725 k=mp->pool_ptr-4; dump_four_ASCII;
25726 mp_print_ln(mp); mp_print(mp, "at most "); mp_print_int(mp, mp->max_str_ptr);
25727 mp_print(mp, " strings of total length ");
25728 mp_print_int(mp, mp->pool_ptr)
25730 @ @d undump_four_ASCII
25732 mp->str_pool[k]=qo(w.b0); mp->str_pool[k+1]=qo(w.b1);
25733 mp->str_pool[k+2]=qo(w.b2); mp->str_pool[k+3]=qo(w.b3)
25735 @<Undump the string pool@>=
25736 undump_int(mp->pool_ptr);
25737 mp_reallocate_pool(mp, mp->pool_ptr) ;
25738 undump_int(mp->max_str_ptr);
25739 mp_reallocate_strings (mp,mp->max_str_ptr) ;
25740 undump(0,mp->max_str_ptr,mp->str_ptr);
25741 undump(0,mp->max_str_ptr+1,s);
25742 for (k=0;k<=s-1;k++)
25743 mp->next_str[k]=k+1;
25744 for (k=s;k<=mp->max_str_ptr;k++)
25745 undump(s+1,mp->max_str_ptr+1,mp->next_str[k]);
25746 mp->fixed_str_use=0;
25749 undump(0,mp->pool_ptr,mp->str_start[k]);
25750 if ( k==mp->str_ptr ) break;
25751 mp->str_ref[k]=max_str_ref;
25752 incr(mp->fixed_str_use);
25753 mp->last_fixed_str=k; k=mp->next_str[k];
25756 while ( k+4<mp->pool_ptr ) {
25757 undump_four_ASCII; k=k+4;
25759 k=mp->pool_ptr-4; undump_four_ASCII;
25760 mp->init_str_use=mp->fixed_str_use; mp->init_pool_ptr=mp->pool_ptr;
25761 mp->max_pool_ptr=mp->pool_ptr;
25762 mp->strs_used_up=mp->fixed_str_use;
25763 mp->pool_in_use=mp->str_start[mp->str_ptr]; mp->strs_in_use=mp->fixed_str_use;
25764 mp->max_pl_used=mp->pool_in_use; mp->max_strs_used=mp->strs_in_use;
25765 mp->pact_count=0; mp->pact_chars=0; mp->pact_strs=0;
25767 @ By sorting the list of available spaces in the variable-size portion of
25768 |mem|, we are usually able to get by without having to dump very much
25769 of the dynamic memory.
25771 We recompute |var_used| and |dyn_used|, so that \.{INIMP} dumps valid
25772 information even when it has not been gathering statistics.
25774 @<Dump the dynamic memory@>=
25775 mp_sort_avail(mp); mp->var_used=0;
25776 dump_int(mp->lo_mem_max); dump_int(mp->rover);
25777 p=0; q=mp->rover; x=0;
25779 for (k=p;k<= q+1;k++)
25780 dump_wd(mp->mem[k]);
25781 x=x+q+2-p; mp->var_used=mp->var_used+q-p;
25782 p=q+node_size(q); q=rlink(q);
25783 } while (q!=mp->rover);
25784 mp->var_used=mp->var_used+mp->lo_mem_max-p;
25785 mp->dyn_used=mp->mem_end+1-mp->hi_mem_min;
25786 for (k=p;k<= mp->lo_mem_max;k++ )
25787 dump_wd(mp->mem[k]);
25788 x=x+mp->lo_mem_max+1-p;
25789 dump_int(mp->hi_mem_min); dump_int(mp->avail);
25790 for (k=mp->hi_mem_min;k<=mp->mem_end;k++ )
25791 dump_wd(mp->mem[k]);
25792 x=x+mp->mem_end+1-mp->hi_mem_min;
25794 while ( p!=null ) {
25795 decr(mp->dyn_used); p=link(p);
25797 dump_int(mp->var_used); dump_int(mp->dyn_used);
25798 mp_print_ln(mp); mp_print_int(mp, x);
25799 mp_print(mp, " memory locations dumped; current usage is ");
25800 mp_print_int(mp, mp->var_used); mp_print_char(mp, '&'); mp_print_int(mp, mp->dyn_used)
25802 @ @<Undump the dynamic memory@>=
25803 undump(lo_mem_stat_max+1000,hi_mem_stat_min-1,mp->lo_mem_max);
25804 undump(lo_mem_stat_max+1,mp->lo_mem_max,mp->rover);
25807 for (k=p;k<= q+1; k++)
25808 undump_wd(mp->mem[k]);
25810 if ( (p>mp->lo_mem_max)||((q>=rlink(q))&&(rlink(q)!=mp->rover)) )
25813 } while (q!=mp->rover);
25814 for (k=p;k<=mp->lo_mem_max;k++ )
25815 undump_wd(mp->mem[k]);
25816 undump(mp->lo_mem_max+1,hi_mem_stat_min,mp->hi_mem_min);
25817 undump(null,mp->mem_top,mp->avail); mp->mem_end=mp->mem_top;
25818 mp->last_pending=spec_head;
25819 for (k=mp->hi_mem_min;k<= mp->mem_end;k++)
25820 undump_wd(mp->mem[k]);
25821 undump_int(mp->var_used); undump_int(mp->dyn_used)
25823 @ A different scheme is used to compress the hash table, since its lower region
25824 is usually sparse. When |text(p)<>0| for |p<=hash_used|, we output three
25825 words: |p|, |hash[p]|, and |eqtb[p]|. The hash table is, of course, densely
25826 packed for |p>=hash_used|, so the remaining entries are output in~a~block.
25828 @<Dump the table of equivalents and the hash table@>=
25829 dump_int(mp->hash_used);
25830 mp->st_count=frozen_inaccessible-1-mp->hash_used;
25831 for (p=1;p<=mp->hash_used;p++) {
25832 if ( text(p)!=0 ) {
25833 dump_int(p); dump_hh(mp->hash[p]); dump_hh(mp->eqtb[p]); incr(mp->st_count);
25836 for (p=mp->hash_used+1;p<=(int)hash_end;p++) {
25837 dump_hh(mp->hash[p]); dump_hh(mp->eqtb[p]);
25839 dump_int(mp->st_count);
25840 mp_print_ln(mp); mp_print_int(mp, mp->st_count); mp_print(mp, " symbolic tokens")
25842 @ @<Undump the table of equivalents and the hash table@>=
25843 undump(1,frozen_inaccessible,mp->hash_used);
25846 undump(p+1,mp->hash_used,p);
25847 undump_hh(mp->hash[p]); undump_hh(mp->eqtb[p]);
25848 } while (p!=mp->hash_used);
25849 for (p=mp->hash_used+1;p<=(int)hash_end;p++ ) {
25850 undump_hh(mp->hash[p]); undump_hh(mp->eqtb[p]);
25852 undump_int(mp->st_count)
25854 @ We have already printed a lot of statistics, so we set |mp_tracing_stats:=0|
25855 to prevent them appearing again.
25857 @<Dump a few more things and the closing check word@>=
25858 dump_int(mp->max_internal);
25859 dump_int(mp->int_ptr);
25860 for (k=1;k<= mp->int_ptr;k++ ) {
25861 dump_int(mp->internal[k]);
25862 dump_string(mp->int_name[k]);
25864 dump_int(mp->start_sym);
25865 dump_int(mp->interaction);
25866 dump_string(mp->mem_ident);
25867 dump_int(mp->bg_loc); dump_int(mp->eg_loc); dump_int(mp->serial_no); dump_int(69073);
25868 mp->internal[mp_tracing_stats]=0
25870 @ @<Undump a few more things and the closing check word@>=
25872 if (x>mp->max_internal) mp_grow_internals(mp,x);
25873 undump_int(mp->int_ptr);
25874 for (k=1;k<= mp->int_ptr;k++) {
25875 undump_int(mp->internal[k]);
25876 undump_string(mp->int_name[k]);
25878 undump(0,frozen_inaccessible,mp->start_sym);
25879 if (mp->interaction==mp_unspecified_mode) {
25880 undump(mp_unspecified_mode,mp_error_stop_mode,mp->interaction);
25882 undump(mp_unspecified_mode,mp_error_stop_mode,x);
25884 undump_string(mp->mem_ident);
25885 undump(1,hash_end,mp->bg_loc);
25886 undump(1,hash_end,mp->eg_loc);
25887 undump_int(mp->serial_no);
25889 if (x!=69073) goto OFF_BASE
25891 @ @<Create the |mem_ident|...@>=
25893 xfree(mp->mem_ident);
25894 mp->mem_ident = xmalloc(256,1);
25895 mp_snprintf(mp->mem_ident,256," (mem=%s %i.%i.%i)",
25897 (int)(mp_round_unscaled(mp, mp->internal[mp_year]) % 100),
25898 (int)mp_round_unscaled(mp, mp->internal[mp_month]),
25899 (int)mp_round_unscaled(mp, mp->internal[mp_day]));
25900 mp_pack_job_name(mp, mem_extension);
25901 while (! mp_w_open_out(mp, &mp->mem_file) )
25902 mp_prompt_file_name(mp, "mem file name", mem_extension);
25903 mp_print_nl(mp, "Beginning to dump on file ");
25904 @.Beginning to dump...@>
25905 mp_print(mp, mp->name_of_file);
25906 mp_print_nl(mp, mp->mem_ident);
25909 @ @<Dealloc variables@>=
25910 xfree(mp->mem_ident);
25912 @ @<Close the mem file@>=
25913 (mp->close_file)(mp,mp->mem_file)
25915 @* \[46] The main program.
25916 This is it: the part of \MP\ that executes all those procedures we have
25919 Well---almost. We haven't put the parsing subroutines into the
25920 program yet; and we'd better leave space for a few more routines that may
25921 have been forgotten.
25923 @c @<Declare the basic parsing subroutines@>
25924 @<Declare miscellaneous procedures that were declared |forward|@>
25925 @<Last-minute procedures@>
25927 @ We've noted that there are two versions of \MP. One, called \.{INIMP},
25929 has to be run first; it initializes everything from scratch, without
25930 reading a mem file, and it has the capability of dumping a mem file.
25931 The other one is called `\.{VIRMP}'; it is a ``virgin'' program that needs
25933 to input a mem file in order to get started. \.{VIRMP} typically has
25934 a bit more memory capacity than \.{INIMP}, because it does not need the
25935 space consumed by the dumping/undumping routines and the numerous calls on
25938 The \.{VIRMP} program cannot read a mem file instantaneously, of course;
25939 the best implementations therefore allow for production versions of \MP\ that
25940 not only avoid the loading routine for object code, they also have
25941 a mem file pre-loaded.
25943 @ @<Option variables@>=
25944 int ini_version; /* are we iniMP? */
25946 @ @<Set |ini_version|@>=
25947 mp->ini_version = (opt->ini_version ? true : false);
25949 @ Here we do whatever is needed to complete \MP's job gracefully on the
25950 local operating system. The code here might come into play after a fatal
25951 error; it must therefore consist entirely of ``safe'' operations that
25952 cannot produce error messages. For example, it would be a mistake to call
25953 |str_room| or |make_string| at this time, because a call on |overflow|
25954 might lead to an infinite loop.
25955 @^system dependencies@>
25957 This program doesn't bother to close the input files that may still be open.
25959 @<Last-minute...@>=
25960 void mp_close_files_and_terminate (MP mp) {
25961 integer k; /* all-purpose index */
25962 integer LH; /* the length of the \.{TFM} header, in words */
25963 int lk_offset; /* extra words inserted at beginning of |lig_kern| array */
25964 pointer p; /* runs through a list of \.{TFM} dimensions */
25965 @<Close all open files in the |rd_file| and |wr_file| arrays@>;
25966 if ( mp->internal[mp_tracing_stats]>0 )
25967 @<Output statistics about this job@>;
25969 @<Do all the finishing work on the \.{TFM} file@>;
25970 @<Explain what output files were written@>;
25971 if ( mp->log_opened ){
25973 (mp->close_file)(mp,mp->log_file);
25974 mp->selector=mp->selector-2;
25975 if ( mp->selector==term_only ) {
25976 mp_print_nl(mp, "Transcript written on ");
25977 @.Transcript written...@>
25978 mp_print(mp, mp->log_name); mp_print_char(mp, '.');
25986 @ @<Declarations@>=
25987 void mp_close_files_and_terminate (MP mp) ;
25989 @ @<Close all open files in the |rd_file| and |wr_file| arrays@>=
25990 if (mp->rd_fname!=NULL) {
25991 for (k=0;k<=(int)mp->read_files-1;k++ ) {
25992 if ( mp->rd_fname[k]!=NULL ) {
25993 (mp->close_file)(mp,mp->rd_file[k]);
25994 xfree(mp->rd_fname[k]);
25998 if (mp->wr_fname!=NULL) {
25999 for (k=0;k<=(int)mp->write_files-1;k++) {
26000 if ( mp->wr_fname[k]!=NULL ) {
26001 (mp->close_file)(mp,mp->wr_file[k]);
26002 xfree(mp->wr_fname[k]);
26008 for (k=0;k<(int)mp->max_read_files;k++ ) {
26009 if ( mp->rd_fname[k]!=NULL ) {
26010 (mp->close_file)(mp,mp->rd_file[k]);
26011 xfree(mp->rd_fname[k]);
26014 xfree(mp->rd_file);
26015 xfree(mp->rd_fname);
26016 for (k=0;k<(int)mp->max_write_files;k++) {
26017 if ( mp->wr_fname[k]!=NULL ) {
26018 (mp->close_file)(mp,mp->wr_file[k]);
26019 xfree(mp->wr_fname[k]);
26022 xfree(mp->wr_file);
26023 xfree(mp->wr_fname);
26026 @ We want to produce a \.{TFM} file if and only if |mp_fontmaking| is positive.
26028 We reclaim all of the variable-size memory at this point, so that
26029 there is no chance of another memory overflow after the memory capacity
26030 has already been exceeded.
26032 @<Do all the finishing work on the \.{TFM} file@>=
26033 if ( mp->internal[mp_fontmaking]>0 ) {
26034 @<Make the dynamic memory into one big available node@>;
26035 @<Massage the \.{TFM} widths@>;
26036 mp_fix_design_size(mp); mp_fix_check_sum(mp);
26037 @<Massage the \.{TFM} heights, depths, and italic corrections@>;
26038 mp->internal[mp_fontmaking]=0; /* avoid loop in case of fatal error */
26039 @<Finish the \.{TFM} file@>;
26042 @ @<Make the dynamic memory into one big available node@>=
26043 mp->rover=lo_mem_stat_max+1; link(mp->rover)=empty_flag; mp->lo_mem_max=mp->hi_mem_min-1;
26044 if ( mp->lo_mem_max-mp->rover>max_halfword ) mp->lo_mem_max=max_halfword+mp->rover;
26045 node_size(mp->rover)=mp->lo_mem_max-mp->rover;
26046 llink(mp->rover)=mp->rover; rlink(mp->rover)=mp->rover;
26047 link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null
26049 @ The present section goes directly to the log file instead of using
26050 |print| commands, because there's no need for these strings to take
26051 up |str_pool| memory when a non-{\bf stat} version of \MP\ is being used.
26053 @<Output statistics...@>=
26054 if ( mp->log_opened ) {
26057 wlog_ln("Here is how much of MetaPost's memory you used:");
26058 @.Here is how much...@>
26059 mp_snprintf(s,128," %i string%s out of %i",(int)mp->max_strs_used-mp->init_str_use,
26060 (mp->max_strs_used!=mp->init_str_use+1 ? "s" : ""),
26061 (int)(mp->max_strings-1-mp->init_str_use));
26063 mp_snprintf(s,128," %i string characters out of %i",
26064 (int)mp->max_pl_used-mp->init_pool_ptr,
26065 (int)mp->pool_size-mp->init_pool_ptr);
26067 mp_snprintf(s,128," %i words of memory out of %i",
26068 (int)mp->lo_mem_max+mp->mem_end-mp->hi_mem_min+2,
26071 mp_snprintf(s,128," %i symbolic tokens out of %i", (int)mp->st_count, (int)mp->hash_size);
26073 mp_snprintf(s,128," %ii,%in,%ip,%ib stack positions out of %ii,%in,%ip,%ib",
26074 (int)mp->max_in_stack,(int)mp->int_ptr,
26075 (int)mp->max_param_stack,(int)mp->max_buf_stack+1,
26076 (int)mp->stack_size,(int)mp->max_internal,(int)mp->param_size,(int)mp->buf_size);
26078 mp_snprintf(s,128," %i string compactions (moved %i characters, %i strings)",
26079 (int)mp->pact_count,(int)mp->pact_chars,(int)mp->pact_strs);
26083 @ It is nice to have have some of the stats available from the API.
26085 @<Exported function ...@>=
26086 int mp_memory_usage (MP mp );
26087 int mp_hash_usage (MP mp );
26088 int mp_param_usage (MP mp );
26089 int mp_open_usage (MP mp );
26092 int mp_memory_usage (MP mp ) {
26093 return (int)mp->lo_mem_max+mp->mem_end-mp->hi_mem_min+2;
26095 int mp_hash_usage (MP mp ) {
26096 return (int)mp->st_count;
26098 int mp_param_usage (MP mp ) {
26099 return (int)mp->max_param_stack;
26101 int mp_open_usage (MP mp ) {
26102 return (int)mp->max_in_stack;
26105 @ We get to the |final_cleanup| routine when \&{end} or \&{dump} has
26108 @<Last-minute...@>=
26109 void mp_final_cleanup (MP mp) {
26110 small_number c; /* 0 for \&{end}, 1 for \&{dump} */
26112 if ( mp->job_name==NULL ) mp_open_log_file(mp);
26113 while ( mp->input_ptr>0 ) {
26114 if ( token_state ) mp_end_token_list(mp);
26115 else mp_end_file_reading(mp);
26117 while ( mp->loop_ptr!=null ) mp_stop_iteration(mp);
26118 while ( mp->open_parens>0 ) {
26119 mp_print(mp, " )"); decr(mp->open_parens);
26121 while ( mp->cond_ptr!=null ) {
26122 mp_print_nl(mp, "(end occurred when ");
26123 @.end occurred...@>
26124 mp_print_cmd_mod(mp, fi_or_else,mp->cur_if);
26125 /* `\.{if}' or `\.{elseif}' or `\.{else}' */
26126 if ( mp->if_line!=0 ) {
26127 mp_print(mp, " on line "); mp_print_int(mp, mp->if_line);
26129 mp_print(mp, " was incomplete)");
26130 mp->if_line=if_line_field(mp->cond_ptr);
26131 mp->cur_if=name_type(mp->cond_ptr); mp->cond_ptr=link(mp->cond_ptr);
26133 if ( mp->history!=mp_spotless )
26134 if ( ((mp->history==mp_warning_issued)||(mp->interaction<mp_error_stop_mode)) )
26135 if ( mp->selector==term_and_log ) {
26136 mp->selector=term_only;
26137 mp_print_nl(mp, "(see the transcript file for additional information)");
26138 @.see the transcript file...@>
26139 mp->selector=term_and_log;
26142 if (mp->ini_version) {
26143 mp_store_mem_file(mp); return;
26145 mp_print_nl(mp, "(dump is performed only by INIMP)"); return;
26146 @.dump...only by INIMP@>
26150 @ @<Declarations@>=
26151 void mp_final_cleanup (MP mp) ;
26152 void mp_init_prim (MP mp) ;
26153 void mp_init_tab (MP mp) ;
26155 @ @<Last-minute...@>=
26156 void mp_init_prim (MP mp) { /* initialize all the primitives */
26160 void mp_init_tab (MP mp) { /* initialize other tables */
26161 integer k; /* all-purpose index */
26162 @<Initialize table entries (done by \.{INIMP} only)@>;
26166 @ When we begin the following code, \MP's tables may still contain garbage;
26167 the strings might not even be present. Thus we must proceed cautiously to get
26170 But when we finish this part of the program, \MP\ is ready to call on the
26171 |main_control| routine to do its work.
26173 @<Get the first line...@>=
26175 @<Initialize the input routines@>;
26176 if ( (mp->mem_ident==NULL)||(mp->buffer[loc]=='&') ) {
26177 if ( mp->mem_ident!=NULL ) {
26178 mp_do_initialize(mp); /* erase preloaded mem */
26180 if ( ! mp_open_mem_file(mp) ) return mp_fatal_error_stop;
26181 if ( ! mp_load_mem_file(mp) ) {
26182 (mp->close_file)(mp, mp->mem_file);
26183 return mp_fatal_error_stop;
26185 (mp->close_file)(mp, mp->mem_file);
26186 while ( (loc<limit)&&(mp->buffer[loc]==' ') ) incr(loc);
26188 mp->buffer[limit]='%';
26189 mp_fix_date_and_time(mp);
26190 if (mp->random_seed==0)
26191 mp->random_seed = (mp->internal[mp_time] / unity)+mp->internal[mp_day];
26192 mp_init_randoms(mp, mp->random_seed);
26193 @<Initialize the print |selector|...@>;
26194 if ( loc<limit ) if ( mp->buffer[loc]!='\\' )
26195 mp_start_input(mp); /* \&{input} assumed */
26198 @ @<Run inimpost commands@>=
26200 mp_get_strings_started(mp);
26201 mp_init_tab(mp); /* initialize the tables */
26202 mp_init_prim(mp); /* call |primitive| for each primitive */
26203 mp->init_str_use=mp->str_ptr; mp->init_pool_ptr=mp->pool_ptr;
26204 mp->max_str_ptr=mp->str_ptr; mp->max_pool_ptr=mp->pool_ptr;
26205 mp_fix_date_and_time(mp);
26209 @* \[47] Debugging.
26210 Once \MP\ is working, you should be able to diagnose most errors with
26211 the \.{show} commands and other diagnostic features. But for the initial
26212 stages of debugging, and for the revelation of really deep mysteries, you
26213 can compile \MP\ with a few more aids. An additional routine called |debug_help|
26214 will also come into play when you type `\.D' after an error message;
26215 |debug_help| also occurs just before a fatal error causes \MP\ to succumb.
26217 @^system dependencies@>
26219 The interface to |debug_help| is primitive, but it is good enough when used
26220 with a debugger that allows you to set breakpoints and to read
26221 variables and change their values. After getting the prompt `\.{debug \#}', you
26222 type either a negative number (this exits |debug_help|), or zero (this
26223 goes to a location where you can set a breakpoint, thereby entering into
26224 dialog with the debugger), or a positive number |m| followed by
26225 an argument |n|. The meaning of |m| and |n| will be clear from the
26226 program below. (If |m=13|, there is an additional argument, |l|.)
26229 @<Last-minute...@>=
26230 void mp_debug_help (MP mp) { /* routine to display various things */
26237 mp_print_nl(mp, "debug # (-1 to exit):"); update_terminal;
26240 aline = (mp->read_ascii_file)(mp,mp->term_in, &len);
26241 if (len) { sscanf(aline,"%i",&m); xfree(aline); }
26245 aline = (mp->read_ascii_file)(mp,mp->term_in, &len);
26246 if (len) { sscanf(aline,"%i",&n); xfree(aline); }
26248 @<Numbered cases for |debug_help|@>;
26249 default: mp_print(mp, "?"); break;
26254 @ @<Numbered cases...@>=
26255 case 1: mp_print_word(mp, mp->mem[n]); /* display |mem[n]| in all forms */
26257 case 2: mp_print_int(mp, info(n));
26259 case 3: mp_print_int(mp, link(n));
26261 case 4: mp_print_int(mp, eq_type(n)); mp_print_char(mp, ':'); mp_print_int(mp, equiv(n));
26263 case 5: mp_print_variable_name(mp, n);
26265 case 6: mp_print_int(mp, mp->internal[n]);
26267 case 7: mp_do_show_dependencies(mp);
26269 case 9: mp_show_token_list(mp, n,null,100000,0);
26271 case 10: mp_print_str(mp, n);
26273 case 11: mp_check_mem(mp, n>0); /* check wellformedness; print new busy locations if |n>0| */
26275 case 12: mp_search_mem(mp, n); /* look for pointers to |n| */
26279 aline = (mp->read_ascii_file)(mp,mp->term_in, &len);
26280 if (len) { sscanf(aline,"%i",&l); xfree(aline); }
26281 mp_print_cmd_mod(mp, n,l);
26283 case 14: for (k=0;k<=n;k++) mp_print_str(mp, mp->buffer[k]);
26285 case 15: mp->panicking=! mp->panicking;
26289 @ Saving the filename template
26291 @<Save the filename template@>=
26293 if ( mp->filename_template!=0 ) delete_str_ref(mp->filename_template);
26294 if ( length(mp->cur_exp)==0 ) mp->filename_template=0;
26296 mp->filename_template=mp->cur_exp; add_str_ref(mp->filename_template);
26300 @* \[48] System-dependent changes.
26301 This section should be replaced, if necessary, by any special
26302 modification of the program
26303 that are necessary to make \MP\ work at a particular installation.
26304 It is usually best to design your change file so that all changes to
26305 previous sections preserve the section numbering; then everybody's version
26306 will be consistent with the published program. More extensive changes,
26307 which introduce new sections, can be inserted here; then only the index
26308 itself will get a new section number.
26309 @^system dependencies@>
26312 Here is where you can find all uses of each identifier in the program,
26313 with underlined entries pointing to where the identifier was defined.
26314 If the identifier is only one letter long, however, you get to see only
26315 the underlined entries. {\sl All references are to section numbers instead of
26318 This index also lists error messages and other aspects of the program
26319 that you might want to look up some day. For example, the entry
26320 for ``system dependencies'' lists all sections that should receive
26321 special attention from people who are installing \MP\ in a new
26322 operating environment. A list of various things that can't happen appears
26323 under ``this can't happen''.
26324 Approximately 25 sections are listed under ``inner loop''; these account
26325 for more than 60\pct! of \MP's running time, exclusive of input and output.