3 % Copyright 2008 Taco Hoekwater.
5 % This program is free software: you can redistribute it and/or modify
6 % it under the terms of the GNU General Public License as published by
7 % the Free Software Foundation, either version 2 of the License, or
8 % (at your option) any later version.
10 % This program is distributed in the hope that it will be useful,
11 % but WITHOUT ANY WARRANTY; without even the implied warranty of
12 % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 % GNU General Public License for more details.
15 % You should have received a copy of the GNU General Public License
16 % along with this program. If not, see <http://www.gnu.org/licenses/>.
18 % TeX is a trademark of the American Mathematical Society.
19 % METAFONT is a trademark of Addison-Wesley Publishing Company.
20 % PostScript is a trademark of Adobe Systems Incorporated.
22 % Here is TeX material that gets inserted after \input webmac
23 \def\hang{\hangindent 3em\noindent\ignorespaces}
24 \def\textindent#1{\hangindent2.5em\noindent\hbox to2.5em{\hss#1 }\ignorespaces}
26 \def\psqrt#1{\sqrt{\mathstrut#1}}
28 \def\pct!{{\char`\%}} % percent sign in ordinary text
29 \font\tenlogo=logo10 % font used for the METAFONT logo
31 \def\MF{{\tenlogo META}\-{\tenlogo FONT}}
32 \def\MP{{\tenlogo META}\-{\tenlogo POST}}
33 \def\[#1]{\ignorespaces} % left over from pascal web
34 \def\<#1>{$\langle#1\rangle$}
35 \def\section{\mathhexbox278}
36 \let\swap=\leftrightarrow
37 \def\round{\mathop{\rm round}\nolimits}
38 \mathchardef\vb="026A % synonym for `\|'
40 \def\(#1){} % this is used to make section names sort themselves better
41 \def\9#1{} % this is used for sort keys in the index via @@:sort key}{entry@@>
48 This is \MP\ by John Hobby, a graphics-language processor based on D. E. Knuth's \MF.
50 Much of the original Pascal version of this program was copied with
51 permission from MF.web Version 1.9. It interprets a language very
52 similar to D.E. Knuth's METAFONT, but with changes designed to make it
53 more suitable for PostScript output.
55 The main purpose of the following program is to explain the algorithms of \MP\
56 as clearly as possible. However, the program has been written so that it
57 can be tuned to run efficiently in a wide variety of operating environments
58 by making comparatively few changes. Such flexibility is possible because
59 the documentation that follows is written in the \.{WEB} language, which is
60 at a higher level than C.
62 A large piece of software like \MP\ has inherent complexity that cannot
63 be reduced below a certain level of difficulty, although each individual
64 part is fairly simple by itself. The \.{WEB} language is intended to make
65 the algorithms as readable as possible, by reflecting the way the
66 individual program pieces fit together and by providing the
67 cross-references that connect different parts. Detailed comments about
68 what is going on, and about why things were done in certain ways, have
69 been liberally sprinkled throughout the program. These comments explain
70 features of the implementation, but they rarely attempt to explain the
71 \MP\ language itself, since the reader is supposed to be familiar with
72 {\sl The {\logos METAFONT\/}book} as well as the manual
74 @:METAFONTbook}{\sl The {\logos METAFONT\/}book}@>
75 {\sl A User's Manual for MetaPost}, Computing Science Technical Report 162,
76 AT\AM T Bell Laboratories.
78 @ The present implementation is a preliminary version, but the possibilities
79 for new features are limited by the desire to remain as nearly compatible
80 with \MF\ as possible.
82 On the other hand, the \.{WEB} description can be extended without changing
83 the core of the program, and it has been designed so that such
84 extensions are not extremely difficult to make.
85 The |banner| string defined here should be changed whenever \MP\
86 undergoes any modifications, so that it will be clear which version of
87 \MP\ might be the guilty party when a problem arises.
89 @^system dependencies@>
91 @d default_banner "This is MetaPost, Version 1.080" /* printed when \MP\ starts */
92 @d metapost_version "1.080"
97 @ The external library header for \MP\ is |mplib.h|. It contains a
98 few typedefs and the header defintions for the externally used
101 The most important of the typedefs is the definition of the structure
102 |MP_options|, that acts as a small, configurable front-end to the fairly
103 large |MP_instance| structure.
106 typedef struct MP_instance * MP;
108 typedef struct MP_options {
111 @<Exported function headers@>
113 @ The internal header file is much longer: it not only lists the complete
114 |MP_instance|, but also a lot of functions that have to be available to
115 the \ps\ backend, that is defined in a separate \.{WEB} file.
117 The variables from |MP_options| are included inside the |MP_instance|
122 typedef struct psout_data_struct * psout_data;
130 @<Types in the outer block@>
131 @<Constants in the outer block@>
132 # ifndef LIBAVL_ALLOCATOR
133 # define LIBAVL_ALLOCATOR
134 struct libavl_allocator {
135 void *(*libavl_malloc) (struct libavl_allocator *, size_t libavl_size);
136 void (*libavl_free) (struct libavl_allocator *, void *libavl_block);
139 typedef struct MP_instance {
143 @<Internal library declarations@>
152 #include <unistd.h> /* for access() */
153 #include <time.h> /* for struct tm \& co */
155 #include "psout.h" /* external header */
156 #include "mpmp.h" /* internal header */
157 #include "mppsout.h" /* internal header */
160 @<Basic printing procedures@>
161 @<Error handling procedures@>
163 @ Here are the functions that set up the \MP\ instance.
166 @<Declare |mp_reallocate| functions@>
167 struct MP_options *mp_options (void);
168 MP mp_initialize (struct MP_options *opt);
171 struct MP_options *mp_options (void) {
172 struct MP_options *opt;
173 opt = malloc(sizeof(MP_options));
175 memset (opt,0,sizeof(MP_options));
177 opt->ini_version = true;
181 @ The |__attribute__| pragma is gcc-only.
183 @<Internal library ... @>=
184 #if !defined(__GNUC__) || (__GNUC__ < 2)
185 # define __attribute__(x)
186 #endif /* !defined(__GNUC__) || (__GNUC__ < 2) */
188 @ The whole instance structure is initialized with zeroes,
189 this greatly reduces the number of statements needed in
190 the |Allocate or initialize variables| block.
192 @d set_callback_option(A) do { mp->A = mp_##A;
193 if (opt->A!=NULL) mp->A = opt->A;
197 MP __attribute__ ((noinline))
198 mp_do_new (jmp_buf *buf) {
199 MP mp = malloc(sizeof(MP_instance));
202 memset(mp,0,sizeof(MP_instance));
208 static void mp_free (MP mp) {
209 int k; /* loop variable */
210 @<Dealloc variables@>
211 if (mp->noninteractive) {
212 @<Finish non-interactive use@>;
218 void __attribute__((noinline))
219 mp_do_initialize ( MP mp) {
220 @<Local variables for initialization@>
221 @<Set initial values of key variables@>
224 @ This procedure gets things started properly.
226 MP __attribute__ ((noinline))
227 mp_initialize (struct MP_options *opt) {
230 @<Setup the non-local jump buffer in |mp_new|@>;
231 mp = mp_do_new(&buf);
234 mp->userdata=opt->userdata;
235 @<Set |ini_version|@>;
236 mp->noninteractive=opt->noninteractive;
237 set_callback_option(find_file);
238 set_callback_option(open_file);
239 set_callback_option(read_ascii_file);
240 set_callback_option(read_binary_file);
241 set_callback_option(close_file);
242 set_callback_option(eof_file);
243 set_callback_option(flush_file);
244 set_callback_option(write_ascii_file);
245 set_callback_option(write_binary_file);
246 set_callback_option(shipout_backend);
247 if (opt->banner && *(opt->banner)) {
248 mp->banner = xstrdup(opt->banner);
250 mp->banner = xstrdup(default_banner);
252 if (opt->command_line && *(opt->command_line))
253 mp->command_line = xstrdup(opt->command_line);
254 if (mp->noninteractive) {
255 @<Prepare function pointers for non-interactive use@>;
257 /* open the terminal for output */
259 @<Find constant sizes@>;
260 @<Allocate or initialize variables@>
261 mp_reallocate_memory(mp,mp->mem_max);
262 mp_reallocate_paths(mp,1000);
263 mp_reallocate_fonts(mp,8);
264 mp->history=mp_fatal_error_stop; /* in case we quit during initialization */
265 @<Check the ``constant'' values...@>;
268 mp_snprintf(ss,256,"Ouch---my internal constants have been clobbered!\n"
269 "---case %i",(int)mp->bad);
270 do_fprintf(mp->err_out,(char *)ss);
274 mp_do_initialize(mp); /* erase preloaded mem */
275 if (mp->ini_version) {
276 @<Run inimpost commands@>;
278 if (!mp->noninteractive) {
279 @<Initialize the output routines@>;
280 @<Get the first line of input and prepare to start@>;
281 @<Initializations after first line is read@>;
283 mp->history=mp_spotless;
288 @ @<Initializations after first line is read@>=
290 mp_init_map_file(mp, mp->troff_mode);
291 mp->history=mp_spotless; /* ready to go! */
292 if (mp->troff_mode) {
293 mp->internal[mp_gtroffmode]=unity;
294 mp->internal[mp_prologues]=unity;
296 if ( mp->start_sym>0 ) { /* insert the `\&{everyjob}' symbol */
297 mp->cur_sym=mp->start_sym; mp_back_input(mp);
300 @ @<Exported function headers@>=
301 extern struct MP_options *mp_options (void);
302 extern MP mp_initialize (struct MP_options *opt) ;
303 extern int mp_status(MP mp);
304 extern void *mp_userdata(MP mp);
307 int mp_status(MP mp) { return mp->history; }
310 void *mp_userdata(MP mp) { return mp->userdata; }
312 @ The overall \MP\ program begins with the heading just shown, after which
313 comes a bunch of procedure declarations and function declarations.
314 Finally we will get to the main program, which begins with the
315 comment `|start_here|'. If you want to skip down to the
316 main program now, you can look up `|start_here|' in the index.
317 But the author suggests that the best way to understand this program
318 is to follow pretty much the order of \MP's components as they appear in the
319 \.{WEB} description you are now reading, since the present ordering is
320 intended to combine the advantages of the ``bottom up'' and ``top down''
321 approaches to the problem of understanding a somewhat complicated system.
323 @ Some of the code below is intended to be used only when diagnosing the
324 strange behavior that sometimes occurs when \MP\ is being installed or
325 when system wizards are fooling around with \MP\ without quite knowing
326 what they are doing. Such code will not normally be compiled; it is
327 delimited by the preprocessor test `|#ifdef DEBUG .. #endif|'.
329 @ This program has two important variations: (1) There is a long and slow
330 version called \.{INIMP}, which does the extra calculations needed to
332 initialize \MP's internal tables; and (2)~there is a shorter and faster
333 production version, which cuts the initialization to a bare minimum.
335 Which is which is decided at runtime.
337 @ The following parameters can be changed at compile time to extend or
338 reduce \MP's capacity. They may have different values in \.{INIMP} and
339 in production versions of \MP.
341 @^system dependencies@>
344 #define file_name_size 255 /* file names shouldn't be longer than this */
345 #define bistack_size 1500 /* size of stack for bisection algorithms;
346 should probably be left at this value */
348 @ Like the preceding parameters, the following quantities can be changed
349 to extend or reduce \MP's capacity. But if they are changed,
350 it is necessary to rerun the initialization program \.{INIMP}
352 to generate new tables for the production \MP\ program.
353 One can't simply make helter-skelter changes to the following constants,
354 since certain rather complex initialization
355 numbers are computed from them.
358 int max_strings; /* maximum number of strings; must not exceed |max_halfword| */
359 int pool_size; /* maximum number of characters in strings, including all
360 error messages and help texts, and the names of all identifiers */
361 int mem_max; /* greatest index in \MP's internal |mem| array;
362 must be strictly less than |max_halfword|;
363 must be equal to |mem_top| in \.{INIMP}, otherwise |>=mem_top| */
364 int mem_top; /* largest index in the |mem| array dumped by \.{INIMP};
365 must not be greater than |mem_max| */
366 int hash_prime; /* a prime number equal to about 85\pct! of |hash_size| */
368 @ @<Option variables@>=
369 int error_line; /* width of context lines on terminal error messages */
370 int half_error_line; /* width of first lines of contexts in terminal
371 error messages; should be between 30 and |error_line-15| */
372 int max_print_line; /* width of longest text lines output; should be at least 60 */
373 int hash_size; /* maximum number of symbolic tokens,
374 must be less than |max_halfword-3*param_size| */
375 int param_size; /* maximum number of simultaneous macro parameters */
376 int max_in_open; /* maximum number of input files and error insertions that
377 can be going on simultaneously */
378 int main_memory; /* only for options, to set up |mem_max| and |mem_top| */
379 void *userdata; /* this allows the calling application to setup local */
380 char *banner; /* the banner that is printed to the screen and log */
382 @ @<Dealloc variables@>=
386 @d set_value(a,b,c) do { a=c; if (b>c) a=b; } while (0)
391 set_value(mp->error_line,opt->error_line,79);
392 set_value(mp->half_error_line,opt->half_error_line,50);
393 if (mp->half_error_line>mp->error_line-15 )
394 mp->half_error_line = mp->error_line-15;
395 set_value(mp->max_print_line,opt->max_print_line,100);
397 @ In case somebody has inadvertently made bad settings of the ``constants,''
398 \MP\ checks them using a global variable called |bad|.
400 This is the second of many sections of \MP\ where global variables are
404 integer bad; /* is some ``constant'' wrong? */
406 @ Later on we will say `\ignorespaces|if (mem_max>=max_halfword) bad=10;|',
407 or something similar. (We can't do that until |max_halfword| has been defined.)
409 In case you are wondering about the non-consequtive values of |bad|: some
410 of the things that used to be WEB constants are now runtime variables
411 with checking at assignment time.
413 @<Check the ``constant'' values for consistency@>=
415 if ( mp->mem_top<=1100 ) mp->bad=4;
417 @ Some |goto| labels are used by the following definitions. The label
418 `|restart|' is occasionally used at the very beginning of a procedure; and
419 the label `|reswitch|' is occasionally used just prior to a |case|
420 statement in which some cases change the conditions and we wish to branch
421 to the newly applicable case. Loops that are set up with the |loop|
422 construction defined below are commonly exited by going to `|done|' or to
423 `|found|' or to `|not_found|', and they are sometimes repeated by going to
424 `|continue|'. If two or more parts of a subroutine start differently but
425 end up the same, the shared code may be gathered together at
428 @ Here are some macros for common programming idioms.
430 @d incr(A) (A)=(A)+1 /* increase a variable by unity */
431 @d decr(A) (A)=(A)-1 /* decrease a variable by unity */
432 @d negate(A) (A)=-(A) /* change the sign of a variable */
433 @d double(A) (A)=(A)+(A)
435 @d do_nothing /* empty statement */
437 @* \[2] The character set.
438 In order to make \MP\ readily portable to a wide variety of
439 computers, all of its input text is converted to an internal eight-bit
440 code that includes standard ASCII, the ``American Standard Code for
441 Information Interchange.'' This conversion is done immediately when each
442 character is read in. Conversely, characters are converted from ASCII to
443 the user's external representation just before they are output to a
447 Such an internal code is relevant to users of \MP\ only with respect to
448 the \&{char} and \&{ASCII} operations, and the comparison of strings.
450 @ Characters of text that have been converted to \MP's internal form
451 are said to be of type |ASCII_code|, which is a subrange of the integers.
454 typedef unsigned char ASCII_code; /* eight-bit numbers */
456 @ The present specification of \MP\ has been written under the assumption
457 that the character set contains at least the letters and symbols associated
458 with ASCII codes 040 through 0176; all of these characters are now
459 available on most computer terminals.
462 typedef unsigned char text_char; /* the data type of characters in text files */
464 @ @<Local variables for init...@>=
467 @ The \MP\ processor converts between ASCII code and
468 the user's external character set by means of arrays |xord| and |xchr|
469 that are analogous to Pascal's |ord| and |chr| functions.
471 @d xchr(A) mp->xchr[(A)]
472 @d xord(A) mp->xord[(A)]
475 ASCII_code xord[256]; /* specifies conversion of input characters */
476 text_char xchr[256]; /* specifies conversion of output characters */
478 @ The core system assumes all 8-bit is acceptable. If it is not,
479 a change file has to alter the below section.
480 @^system dependencies@>
482 Additionally, people with extended character sets can
483 assign codes arbitrarily, giving an |xchr| equivalent to whatever
484 characters the users of \MP\ are allowed to have in their input files.
485 Appropriate changes to \MP's |char_class| table should then be made.
486 (Unlike \TeX, each installation of \MP\ has a fixed assignment of category
487 codes, called the |char_class|.) Such changes make portability of programs
488 more difficult, so they should be introduced cautiously if at all.
489 @^character set dependencies@>
490 @^system dependencies@>
493 for (i=0;i<=0377;i++) { xchr(i)=i; }
495 @ The following system-independent code makes the |xord| array contain a
496 suitable inverse to the information in |xchr|. Note that if |xchr[i]=xchr[j]|
497 where |i<j<0177|, the value of |xord[xchr[i]]| will turn out to be
498 |j| or more; hence, standard ASCII code numbers will be used instead of
499 codes below 040 in case there is a coincidence.
502 for (i=0;i<=255;i++) {
505 for (i=0200;i<=0377;i++) { xord(xchr(i))=i;}
506 for (i=0;i<=0176;i++) { xord(xchr(i))=i;}
508 @* \[3] Input and output.
509 The bane of portability is the fact that different operating systems treat
510 input and output quite differently, perhaps because computer scientists
511 have not given sufficient attention to this problem. People have felt somehow
512 that input and output are not part of ``real'' programming. Well, it is true
513 that some kinds of programming are more fun than others. With existing
514 input/output conventions being so diverse and so messy, the only sources of
515 joy in such parts of the code are the rare occasions when one can find a
516 way to make the program a little less bad than it might have been. We have
517 two choices, either to attack I/O now and get it over with, or to postpone
518 I/O until near the end. Neither prospect is very attractive, so let's
521 The basic operations we need to do are (1)~inputting and outputting of
522 text, to or from a file or the user's terminal; (2)~inputting and
523 outputting of eight-bit bytes, to or from a file; (3)~instructing the
524 operating system to initiate (``open'') or to terminate (``close'') input or
525 output from a specified file; (4)~testing whether the end of an input
526 file has been reached; (5)~display of bits on the user's screen.
527 The bit-display operation will be discussed in a later section; we shall
528 deal here only with more traditional kinds of I/O.
530 @ Finding files happens in a slightly roundabout fashion: the \MP\
531 instance object contains a field that holds a function pointer that finds a
532 file, and returns its name, or NULL. For this, it receives three
533 parameters: the non-qualified name |fname|, the intended |fopen|
534 operation type |fmode|, and the type of the file |ftype|.
536 The file types that are passed on in |ftype| can be used to
537 differentiate file searches if a library like kpathsea is used,
538 the fopen mode is passed along for the same reason.
541 typedef unsigned char eight_bits ; /* unsigned one-byte quantity */
543 @ @<Exported types@>=
545 mp_filetype_terminal = 0, /* the terminal */
546 mp_filetype_error, /* the terminal */
547 mp_filetype_program , /* \MP\ language input */
548 mp_filetype_log, /* the log file */
549 mp_filetype_postscript, /* the postscript output */
550 mp_filetype_memfile, /* memory dumps */
551 mp_filetype_metrics, /* TeX font metric files */
552 mp_filetype_fontmap, /* PostScript font mapping files */
553 mp_filetype_font, /* PostScript type1 font programs */
554 mp_filetype_encoding, /* PostScript font encoding files */
555 mp_filetype_text /* first text file for readfrom and writeto primitives */
557 typedef char *(*mp_file_finder)(MP, const char *, const char *, int);
558 typedef void *(*mp_file_opener)(MP, const char *, const char *, int);
559 typedef char *(*mp_file_reader)(MP, void *, size_t *);
560 typedef void (*mp_binfile_reader)(MP, void *, void **, size_t *);
561 typedef void (*mp_file_closer)(MP, void *);
562 typedef int (*mp_file_eoftest)(MP, void *);
563 typedef void (*mp_file_flush)(MP, void *);
564 typedef void (*mp_file_writer)(MP, void *, const char *);
565 typedef void (*mp_binfile_writer)(MP, void *, void *, size_t);
567 @ @<Option variables@>=
568 mp_file_finder find_file;
569 mp_file_opener open_file;
570 mp_file_reader read_ascii_file;
571 mp_binfile_reader read_binary_file;
572 mp_file_closer close_file;
573 mp_file_eoftest eof_file;
574 mp_file_flush flush_file;
575 mp_file_writer write_ascii_file;
576 mp_binfile_writer write_binary_file;
578 @ The default function for finding files is |mp_find_file|. It is
579 pretty stupid: it will only find files in the current directory.
581 This function may disappear altogether, it is currently only
582 used for the default font map file.
585 char *mp_find_file (MP mp, const char *fname, const char *fmode, int ftype) {
587 if (fmode[0] != 'r' || (! access (fname,R_OK)) || ftype) {
588 return strdup(fname);
593 @ Because |mp_find_file| is used so early, it has to be in the helpers
597 char *mp_find_file (MP mp, const char *fname, const char *fmode, int ftype) ;
598 void *mp_open_file (MP mp , const char *fname, const char *fmode, int ftype) ;
599 char *mp_read_ascii_file (MP mp, void *f, size_t *size) ;
600 void mp_read_binary_file (MP mp, void *f, void **d, size_t *size) ;
601 void mp_close_file (MP mp, void *f) ;
602 int mp_eof_file (MP mp, void *f) ;
603 void mp_flush_file (MP mp, void *f) ;
604 void mp_write_ascii_file (MP mp, void *f, const char *s) ;
605 void mp_write_binary_file (MP mp, void *f, void *s, size_t t) ;
607 @ The function to open files can now be very short.
610 void *mp_open_file(MP mp, const char *fname, const char *fmode, int ftype) {
613 realmode[0] = *fmode;
616 if (ftype==mp_filetype_terminal) {
617 return (fmode[0] == 'r' ? stdin : stdout);
618 } else if (ftype==mp_filetype_error) {
620 } else if (fname != NULL && (fmode[0] != 'r' || (! access (fname,R_OK)))) {
621 return (void *)fopen(fname, realmode);
626 @ This is a legacy interface: (almost) all file names pass through |name_of_file|.
629 char name_of_file[file_name_size+1]; /* the name of a system file */
630 int name_length;/* this many characters are actually
631 relevant in |name_of_file| (the rest are blank) */
633 @ @<Option variables@>=
634 int print_found_names; /* configuration parameter */
636 @ If this parameter is true, the terminal and log will report the found
637 file names for input files instead of the requested ones.
638 It is off by default because it creates an extra filename lookup.
640 @<Allocate or initialize ...@>=
641 mp->print_found_names = (opt->print_found_names>0 ? true : false);
643 @ \MP's file-opening procedures return |false| if no file identified by
644 |name_of_file| could be opened.
646 The |OPEN_FILE| macro takes care of the |print_found_names| parameter.
647 It is not used for opening a mem file for read, because that file name
651 if (mp->print_found_names) {
652 char *s = (mp->find_file)(mp,mp->name_of_file,A,ftype);
654 *f = (mp->open_file)(mp,mp->name_of_file,A, ftype);
655 strncpy(mp->name_of_file,s,file_name_size);
661 *f = (mp->open_file)(mp,mp->name_of_file,A, ftype);
664 return (*f ? true : false)
667 boolean mp_a_open_in (MP mp, void **f, int ftype) {
668 /* open a text file for input */
672 boolean mp_w_open_in (MP mp, void **f) {
673 /* open a word file for input */
674 *f = (mp->open_file)(mp,mp->name_of_file,"r",mp_filetype_memfile);
675 return (*f ? true : false);
678 boolean mp_a_open_out (MP mp, void **f, int ftype) {
679 /* open a text file for output */
683 boolean mp_b_open_out (MP mp, void **f, int ftype) {
684 /* open a binary file for output */
688 boolean mp_w_open_out (MP mp, void **f) {
689 /* open a word file for output */
690 int ftype = mp_filetype_memfile;
695 char *mp_read_ascii_file (MP mp, void *ff, size_t *size) {
697 size_t len = 0, lim = 128;
699 FILE *f = (FILE *)ff;
701 (void) mp; /* for -Wunused */
708 if (s==NULL) return NULL;
709 while (c!=EOF && c!='\n' && c!='\r') {
711 s =realloc(s, (lim+(lim>>2)));
712 if (s==NULL) return NULL;
720 if (c!=EOF && c!='\n')
729 void mp_write_ascii_file (MP mp, void *f, const char *s) {
737 void mp_read_binary_file (MP mp, void *f, void **data, size_t *size) {
741 len = fread(*data,1,*size,(FILE *)f);
746 void mp_write_binary_file (MP mp, void *f, void *s, size_t size) {
749 fwrite(s,size,1,(FILE *)f);
754 void mp_close_file (MP mp, void *f) {
761 int mp_eof_file (MP mp, void *f) {
764 return feof((FILE *)f);
770 void mp_flush_file (MP mp, void *f) {
776 @ Input from text files is read one line at a time, using a routine called
777 |input_ln|. This function is defined in terms of global variables called
778 |buffer|, |first|, and |last| that will be described in detail later; for
779 now, it suffices for us to know that |buffer| is an array of |ASCII_code|
780 values, and that |first| and |last| are indices into this array
781 representing the beginning and ending of a line of text.
784 size_t buf_size; /* maximum number of characters simultaneously present in
785 current lines of open files */
786 ASCII_code *buffer; /* lines of characters being read */
787 size_t first; /* the first unused position in |buffer| */
788 size_t last; /* end of the line just input to |buffer| */
789 size_t max_buf_stack; /* largest index used in |buffer| */
791 @ @<Allocate or initialize ...@>=
793 mp->buffer = xmalloc((mp->buf_size+1),sizeof(ASCII_code));
795 @ @<Dealloc variables@>=
799 void mp_reallocate_buffer(MP mp, size_t l) {
801 if (l>max_halfword) {
802 mp_confusion(mp,"buffer size"); /* can't happen (I hope) */
804 buffer = xmalloc((l+1),sizeof(ASCII_code));
805 memcpy(buffer,mp->buffer,(mp->buf_size+1));
807 mp->buffer = buffer ;
811 @ The |input_ln| function brings the next line of input from the specified
812 field into available positions of the buffer array and returns the value
813 |true|, unless the file has already been entirely read, in which case it
814 returns |false| and sets |last:=first|. In general, the |ASCII_code|
815 numbers that represent the next line of the file are input into
816 |buffer[first]|, |buffer[first+1]|, \dots, |buffer[last-1]|; and the
817 global variable |last| is set equal to |first| plus the length of the
818 line. Trailing blanks are removed from the line; thus, either |last=first|
819 (in which case the line was entirely blank) or |buffer[last-1]<>" "|.
822 The variable |max_buf_stack|, which is used to keep track of how large
823 the |buf_size| parameter must be to accommodate the present job, is
824 also kept up to date by |input_ln|.
827 boolean mp_input_ln (MP mp, void *f ) {
828 /* inputs the next line or returns |false| */
831 mp->last=mp->first; /* cf.\ Matthew 19\thinspace:\thinspace30 */
832 s = (mp->read_ascii_file)(mp,f, &size);
836 mp->last = mp->first+size;
837 if ( mp->last>=mp->max_buf_stack ) {
838 mp->max_buf_stack=mp->last+1;
839 while ( mp->max_buf_stack>=mp->buf_size ) {
840 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
843 memcpy((mp->buffer+mp->first),s,size);
844 /* while ( mp->buffer[mp->last]==' ' ) mp->last--; */
850 @ The user's terminal acts essentially like other files of text, except
851 that it is used both for input and for output. When the terminal is
852 considered an input file, the file variable is called |term_in|, and when it
853 is considered an output file the file variable is |term_out|.
854 @^system dependencies@>
857 void * term_in; /* the terminal as an input file */
858 void * term_out; /* the terminal as an output file */
859 void * err_out; /* the terminal as an output file */
861 @ Here is how to open the terminal files. In the default configuration,
862 nothing happens except that the command line (if there is one) is copied
863 to the input buffer. The variable |command_line| will be filled by the
864 |main| procedure. The copying can not be done earlier in the program
865 logic because in the |INI| version, the |buffer| is also used for primitive
868 @d t_open_out do {/* open the terminal for text output */
869 mp->term_out = (mp->open_file)(mp,"terminal", "w", mp_filetype_terminal);
870 mp->err_out = (mp->open_file)(mp,"error", "w", mp_filetype_error);
872 @d t_open_in do { /* open the terminal for text input */
873 mp->term_in = (mp->open_file)(mp,"terminal", "r", mp_filetype_terminal);
874 if (mp->command_line!=NULL) {
875 mp->last = strlen(mp->command_line);
876 strncpy((char *)mp->buffer,mp->command_line,mp->last);
877 xfree(mp->command_line);
883 @<Option variables@>=
886 @ Sometimes it is necessary to synchronize the input/output mixture that
887 happens on the user's terminal, and three system-dependent
888 procedures are used for this
889 purpose. The first of these, |update_terminal|, is called when we want
890 to make sure that everything we have output to the terminal so far has
891 actually left the computer's internal buffers and been sent.
892 The second, |clear_terminal|, is called when we wish to cancel any
893 input that the user may have typed ahead (since we are about to
894 issue an unexpected error message). The third, |wake_up_terminal|,
895 is supposed to revive the terminal if the user has disabled it by
896 some instruction to the operating system. The following macros show how
897 these operations can be specified:
898 @^system dependencies@>
900 @d update_terminal (mp->flush_file)(mp,mp->term_out) /* empty the terminal output buffer */
901 @d clear_terminal do_nothing /* clear the terminal input buffer */
902 @d wake_up_terminal (mp->flush_file)(mp,mp->term_out)
903 /* cancel the user's cancellation of output */
905 @ We need a special routine to read the first line of \MP\ input from
906 the user's terminal. This line is different because it is read before we
907 have opened the transcript file; there is sort of a ``chicken and
908 egg'' problem here. If the user types `\.{input cmr10}' on the first
909 line, or if some macro invoked by that line does such an \.{input},
910 the transcript file will be named `\.{cmr10.log}'; but if no \.{input}
911 commands are performed during the first line of terminal input, the transcript
912 file will acquire its default name `\.{mpout.log}'. (The transcript file
913 will not contain error messages generated by the first line before the
914 first \.{input} command.)
916 The first line is even more special. It's nice to let the user start
917 running a \MP\ job by typing a command line like `\.{MP cmr10}'; in
918 such a case, \MP\ will operate as if the first line of input were
919 `\.{cmr10}', i.e., the first line will consist of the remainder of the
920 command line, after the part that invoked \MP.
922 @ Different systems have different ways to get started. But regardless of
923 what conventions are adopted, the routine that initializes the terminal
924 should satisfy the following specifications:
926 \yskip\textindent{1)}It should open file |term_in| for input from the
927 terminal. (The file |term_out| will already be open for output to the
930 \textindent{2)}If the user has given a command line, this line should be
931 considered the first line of terminal input. Otherwise the
932 user should be prompted with `\.{**}', and the first line of input
933 should be whatever is typed in response.
935 \textindent{3)}The first line of input, which might or might not be a
936 command line, should appear in locations |first| to |last-1| of the
939 \textindent{4)}The global variable |loc| should be set so that the
940 character to be read next by \MP\ is in |buffer[loc]|. This
941 character should not be blank, and we should have |loc<last|.
943 \yskip\noindent(It may be necessary to prompt the user several times
944 before a non-blank line comes in. The prompt is `\.{**}' instead of the
945 later `\.*' because the meaning is slightly different: `\.{input}' need
946 not be typed immediately after~`\.{**}'.)
948 @d loc mp->cur_input.loc_field /* location of first unread character in |buffer| */
951 boolean mp_init_terminal (MP mp) { /* gets the terminal input started */
958 if (!mp->noninteractive) {
959 wake_up_terminal; do_fprintf(mp->term_out,"**"); update_terminal;
962 if ( ! mp_input_ln(mp, mp->term_in ) ) { /* this shouldn't happen */
963 do_fprintf(mp->term_out,"\n! End of file on the terminal... why?");
964 @.End of file on the terminal@>
968 while ( (loc<(int)mp->last)&&(mp->buffer[loc]==' ') )
970 if ( loc<(int)mp->last ) {
971 return true; /* return unless the line was all blank */
973 if (!mp->noninteractive) {
974 do_fprintf(mp->term_out,"Please type the name of your input file.\n");
980 boolean mp_init_terminal (MP mp) ;
983 @* \[4] String handling.
984 Symbolic token names and diagnostic messages are variable-length strings
985 of eight-bit characters. Many strings \MP\ uses are simply literals
986 in the compiled source, like the error messages and the names of the
987 internal parameters. Other strings are used or defined from the \MP\ input
988 language, and these have to be interned.
990 \MP\ uses strings more extensively than \MF\ does, but the necessary
991 operations can still be handled with a fairly simple data structure.
992 The array |str_pool| contains all of the (eight-bit) ASCII codes in all
993 of the strings, and the array |str_start| contains indices of the starting
994 points of each string. Strings are referred to by integer numbers, so that
995 string number |s| comprises the characters |str_pool[j]| for
996 |str_start[s]<=j<str_start[ss]| where |ss=next_str[s]|. The string pool
997 is allocated sequentially and |str_pool[pool_ptr]| is the next unused
998 location. The first string number not currently in use is |str_ptr|
999 and |next_str[str_ptr]| begins a list of free string numbers. String
1000 pool entries |str_start[str_ptr]| up to |pool_ptr| are reserved for a
1001 string currently being constructed.
1003 String numbers 0 to 255 are reserved for strings that correspond to single
1004 ASCII characters. This is in accordance with the conventions of \.{WEB},
1006 which converts single-character strings into the ASCII code number of the
1007 single character involved, while it converts other strings into integers
1008 and builds a string pool file. Thus, when the string constant \.{"."} appears
1009 in the program below, \.{WEB} converts it into the integer 46, which is the
1010 ASCII code for a period, while \.{WEB} will convert a string like \.{"hello"}
1011 into some integer greater than~255. String number 46 will presumably be the
1012 single character `\..'\thinspace; but some ASCII codes have no standard visible
1013 representation, and \MP\ may need to be able to print an arbitrary
1014 ASCII character, so the first 256 strings are used to specify exactly what
1015 should be printed for each of the 256 possibilities.
1018 typedef int pool_pointer; /* for variables that point into |str_pool| */
1019 typedef int str_number; /* for variables that point into |str_start| */
1022 ASCII_code *str_pool; /* the characters */
1023 pool_pointer *str_start; /* the starting pointers */
1024 str_number *next_str; /* for linking strings in order */
1025 pool_pointer pool_ptr; /* first unused position in |str_pool| */
1026 str_number str_ptr; /* number of the current string being created */
1027 pool_pointer init_pool_ptr; /* the starting value of |pool_ptr| */
1028 str_number init_str_use; /* the initial number of strings in use */
1029 pool_pointer max_pool_ptr; /* the maximum so far of |pool_ptr| */
1030 str_number max_str_ptr; /* the maximum so far of |str_ptr| */
1032 @ @<Allocate or initialize ...@>=
1033 mp->str_pool = xmalloc ((mp->pool_size +1),sizeof(ASCII_code));
1034 mp->str_start = xmalloc ((mp->max_strings+1),sizeof(pool_pointer));
1035 mp->next_str = xmalloc ((mp->max_strings+1),sizeof(str_number));
1037 @ @<Dealloc variables@>=
1038 xfree(mp->str_pool);
1039 xfree(mp->str_start);
1040 xfree(mp->next_str);
1042 @ Most printing is done from |char *|s, but sometimes not. Here are
1043 functions that convert an internal string into a |char *| for use
1044 by the printing routines, and vice versa.
1046 @d str(A) mp_str(mp,A)
1047 @d rts(A) mp_rts(mp,A)
1050 int mp_xstrcmp (const char *a, const char *b);
1051 char * mp_str (MP mp, str_number s);
1054 str_number mp_rts (MP mp, const char *s);
1055 str_number mp_make_string (MP mp);
1058 int mp_xstrcmp (const char *a, const char *b) {
1059 if (a==NULL && b==NULL)
1068 @ The attempt to catch interrupted strings that is in |mp_rts|, is not
1069 very good: it does not handle nesting over more than one level.
1072 char * mp_str (MP mp, str_number ss) {
1075 if (ss==mp->str_ptr) {
1079 s = xmalloc(len+1,sizeof(char));
1080 strncpy(s,(char *)(mp->str_pool+(mp->str_start[ss])),len);
1085 str_number mp_rts (MP mp, const char *s) {
1086 int r; /* the new string */
1087 int old; /* a possible string in progress */
1091 } else if (strlen(s)==1) {
1095 str_room((integer)strlen(s));
1096 if (mp->str_start[mp->str_ptr]<mp->pool_ptr)
1097 old = mp_make_string(mp);
1102 r = mp_make_string(mp);
1104 str_room(length(old));
1105 while (i<length(old)) {
1106 append_char((mp->str_start[old]+i));
1108 mp_flush_string(mp,old);
1114 @ Except for |strs_used_up|, the following string statistics are only
1115 maintained when code between |stat| $\ldots$ |tats| delimiters is not
1119 integer strs_used_up; /* strings in use or unused but not reclaimed */
1120 integer pool_in_use; /* total number of cells of |str_pool| actually in use */
1121 integer strs_in_use; /* total number of strings actually in use */
1122 integer max_pl_used; /* maximum |pool_in_use| so far */
1123 integer max_strs_used; /* maximum |strs_in_use| so far */
1125 @ Several of the elementary string operations are performed using \.{WEB}
1126 macros instead of functions, because many of the
1127 operations are done quite frequently and we want to avoid the
1128 overhead of procedure calls. For example, here is
1129 a simple macro that computes the length of a string.
1132 @d str_stop(A) mp->str_start[mp->next_str[(A)]] /* one cell past the end of string \# */
1133 @d length(A) (str_stop((A))-mp->str_start[(A)]) /* the number of characters in string \# */
1135 @ The length of the current string is called |cur_length|. If we decide that
1136 the current string is not needed, |flush_cur_string| resets |pool_ptr| so that
1137 |cur_length| becomes zero.
1139 @d cur_length (mp->pool_ptr - mp->str_start[mp->str_ptr])
1140 @d flush_cur_string mp->pool_ptr=mp->str_start[mp->str_ptr]
1142 @ Strings are created by appending character codes to |str_pool|.
1143 The |append_char| macro, defined here, does not check to see if the
1144 value of |pool_ptr| has gotten too high; this test is supposed to be
1145 made before |append_char| is used.
1147 To test if there is room to append |l| more characters to |str_pool|,
1148 we shall write |str_room(l)|, which tries to make sure there is enough room
1149 by compacting the string pool if necessary. If this does not work,
1150 |do_compaction| aborts \MP\ and gives an apologetic error message.
1152 @d append_char(A) /* put |ASCII_code| \# at the end of |str_pool| */
1153 { mp->str_pool[mp->pool_ptr]=(A); incr(mp->pool_ptr);
1155 @d str_room(A) /* make sure that the pool hasn't overflowed */
1156 { if ( mp->pool_ptr+(A) > mp->max_pool_ptr ) {
1157 if ( mp->pool_ptr+(A) > mp->pool_size ) mp_do_compaction(mp, (A));
1158 else mp->max_pool_ptr=mp->pool_ptr+(A); }
1161 @ The following routine is similar to |str_room(1)| but it uses the
1162 argument |mp->pool_size| to prevent |do_compaction| from aborting when
1163 string space is exhausted.
1165 @<Declare the procedure called |unit_str_room|@>=
1166 void mp_unit_str_room (MP mp);
1169 void mp_unit_str_room (MP mp) {
1170 if ( mp->pool_ptr>=mp->pool_size ) mp_do_compaction(mp, mp->pool_size);
1171 if ( mp->pool_ptr>=mp->max_pool_ptr ) mp->max_pool_ptr=mp->pool_ptr+1;
1174 @ \MP's string expressions are implemented in a brute-force way: Every
1175 new string or substring that is needed is simply copied into the string pool.
1176 Space is eventually reclaimed by a procedure called |do_compaction| with
1177 the aid of a simple system system of reference counts.
1178 @^reference counts@>
1180 The number of references to string number |s| will be |str_ref[s]|. The
1181 special value |str_ref[s]=max_str_ref=127| is used to denote an unknown
1182 positive number of references; such strings will never be recycled. If
1183 a string is ever referred to more than 126 times, simultaneously, we
1184 put it in this category. Hence a single byte suffices to store each |str_ref|.
1186 @d max_str_ref 127 /* ``infinite'' number of references */
1187 @d add_str_ref(A) { if ( mp->str_ref[(A)]<max_str_ref ) incr(mp->str_ref[(A)]); }
1192 @ @<Allocate or initialize ...@>=
1193 mp->str_ref = xmalloc ((mp->max_strings+1),sizeof(int));
1195 @ @<Dealloc variables@>=
1198 @ Here's what we do when a string reference disappears:
1200 @d delete_str_ref(A) {
1201 if ( mp->str_ref[(A)]<max_str_ref ) {
1202 if ( mp->str_ref[(A)]>1 ) decr(mp->str_ref[(A)]);
1203 else mp_flush_string(mp, (A));
1207 @<Declare the procedure called |flush_string|@>=
1208 void mp_flush_string (MP mp,str_number s) ;
1211 @ We can't flush the first set of static strings at all, so there
1212 is no point in trying
1215 void mp_flush_string (MP mp,str_number s) {
1217 mp->pool_in_use=mp->pool_in_use-length(s);
1218 decr(mp->strs_in_use);
1219 if ( mp->next_str[s]!=mp->str_ptr ) {
1223 decr(mp->strs_used_up);
1225 mp->pool_ptr=mp->str_start[mp->str_ptr];
1229 @ C literals cannot be simply added, they need to be set so they can't
1232 @d intern(A) mp_intern(mp,(A))
1235 str_number mp_intern (MP mp, const char *s) {
1238 mp->str_ref[r] = max_str_ref;
1243 str_number mp_intern (MP mp, const char *s);
1246 @ Once a sequence of characters has been appended to |str_pool|, it
1247 officially becomes a string when the function |make_string| is called.
1248 This function returns the identification number of the new string as its
1251 When getting the next unused string number from the linked list, we pretend
1253 $$ \hbox{|max_str_ptr+1|, |max_str_ptr+2|, $\ldots$, |mp->max_strings|} $$
1254 are linked sequentially even though the |next_str| entries have not been
1255 initialized yet. We never allow |str_ptr| to reach |mp->max_strings|;
1256 |do_compaction| is responsible for making sure of this.
1259 @<Declare the procedure called |do_compaction|@>
1260 @<Declare the procedure called |unit_str_room|@>
1261 str_number mp_make_string (MP mp);
1264 str_number mp_make_string (MP mp) { /* current string enters the pool */
1265 str_number s; /* the new string */
1268 mp->str_ptr=mp->next_str[s];
1269 if ( mp->str_ptr>mp->max_str_ptr ) {
1270 if ( mp->str_ptr==mp->max_strings ) {
1272 mp_do_compaction(mp, 0);
1275 mp->max_str_ptr=mp->str_ptr;
1276 mp->next_str[mp->str_ptr]=mp->max_str_ptr+1;
1280 mp->str_start[mp->str_ptr]=mp->pool_ptr;
1281 incr(mp->strs_used_up);
1282 incr(mp->strs_in_use);
1283 mp->pool_in_use=mp->pool_in_use+length(s);
1284 if ( mp->pool_in_use>mp->max_pl_used )
1285 mp->max_pl_used=mp->pool_in_use;
1286 if ( mp->strs_in_use>mp->max_strs_used )
1287 mp->max_strs_used=mp->strs_in_use;
1291 @ The most interesting string operation is string pool compaction. The idea
1292 is to recover unused space in the |str_pool| array by recopying the strings
1293 to close the gaps created when some strings become unused. All string
1294 numbers~$k$ where |str_ref[k]=0| are to be linked into the list of free string
1295 numbers after |str_ptr|. If this fails to free enough pool space we issue an
1296 |overflow| error unless |needed=mp->pool_size|. Calling |do_compaction|
1297 with |needed=mp->pool_size| supresses all overflow tests.
1299 The compaction process starts with |last_fixed_str| because all lower numbered
1300 strings are permanently allocated with |max_str_ref| in their |str_ref| entries.
1303 str_number last_fixed_str; /* last permanently allocated string */
1304 str_number fixed_str_use; /* number of permanently allocated strings */
1306 @ @<Declare the procedure called |do_compaction|@>=
1307 void mp_do_compaction (MP mp, pool_pointer needed) ;
1310 void mp_do_compaction (MP mp, pool_pointer needed) {
1311 str_number str_use; /* a count of strings in use */
1312 str_number r,s,t; /* strings being manipulated */
1313 pool_pointer p,q; /* destination and source for copying string characters */
1314 @<Advance |last_fixed_str| as far as possible and set |str_use|@>;
1315 r=mp->last_fixed_str;
1318 while ( s!=mp->str_ptr ) {
1319 while ( mp->str_ref[s]==0 ) {
1320 @<Advance |s| and add the old |s| to the list of free string numbers;
1321 then |break| if |s=str_ptr|@>;
1323 r=s; s=mp->next_str[s];
1325 @<Move string |r| back so that |str_start[r]=p|; make |p| the location
1326 after the end of the string@>;
1329 @<Move the current string back so that it starts at |p|@>;
1330 if ( needed<mp->pool_size ) {
1331 @<Make sure that there is room for another string with |needed| characters@>;
1333 @<Account for the compaction and make sure the statistics agree with the
1335 mp->strs_used_up=str_use;
1338 @ @<Advance |last_fixed_str| as far as possible and set |str_use|@>=
1339 t=mp->next_str[mp->last_fixed_str];
1340 while (t!=mp->str_ptr && mp->str_ref[t]==max_str_ref) {
1341 incr(mp->fixed_str_use);
1342 mp->last_fixed_str=t;
1345 str_use=mp->fixed_str_use
1347 @ Because of the way |flush_string| has been written, it should never be
1348 necessary to |break| here. The extra line of code seems worthwhile to
1349 preserve the generality of |do_compaction|.
1351 @<Advance |s| and add the old |s| to the list of free string numbers;...@>=
1356 mp->next_str[t]=mp->next_str[mp->str_ptr];
1357 mp->next_str[mp->str_ptr]=t;
1358 if ( s==mp->str_ptr ) goto DONE;
1361 @ The string currently starts at |str_start[r]| and ends just before
1362 |str_start[s]|. We don't change |str_start[s]| because it might be needed
1363 to locate the next string.
1365 @<Move string |r| back so that |str_start[r]=p|; make |p| the location...@>=
1368 while ( q<mp->str_start[s] ) {
1369 mp->str_pool[p]=mp->str_pool[q];
1373 @ Pointers |str_start[str_ptr]| and |pool_ptr| have not been updated. When
1374 we do this, anything between them should be moved.
1376 @ @<Move the current string back so that it starts at |p|@>=
1377 q=mp->str_start[mp->str_ptr];
1378 mp->str_start[mp->str_ptr]=p;
1379 while ( q<mp->pool_ptr ) {
1380 mp->str_pool[p]=mp->str_pool[q];
1385 @ We must remember that |str_ptr| is not allowed to reach |mp->max_strings|.
1387 @<Make sure that there is room for another string with |needed| char...@>=
1388 if ( str_use>=mp->max_strings-1 )
1389 mp_reallocate_strings (mp,str_use);
1390 if ( mp->pool_ptr+needed>mp->max_pool_ptr ) {
1391 mp_reallocate_pool(mp, mp->pool_ptr+needed);
1392 mp->max_pool_ptr=mp->pool_ptr+needed;
1396 void mp_reallocate_strings (MP mp, str_number str_use) ;
1397 void mp_reallocate_pool(MP mp, pool_pointer needed) ;
1400 void mp_reallocate_strings (MP mp, str_number str_use) {
1401 while ( str_use>=mp->max_strings-1 ) {
1402 int l = mp->max_strings + (mp->max_strings>>2);
1403 XREALLOC (mp->str_ref, l, int);
1404 XREALLOC (mp->str_start, l, pool_pointer);
1405 XREALLOC (mp->next_str, l, str_number);
1406 mp->max_strings = l;
1409 void mp_reallocate_pool(MP mp, pool_pointer needed) {
1410 while ( needed>mp->pool_size ) {
1411 int l = mp->pool_size + (mp->pool_size>>2);
1412 XREALLOC (mp->str_pool, l, ASCII_code);
1417 @ @<Account for the compaction and make sure the statistics agree with...@>=
1418 if ( (mp->str_start[mp->str_ptr]!=mp->pool_in_use)||(str_use!=mp->strs_in_use) )
1419 mp_confusion(mp, "string");
1420 @:this can't happen string}{\quad string@>
1421 incr(mp->pact_count);
1422 mp->pact_chars=mp->pact_chars+mp->pool_ptr-str_stop(mp->last_fixed_str);
1423 mp->pact_strs=mp->pact_strs+str_use-mp->fixed_str_use;
1425 @ A few more global variables are needed to keep track of statistics when
1426 |stat| $\ldots$ |tats| blocks are not commented out.
1429 integer pact_count; /* number of string pool compactions so far */
1430 integer pact_chars; /* total number of characters moved during compactions */
1431 integer pact_strs; /* total number of strings moved during compactions */
1433 @ @<Initialize compaction statistics@>=
1438 @ The following subroutine compares string |s| with another string of the
1439 same length that appears in |buffer| starting at position |k|;
1440 the result is |true| if and only if the strings are equal.
1443 boolean mp_str_eq_buf (MP mp,str_number s, integer k) {
1444 /* test equality of strings */
1445 pool_pointer j; /* running index */
1447 while ( j<str_stop(s) ) {
1448 if ( mp->str_pool[j++]!=mp->buffer[k++] )
1454 @ Here is a similar routine, but it compares two strings in the string pool,
1455 and it does not assume that they have the same length. If the first string
1456 is lexicographically greater than, less than, or equal to the second,
1457 the result is respectively positive, negative, or zero.
1460 integer mp_str_vs_str (MP mp, str_number s, str_number t) {
1461 /* test equality of strings */
1462 pool_pointer j,k; /* running indices */
1463 integer ls,lt; /* lengths */
1464 integer l; /* length remaining to test */
1465 ls=length(s); lt=length(t);
1466 if ( ls<=lt ) l=ls; else l=lt;
1467 j=mp->str_start[s]; k=mp->str_start[t];
1469 if ( mp->str_pool[j]!=mp->str_pool[k] ) {
1470 return (mp->str_pool[j]-mp->str_pool[k]);
1477 @ The initial values of |str_pool|, |str_start|, |pool_ptr|,
1478 and |str_ptr| are computed by the \.{INIMP} program, based in part
1479 on the information that \.{WEB} has output while processing \MP.
1484 void mp_get_strings_started (MP mp) {
1485 /* initializes the string pool,
1486 but returns |false| if something goes wrong */
1487 int k; /* small indices or counters */
1488 str_number g; /* a new string */
1489 mp->pool_ptr=0; mp->str_ptr=0; mp->max_pool_ptr=0; mp->max_str_ptr=0;
1492 mp->pool_in_use=0; mp->strs_in_use=0;
1493 mp->max_pl_used=0; mp->max_strs_used=0;
1494 @<Initialize compaction statistics@>;
1496 @<Make the first 256 strings@>;
1497 g=mp_make_string(mp); /* string 256 == "" */
1498 mp->str_ref[g]=max_str_ref;
1499 mp->last_fixed_str=mp->str_ptr-1;
1500 mp->fixed_str_use=mp->str_ptr;
1505 void mp_get_strings_started (MP mp);
1507 @ The first 256 strings will consist of a single character only.
1509 @<Make the first 256...@>=
1510 for (k=0;k<=255;k++) {
1512 g=mp_make_string(mp);
1513 mp->str_ref[g]=max_str_ref;
1516 @ The first 128 strings will contain 95 standard ASCII characters, and the
1517 other 33 characters will be printed in three-symbol form like `\.{\^\^A}'
1518 unless a system-dependent change is made here. Installations that have
1519 an extended character set, where for example |xchr[032]=@t\.{'^^Z'}@>|,
1520 would like string 032 to be printed as the single character 032 instead
1521 of the three characters 0136, 0136, 0132 (\.{\^\^Z}). On the other hand,
1522 even people with an extended character set will want to represent string
1523 015 by \.{\^\^M}, since 015 is ASCII's ``carriage return'' code; the idea is
1524 to produce visible strings instead of tabs or line-feeds or carriage-returns
1525 or bell-rings or characters that are treated anomalously in text files.
1527 The boolean expression defined here should be |true| unless \MP\ internal
1528 code number~|k| corresponds to a non-troublesome visible symbol in the
1529 local character set.
1530 If character |k| cannot be printed, and |k<0200|, then character |k+0100| or
1531 |k-0100| must be printable; moreover, ASCII codes |[060..071, 0141..0146]|
1533 @^character set dependencies@>
1534 @^system dependencies@>
1536 @<Character |k| cannot be printed@>=
1539 @* \[5] On-line and off-line printing.
1540 Messages that are sent to a user's terminal and to the transcript-log file
1541 are produced by several `|print|' procedures. These procedures will
1542 direct their output to a variety of places, based on the setting of
1543 the global variable |selector|, which has the following possible
1547 \hang |term_and_log|, the normal setting, prints on the terminal and on the
1550 \hang |log_only|, prints only on the transcript file.
1552 \hang |term_only|, prints only on the terminal.
1554 \hang |no_print|, doesn't print at all. This is used only in rare cases
1555 before the transcript file is open.
1557 \hang |pseudo|, puts output into a cyclic buffer that is used
1558 by the |show_context| routine; when we get to that routine we shall discuss
1559 the reasoning behind this curious mode.
1561 \hang |new_string|, appends the output to the current string in the
1564 \hang |>=write_file| prints on one of the files used for the \&{write}
1565 @:write_}{\&{write} primitive@>
1569 \noindent The symbolic names `|term_and_log|', etc., have been assigned
1570 numeric codes that satisfy the convenient relations |no_print+1=term_only|,
1571 |no_print+2=log_only|, |term_only+2=log_only+1=term_and_log|. These
1572 relations are not used when |selector| could be |pseudo|, or |new_string|.
1573 We need not check for unprintable characters when |selector<pseudo|.
1575 Three additional global variables, |tally|, |term_offset| and |file_offset|
1576 record the number of characters that have been printed
1577 since they were most recently cleared to zero. We use |tally| to record
1578 the length of (possibly very long) stretches of printing; |term_offset|,
1579 and |file_offset|, on the other hand, keep track of how many
1580 characters have appeared so far on the current line that has been output
1581 to the terminal, the transcript file, or the \ps\ output file, respectively.
1583 @d new_string 0 /* printing is deflected to the string pool */
1584 @d pseudo 2 /* special |selector| setting for |show_context| */
1585 @d no_print 3 /* |selector| setting that makes data disappear */
1586 @d term_only 4 /* printing is destined for the terminal only */
1587 @d log_only 5 /* printing is destined for the transcript file only */
1588 @d term_and_log 6 /* normal |selector| setting */
1589 @d write_file 7 /* first write file selector */
1592 void * log_file; /* transcript of \MP\ session */
1593 void * ps_file; /* the generic font output goes here */
1594 unsigned int selector; /* where to print a message */
1595 unsigned char dig[23]; /* digits in a number, for rounding */
1596 integer tally; /* the number of characters recently printed */
1597 unsigned int term_offset;
1598 /* the number of characters on the current terminal line */
1599 unsigned int file_offset;
1600 /* the number of characters on the current file line */
1601 ASCII_code *trick_buf; /* circular buffer for pseudoprinting */
1602 integer trick_count; /* threshold for pseudoprinting, explained later */
1603 integer first_count; /* another variable for pseudoprinting */
1605 @ @<Allocate or initialize ...@>=
1606 mp->trick_buf = xmalloc((mp->error_line+1),sizeof(ASCII_code));
1608 @ @<Dealloc variables@>=
1609 xfree(mp->trick_buf);
1611 @ @<Initialize the output routines@>=
1612 mp->selector=term_only; mp->tally=0; mp->term_offset=0; mp->file_offset=0;
1614 @ Macro abbreviations for output to the terminal and to the log file are
1615 defined here for convenience. Some systems need special conventions
1616 for terminal output, and it is possible to adhere to those conventions
1617 by changing |wterm|, |wterm_ln|, and |wterm_cr| here.
1618 @^system dependencies@>
1620 @d do_fprintf(f,b) (mp->write_ascii_file)(mp,f,b)
1621 @d wterm(A) do_fprintf(mp->term_out,(A))
1622 @d wterm_chr(A) { unsigned char ss[2]; ss[0]=(A); ss[1]=0; do_fprintf(mp->term_out,(char *)ss); }
1623 @d wterm_cr do_fprintf(mp->term_out,"\n")
1624 @d wterm_ln(A) { wterm_cr; do_fprintf(mp->term_out,(A)); }
1625 @d wlog(A) do_fprintf(mp->log_file,(A))
1626 @d wlog_chr(A) { unsigned char ss[2]; ss[0]=(A); ss[1]=0; do_fprintf(mp->log_file,(char *)ss); }
1627 @d wlog_cr do_fprintf(mp->log_file, "\n")
1628 @d wlog_ln(A) { wlog_cr; do_fprintf(mp->log_file,(A)); }
1631 @ To end a line of text output, we call |print_ln|. Cases |0..max_write_files|
1632 use an array |wr_file| that will be declared later.
1634 @d mp_print_text(A) mp_print_str(mp,text((A)))
1637 void mp_print_ln (MP mp);
1638 void mp_print_visible_char (MP mp, ASCII_code s);
1639 void mp_print_char (MP mp, ASCII_code k);
1640 void mp_print (MP mp, const char *s);
1641 void mp_print_str (MP mp, str_number s);
1642 void mp_print_nl (MP mp, const char *s);
1643 void mp_print_two (MP mp,scaled x, scaled y) ;
1644 void mp_print_scaled (MP mp,scaled s);
1646 @ @<Basic print...@>=
1647 void mp_print_ln (MP mp) { /* prints an end-of-line */
1648 switch (mp->selector) {
1651 mp->term_offset=0; mp->file_offset=0;
1654 wlog_cr; mp->file_offset=0;
1657 wterm_cr; mp->term_offset=0;
1664 do_fprintf(mp->wr_file[(mp->selector-write_file)],"\n");
1666 } /* note that |tally| is not affected */
1668 @ The |print_visible_char| procedure sends one character to the desired
1669 destination, using the |xchr| array to map it into an external character
1670 compatible with |input_ln|. (It assumes that it is always called with
1671 a visible ASCII character.) All printing comes through |print_ln| or
1672 |print_char|, which ultimately calls |print_visible_char|, hence these
1673 routines are the ones that limit lines to at most |max_print_line| characters.
1674 But we must make an exception for the \ps\ output file since it is not safe
1675 to cut up lines arbitrarily in \ps.
1677 Procedure |unit_str_room| needs to be declared |forward| here because it calls
1678 |do_compaction| and |do_compaction| can call the error routines. Actually,
1679 |unit_str_room| avoids |overflow| errors but it can call |confusion|.
1681 @<Basic printing...@>=
1682 void mp_print_visible_char (MP mp, ASCII_code s) { /* prints a single character */
1683 switch (mp->selector) {
1685 wterm_chr(xchr(s)); wlog_chr(xchr(s));
1686 incr(mp->term_offset); incr(mp->file_offset);
1687 if ( mp->term_offset==(unsigned)mp->max_print_line ) {
1688 wterm_cr; mp->term_offset=0;
1690 if ( mp->file_offset==(unsigned)mp->max_print_line ) {
1691 wlog_cr; mp->file_offset=0;
1695 wlog_chr(xchr(s)); incr(mp->file_offset);
1696 if ( mp->file_offset==(unsigned)mp->max_print_line ) mp_print_ln(mp);
1699 wterm_chr(xchr(s)); incr(mp->term_offset);
1700 if ( mp->term_offset==(unsigned)mp->max_print_line ) mp_print_ln(mp);
1705 if ( mp->tally<mp->trick_count )
1706 mp->trick_buf[mp->tally % mp->error_line]=s;
1709 if ( mp->pool_ptr>=mp->max_pool_ptr ) {
1710 mp_unit_str_room(mp);
1711 if ( mp->pool_ptr>=mp->pool_size )
1712 goto DONE; /* drop characters if string space is full */
1717 { char ss[2]; ss[0] = xchr(s); ss[1]=0;
1718 do_fprintf(mp->wr_file[(mp->selector-write_file)],(char *)ss);
1725 @ The |print_char| procedure sends one character to the desired destination.
1726 File names and string expressions might contain |ASCII_code| values that
1727 can't be printed using |print_visible_char|. These characters will be
1728 printed in three- or four-symbol form like `\.{\^\^A}' or `\.{\^\^e4}'.
1729 (This procedure assumes that it is safe to bypass all checks for unprintable
1730 characters when |selector| is in the range |0..max_write_files-1|.
1731 The user might want to write unprintable characters.
1733 @<Basic printing...@>=
1734 void mp_print_char (MP mp, ASCII_code k) { /* prints a single character */
1735 if ( mp->selector<pseudo || mp->selector>=write_file) {
1736 mp_print_visible_char(mp, k);
1737 } else if ( @<Character |k| cannot be printed@> ) {
1740 mp_print_visible_char(mp, k+0100);
1741 } else if ( k<0200 ) {
1742 mp_print_visible_char(mp, k-0100);
1744 int l; /* small index or counter */
1746 mp_print_visible_char(mp, (l<10 ? l+'0' : l-10+'a'));
1748 mp_print_visible_char(mp, (l<10 ? l+'0' : l-10+'a'));
1751 mp_print_visible_char(mp, k);
1755 @ An entire string is output by calling |print|. Note that if we are outputting
1756 the single standard ASCII character \.c, we could call |print("c")|, since
1757 |"c"=99| is the number of a single-character string, as explained above. But
1758 |print_char("c")| is quicker, so \MP\ goes directly to the |print_char|
1759 routine when it knows that this is safe. (The present implementation
1760 assumes that it is always safe to print a visible ASCII character.)
1761 @^system dependencies@>
1764 void mp_do_print (MP mp, const char *ss, unsigned int len) { /* prints string |s| */
1767 mp_print_char(mp, ss[j]); incr(j);
1773 void mp_print (MP mp, const char *ss) {
1774 if (ss==NULL) return;
1775 mp_do_print(mp, ss, strlen(ss));
1777 void mp_print_str (MP mp, str_number s) {
1778 pool_pointer j; /* current character code position */
1779 if ( (s<0)||(s>mp->max_str_ptr) ) {
1780 mp_do_print(mp,"???",3); /* this can't happen */
1784 mp_do_print(mp, (char *)(mp->str_pool+j), (str_stop(s)-j));
1788 @ Here is the very first thing that \MP\ prints: a headline that identifies
1789 the version number and base name. The |term_offset| variable is temporarily
1790 incorrect, but the discrepancy is not serious since we assume that the banner
1791 and mem identifier together will occupy at most |max_print_line|
1792 character positions.
1794 @<Initialize the output...@>=
1796 if (mp->mem_ident!=NULL)
1797 mp_print(mp,mp->mem_ident);
1801 @ The procedure |print_nl| is like |print|, but it makes sure that the
1802 string appears at the beginning of a new line.
1805 void mp_print_nl (MP mp, const char *s) { /* prints string |s| at beginning of line */
1806 switch(mp->selector) {
1808 if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_ln(mp);
1811 if ( mp->file_offset>0 ) mp_print_ln(mp);
1814 if ( mp->term_offset>0 ) mp_print_ln(mp);
1820 } /* there are no other cases */
1824 @ The following procedure, which prints out the decimal representation of a
1825 given integer |n|, assumes that all integers fit nicely into a |int|.
1826 @^system dependencies@>
1829 void mp_print_int (MP mp,integer n) { /* prints an integer in decimal form */
1831 mp_snprintf(s,12,"%d", (int)n);
1836 void mp_print_int (MP mp,integer n);
1838 @ \MP\ also makes use of a trivial procedure to print two digits. The
1839 following subroutine is usually called with a parameter in the range |0<=n<=99|.
1842 void mp_print_dd (MP mp,integer n) { /* prints two least significant digits */
1844 mp_print_char(mp, '0'+(n / 10));
1845 mp_print_char(mp, '0'+(n % 10));
1850 void mp_print_dd (MP mp,integer n);
1852 @ Here is a procedure that asks the user to type a line of input,
1853 assuming that the |selector| setting is either |term_only| or |term_and_log|.
1854 The input is placed into locations |first| through |last-1| of the
1855 |buffer| array, and echoed on the transcript file if appropriate.
1857 This procedure is never called when |interaction<mp_scroll_mode|.
1859 @d prompt_input(A) do {
1860 if (!mp->noninteractive) {
1861 wake_up_terminal; mp_print(mp, (A));
1864 } while (0) /* prints a string and gets a line of input */
1867 void mp_term_input (MP mp) { /* gets a line from the terminal */
1868 size_t k; /* index into |buffer| */
1869 if (mp->noninteractive) {
1870 if (!mp_input_ln(mp, mp->term_in ))
1871 longjmp(*(mp->jump_buf),1); /* chunk finished */
1872 mp->buffer[mp->last]='%';
1874 update_terminal; /* Now the user sees the prompt for sure */
1875 if (!mp_input_ln(mp, mp->term_in )) {
1876 mp_fatal_error(mp, "End of file on the terminal!");
1877 @.End of file on the terminal@>
1879 mp->term_offset=0; /* the user's line ended with \<\rm return> */
1880 decr(mp->selector); /* prepare to echo the input */
1881 if ( mp->last!=mp->first ) {
1882 for (k=mp->first;k<=mp->last-1;k++) {
1883 mp_print_char(mp, mp->buffer[k]);
1887 mp->buffer[mp->last]='%';
1888 incr(mp->selector); /* restore previous status */
1892 @* \[6] Reporting errors.
1893 When something anomalous is detected, \MP\ typically does something like this:
1894 $$\vbox{\halign{#\hfil\cr
1895 |print_err("Something anomalous has been detected");|\cr
1896 |help3("This is the first line of my offer to help.")|\cr
1897 |("This is the second line. I'm trying to")|\cr
1898 |("explain the best way for you to proceed.");|\cr
1900 A two-line help message would be given using |help2|, etc.; these informal
1901 helps should use simple vocabulary that complements the words used in the
1902 official error message that was printed. (Outside the U.S.A., the help
1903 messages should preferably be translated into the local vernacular. Each
1904 line of help is at most 60 characters long, in the present implementation,
1905 so that |max_print_line| will not be exceeded.)
1907 The |print_err| procedure supplies a `\.!' before the official message,
1908 and makes sure that the terminal is awake if a stop is going to occur.
1909 The |error| procedure supplies a `\..' after the official message, then it
1910 shows the location of the error; and if |interaction=error_stop_mode|,
1911 it also enters into a dialog with the user, during which time the help
1912 message may be printed.
1913 @^system dependencies@>
1915 @ The global variable |interaction| has four settings, representing increasing
1916 amounts of user interaction:
1919 enum mp_interaction_mode {
1920 mp_unspecified_mode=0, /* extra value for command-line switch */
1921 mp_batch_mode, /* omits all stops and omits terminal output */
1922 mp_nonstop_mode, /* omits all stops */
1923 mp_scroll_mode, /* omits error stops */
1924 mp_error_stop_mode /* stops at every opportunity to interact */
1927 @ @<Option variables@>=
1928 int interaction; /* current level of interaction */
1929 int noninteractive; /* do we have a terminal? */
1931 @ Set it here so it can be overwritten by the commandline
1933 @<Allocate or initialize ...@>=
1934 mp->interaction=opt->interaction;
1935 if (mp->interaction==mp_unspecified_mode || mp->interaction>mp_error_stop_mode)
1936 mp->interaction=mp_error_stop_mode;
1937 if (mp->interaction<mp_unspecified_mode)
1938 mp->interaction=mp_batch_mode;
1942 @d print_err(A) mp_print_err(mp,(A))
1945 void mp_print_err(MP mp, const char * A);
1948 void mp_print_err(MP mp, const char * A) {
1949 if ( mp->interaction==mp_error_stop_mode )
1951 mp_print_nl(mp, "! ");
1957 @ \MP\ is careful not to call |error| when the print |selector| setting
1958 might be unusual. The only possible values of |selector| at the time of
1961 \yskip\hang|no_print| (when |interaction=mp_batch_mode|
1962 and |log_file| not yet open);
1964 \hang|term_only| (when |interaction>mp_batch_mode| and |log_file| not yet open);
1966 \hang|log_only| (when |interaction=mp_batch_mode| and |log_file| is open);
1968 \hang|term_and_log| (when |interaction>mp_batch_mode| and |log_file| is open).
1970 @<Initialize the print |selector| based on |interaction|@>=
1971 if ( mp->interaction==mp_batch_mode ) mp->selector=no_print; else mp->selector=term_only
1973 @ A global variable |deletions_allowed| is set |false| if the |get_next|
1974 routine is active when |error| is called; this ensures that |get_next|
1975 will never be called recursively.
1978 The global variable |history| records the worst level of error that
1979 has been detected. It has four possible values: |spotless|, |warning_issued|,
1980 |error_message_issued|, and |fatal_error_stop|.
1982 Another global variable, |error_count|, is increased by one when an
1983 |error| occurs without an interactive dialog, and it is reset to zero at
1984 the end of every statement. If |error_count| reaches 100, \MP\ decides
1985 that there is no point in continuing further.
1988 enum mp_history_states {
1989 mp_spotless=0, /* |history| value when nothing has been amiss yet */
1990 mp_warning_issued, /* |history| value when |begin_diagnostic| has been called */
1991 mp_error_message_issued, /* |history| value when |error| has been called */
1992 mp_fatal_error_stop, /* |history| value when termination was premature */
1993 mp_system_error_stop /* |history| value when termination was due to disaster */
1997 boolean deletions_allowed; /* is it safe for |error| to call |get_next|? */
1998 int history; /* has the source input been clean so far? */
1999 int error_count; /* the number of scrolled errors since the last statement ended */
2001 @ The value of |history| is initially |fatal_error_stop|, but it will
2002 be changed to |spotless| if \MP\ survives the initialization process.
2004 @<Allocate or ...@>=
2005 mp->deletions_allowed=true; /* |history| is initialized elsewhere */
2007 @ Since errors can be detected almost anywhere in \MP, we want to declare the
2008 error procedures near the beginning of the program. But the error procedures
2009 in turn use some other procedures, which need to be declared |forward|
2010 before we get to |error| itself.
2012 It is possible for |error| to be called recursively if some error arises
2013 when |get_next| is being used to delete a token, and/or if some fatal error
2014 occurs while \MP\ is trying to fix a non-fatal one. But such recursion
2016 is never more than two levels deep.
2019 void mp_get_next (MP mp);
2020 void mp_term_input (MP mp);
2021 void mp_show_context (MP mp);
2022 void mp_begin_file_reading (MP mp);
2023 void mp_open_log_file (MP mp);
2024 void mp_clear_for_error_prompt (MP mp);
2025 @<Declare the procedure called |flush_string|@>
2028 void mp_normalize_selector (MP mp);
2030 @ Individual lines of help are recorded in the array |help_line|, which
2031 contains entries in positions |0..(help_ptr-1)|. They should be printed
2032 in reverse order, i.e., with |help_line[0]| appearing last.
2034 @d hlp1(A) mp->help_line[0]=(A); }
2035 @d hlp2(A) mp->help_line[1]=(A); hlp1
2036 @d hlp3(A) mp->help_line[2]=(A); hlp2
2037 @d hlp4(A) mp->help_line[3]=(A); hlp3
2038 @d hlp5(A) mp->help_line[4]=(A); hlp4
2039 @d hlp6(A) mp->help_line[5]=(A); hlp5
2040 @d help0 mp->help_ptr=0 /* sometimes there might be no help */
2041 @d help1 { mp->help_ptr=1; hlp1 /* use this with one help line */
2042 @d help2 { mp->help_ptr=2; hlp2 /* use this with two help lines */
2043 @d help3 { mp->help_ptr=3; hlp3 /* use this with three help lines */
2044 @d help4 { mp->help_ptr=4; hlp4 /* use this with four help lines */
2045 @d help5 { mp->help_ptr=5; hlp5 /* use this with five help lines */
2046 @d help6 { mp->help_ptr=6; hlp6 /* use this with six help lines */
2049 const char * help_line[6]; /* helps for the next |error| */
2050 unsigned int help_ptr; /* the number of help lines present */
2051 boolean use_err_help; /* should the |err_help| string be shown? */
2052 str_number err_help; /* a string set up by \&{errhelp} */
2053 str_number filename_template; /* a string set up by \&{filenametemplate} */
2055 @ @<Allocate or ...@>=
2056 mp->use_err_help=false;
2058 @ The |jump_out| procedure just cuts across all active procedure levels and
2059 goes to |end_of_MP|. This is the only nonlocal |goto| statement in the
2060 whole program. It is used when there is no recovery from a particular error.
2062 The program uses a |jump_buf| to handle this, this is initialized at three
2063 spots: the start of |mp_new|, the start of |mp_initialize|, and the start
2064 of |mp_run|. Those are the only library enty points.
2066 @^system dependencies@>
2071 @ @<Install and test the non-local jump buffer@>=
2072 mp->jump_buf = &buf;
2073 if (setjmp(*(mp->jump_buf)) != 0) { return mp->history; }
2075 @ @<Setup the non-local jump buffer in |mp_new|@>=
2076 if (setjmp(buf) != 0) { return NULL; }
2079 @ If the array of internals is still |NULL| when |jump_out| is called, a
2080 crash occured during initialization, and it is not safe to run the normal
2084 void mp_jump_out (MP mp) {
2085 if (mp->internal!=NULL && mp->history < mp_system_error_stop)
2086 mp_close_files_and_terminate(mp);
2087 longjmp(*(mp->jump_buf),1);
2090 @ Here now is the general |error| routine.
2093 void mp_error (MP mp) { /* completes the job of error reporting */
2094 ASCII_code c; /* what the user types */
2095 integer s1,s2,s3; /* used to save global variables when deleting tokens */
2096 pool_pointer j; /* character position being printed */
2097 if ( mp->history<mp_error_message_issued )
2098 mp->history=mp_error_message_issued;
2099 mp_print_char(mp, '.'); mp_show_context(mp);
2100 if ((!mp->noninteractive) && (mp->interaction==mp_error_stop_mode )) {
2101 @<Get user's advice and |return|@>;
2103 incr(mp->error_count);
2104 if ( mp->error_count==100 ) {
2105 mp_print_nl(mp,"(That makes 100 errors; please try again.)");
2106 @.That makes 100 errors...@>
2107 mp->history=mp_fatal_error_stop; mp_jump_out(mp);
2109 @<Put help message on the transcript file@>;
2111 void mp_warn (MP mp, const char *msg) {
2112 int saved_selector = mp->selector;
2113 mp_normalize_selector(mp);
2114 mp_print_nl(mp,"Warning: ");
2117 mp->selector = saved_selector;
2120 @ @<Exported function ...@>=
2121 void mp_error (MP mp);
2122 void mp_warn (MP mp, const char *msg);
2125 @ @<Get user's advice...@>=
2128 mp_clear_for_error_prompt(mp); prompt_input("? ");
2130 if ( mp->last==mp->first ) return;
2131 c=mp->buffer[mp->first];
2132 if ( c>='a' ) c=c+'A'-'a'; /* convert to uppercase */
2133 @<Interpret code |c| and |return| if done@>;
2136 @ It is desirable to provide an `\.E' option here that gives the user
2137 an easy way to return from \MP\ to the system editor, with the offending
2138 line ready to be edited. But such an extension requires some system
2139 wizardry, so the present implementation simply types out the name of the
2141 edited and the relevant line number.
2142 @^system dependencies@>
2145 typedef void (*mp_run_editor_command)(MP, char *, int);
2147 @ @<Option variables@>=
2148 mp_run_editor_command run_editor;
2150 @ @<Allocate or initialize ...@>=
2151 set_callback_option(run_editor);
2154 void mp_run_editor (MP mp, char *fname, int fline);
2156 @ @c void mp_run_editor (MP mp, char *fname, int fline) {
2157 mp_print_nl(mp, "You want to edit file ");
2158 @.You want to edit file x@>
2159 mp_print(mp, fname);
2160 mp_print(mp, " at line ");
2161 mp_print_int(mp, fline);
2162 mp->interaction=mp_scroll_mode;
2167 There is a secret `\.D' option available when the debugging routines haven't
2171 @<Interpret code |c| and |return| if done@>=
2173 case '0': case '1': case '2': case '3': case '4':
2174 case '5': case '6': case '7': case '8': case '9':
2175 if ( mp->deletions_allowed ) {
2176 @<Delete |c-"0"| tokens and |continue|@>;
2180 if ( mp->file_ptr>0 ){
2181 (mp->run_editor)(mp,
2182 str(mp->input_stack[mp->file_ptr].name_field),
2187 @<Print the help information and |continue|@>;
2190 @<Introduce new material from the terminal and |return|@>;
2192 case 'Q': case 'R': case 'S':
2193 @<Change the interaction level and |return|@>;
2196 mp->interaction=mp_scroll_mode; mp_jump_out(mp);
2201 @<Print the menu of available options@>
2203 @ @<Print the menu...@>=
2205 mp_print(mp, "Type <return> to proceed, S to scroll future error messages,");
2206 @.Type <return> to proceed...@>
2207 mp_print_nl(mp, "R to run without stopping, Q to run quietly,");
2208 mp_print_nl(mp, "I to insert something, ");
2209 if ( mp->file_ptr>0 )
2210 mp_print(mp, "E to edit your file,");
2211 if ( mp->deletions_allowed )
2212 mp_print_nl(mp, "1 or ... or 9 to ignore the next 1 to 9 tokens of input,");
2213 mp_print_nl(mp, "H for help, X to quit.");
2216 @ Here the author of \MP\ apologizes for making use of the numerical
2217 relation between |"Q"|, |"R"|, |"S"|, and the desired interaction settings
2218 |mp_batch_mode|, |mp_nonstop_mode|, |mp_scroll_mode|.
2219 @^Knuth, Donald Ervin@>
2221 @<Change the interaction...@>=
2223 mp->error_count=0; mp->interaction=mp_batch_mode+c-'Q';
2224 mp_print(mp, "OK, entering ");
2226 case 'Q': mp_print(mp, "batchmode"); decr(mp->selector); break;
2227 case 'R': mp_print(mp, "nonstopmode"); break;
2228 case 'S': mp_print(mp, "scrollmode"); break;
2229 } /* there are no other cases */
2230 mp_print(mp, "..."); mp_print_ln(mp); update_terminal; return;
2233 @ When the following code is executed, |buffer[(first+1)..(last-1)]| may
2234 contain the material inserted by the user; otherwise another prompt will
2235 be given. In order to understand this part of the program fully, you need
2236 to be familiar with \MP's input stacks.
2238 @<Introduce new material...@>=
2240 mp_begin_file_reading(mp); /* enter a new syntactic level for terminal input */
2241 if ( mp->last>mp->first+1 ) {
2242 loc=mp->first+1; mp->buffer[mp->first]=' ';
2244 prompt_input("insert>"); loc=mp->first;
2247 mp->first=mp->last+1; mp->cur_input.limit_field=mp->last; return;
2250 @ We allow deletion of up to 99 tokens at a time.
2252 @<Delete |c-"0"| tokens...@>=
2254 s1=mp->cur_cmd; s2=mp->cur_mod; s3=mp->cur_sym; mp->OK_to_interrupt=false;
2255 if ( (mp->last>mp->first+1) && (mp->buffer[mp->first+1]>='0')&&(mp->buffer[mp->first+1]<='9') )
2256 c=c*10+mp->buffer[mp->first+1]-'0'*11;
2260 mp_get_next(mp); /* one-level recursive call of |error| is possible */
2261 @<Decrease the string reference count, if the current token is a string@>;
2264 mp->cur_cmd=s1; mp->cur_mod=s2; mp->cur_sym=s3; mp->OK_to_interrupt=true;
2265 help2("I have just deleted some text, as you asked.")
2266 ("You can now delete more, or insert, or whatever.");
2267 mp_show_context(mp);
2271 @ @<Print the help info...@>=
2273 if ( mp->use_err_help ) {
2274 @<Print the string |err_help|, possibly on several lines@>;
2275 mp->use_err_help=false;
2277 if ( mp->help_ptr==0 ) {
2278 help2("Sorry, I don't know how to help in this situation.")
2279 ("Maybe you should try asking a human?");
2282 decr(mp->help_ptr); mp_print(mp, mp->help_line[mp->help_ptr]); mp_print_ln(mp);
2283 } while (mp->help_ptr!=0);
2285 help4("Sorry, I already gave what help I could...")
2286 ("Maybe you should try asking a human?")
2287 ("An error might have occurred before I noticed any problems.")
2288 ("``If all else fails, read the instructions.''");
2292 @ @<Print the string |err_help|, possibly on several lines@>=
2293 j=mp->str_start[mp->err_help];
2294 while ( j<str_stop(mp->err_help) ) {
2295 if ( mp->str_pool[j]!='%' ) mp_print_str(mp, mp->str_pool[j]);
2296 else if ( j+1==str_stop(mp->err_help) ) mp_print_ln(mp);
2297 else if ( mp->str_pool[j+1]!='%' ) mp_print_ln(mp);
2298 else { incr(j); mp_print_char(mp, '%'); };
2302 @ @<Put help message on the transcript file@>=
2303 if ( mp->interaction>mp_batch_mode ) decr(mp->selector); /* avoid terminal output */
2304 if ( mp->use_err_help ) {
2305 mp_print_nl(mp, "");
2306 @<Print the string |err_help|, possibly on several lines@>;
2308 while ( mp->help_ptr>0 ){
2309 decr(mp->help_ptr); mp_print_nl(mp, mp->help_line[mp->help_ptr]);
2313 if ( mp->interaction>mp_batch_mode ) incr(mp->selector); /* re-enable terminal output */
2316 @ In anomalous cases, the print selector might be in an unknown state;
2317 the following subroutine is called to fix things just enough to keep
2318 running a bit longer.
2321 void mp_normalize_selector (MP mp) {
2322 if ( mp->log_opened ) mp->selector=term_and_log;
2323 else mp->selector=term_only;
2324 if ( mp->job_name==NULL) mp_open_log_file(mp);
2325 if ( mp->interaction==mp_batch_mode ) decr(mp->selector);
2328 @ The following procedure prints \MP's last words before dying.
2330 @d succumb { if ( mp->interaction==mp_error_stop_mode )
2331 mp->interaction=mp_scroll_mode; /* no more interaction */
2332 if ( mp->log_opened ) mp_error(mp);
2333 mp->history=mp_fatal_error_stop; mp_jump_out(mp); /* irrecoverable error */
2337 void mp_fatal_error (MP mp, const char *s) { /* prints |s|, and that's it */
2338 mp_normalize_selector(mp);
2339 print_err("Emergency stop"); help1(s); succumb;
2343 @ @<Exported function ...@>=
2344 void mp_fatal_error (MP mp, const char *s);
2347 @ Here is the most dreaded error message.
2350 void mp_overflow (MP mp, const char *s, integer n) { /* stop due to finiteness */
2352 mp_normalize_selector(mp);
2353 mp_snprintf(msg, 256, "MetaPost capacity exceeded, sorry [%s=%d]",s,(int)n);
2354 @.MetaPost capacity exceeded ...@>
2356 help2("If you really absolutely need more capacity,")
2357 ("you can ask a wizard to enlarge me.");
2361 @ @<Internal library declarations@>=
2362 void mp_overflow (MP mp, const char *s, integer n);
2364 @ The program might sometime run completely amok, at which point there is
2365 no choice but to stop. If no previous error has been detected, that's bad
2366 news; a message is printed that is really intended for the \MP\
2367 maintenance person instead of the user (unless the user has been
2368 particularly diabolical). The index entries for `this can't happen' may
2369 help to pinpoint the problem.
2372 @<Internal library ...@>=
2373 void mp_confusion (MP mp, const char *s);
2375 @ Consistency check violated; |s| tells where.
2377 void mp_confusion (MP mp, const char *s) {
2379 mp_normalize_selector(mp);
2380 if ( mp->history<mp_error_message_issued ) {
2381 mp_snprintf(msg, 256, "This can't happen (%s)",s);
2382 @.This can't happen@>
2384 help1("I'm broken. Please show this to someone who can fix can fix");
2386 print_err("I can\'t go on meeting you like this");
2387 @.I can't go on...@>
2388 help2("One of your faux pas seems to have wounded me deeply...")
2389 ("in fact, I'm barely conscious. Please fix it and try again.");
2394 @ Users occasionally want to interrupt \MP\ while it's running.
2395 If the runtime system allows this, one can implement
2396 a routine that sets the global variable |interrupt| to some nonzero value
2397 when such an interrupt is signaled. Otherwise there is probably at least
2398 a way to make |interrupt| nonzero using the C debugger.
2399 @^system dependencies@>
2402 @d check_interrupt { if ( mp->interrupt!=0 )
2403 mp_pause_for_instructions(mp); }
2406 integer interrupt; /* should \MP\ pause for instructions? */
2407 boolean OK_to_interrupt; /* should interrupts be observed? */
2408 integer run_state; /* are we processing input ?*/
2409 boolean finished; /* set true by |close_files_and_terminate| */
2411 @ @<Allocate or ...@>=
2412 mp->OK_to_interrupt=true;
2415 @ When an interrupt has been detected, the program goes into its
2416 highest interaction level and lets the user have the full flexibility of
2417 the |error| routine. \MP\ checks for interrupts only at times when it is
2421 void mp_pause_for_instructions (MP mp) {
2422 if ( mp->OK_to_interrupt ) {
2423 mp->interaction=mp_error_stop_mode;
2424 if ( (mp->selector==log_only)||(mp->selector==no_print) )
2426 print_err("Interruption");
2429 ("Try to insert some instructions for me (e.g.,`I show x'),")
2430 ("unless you just want to quit by typing `X'.");
2431 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
2436 @ Many of \MP's error messages state that a missing token has been
2437 inserted behind the scenes. We can save string space and program space
2438 by putting this common code into a subroutine.
2441 void mp_missing_err (MP mp, const char *s) {
2443 mp_snprintf(msg, 256, "Missing `%s' has been inserted", s);
2444 @.Missing...inserted@>
2448 @* \[7] Arithmetic with scaled numbers.
2449 The principal computations performed by \MP\ are done entirely in terms of
2450 integers less than $2^{31}$ in magnitude; thus, the arithmetic specified in this
2451 program can be carried out in exactly the same way on a wide variety of
2452 computers, including some small ones.
2455 But C does not rigidly define the |/| operation in the case of negative
2456 dividends; for example, the result of |(-2*n-1) / 2| is |-(n+1)| on some
2457 computers and |-n| on others (is this true ?). There are two principal
2458 types of arithmetic: ``translation-preserving,'' in which the identity
2459 |(a+q*b)/b=(a/b)+q| is valid; and ``negation-preserving,'' in which
2460 |(-a)/b=-(a/b)|. This leads to two \MP s, which can produce
2461 different results, although the differences should be negligible when the
2462 language is being used properly. The \TeX\ processor has been defined
2463 carefully so that both varieties of arithmetic will produce identical
2464 output, but it would be too inefficient to constrain \MP\ in a similar way.
2466 @d el_gordo 0x7fffffff /* $2^{31}-1$, the largest value that \MP\ likes */
2469 @ One of \MP's most common operations is the calculation of
2470 $\lfloor{a+b\over2}\rfloor$,
2471 the midpoint of two given integers |a| and~|b|. The most decent way to do
2472 this is to write `|(a+b)/2|'; but on many machines it is more efficient
2473 to calculate `|(a+b)>>1|'.
2475 Therefore the midpoint operation will always be denoted by `|half(a+b)|'
2476 in this program. If \MP\ is being implemented with languages that permit
2477 binary shifting, the |half| macro should be changed to make this operation
2478 as efficient as possible. Since some systems have shift operators that can
2479 only be trusted to work on positive numbers, there is also a macro |halfp|
2480 that is used only when the quantity being halved is known to be positive
2483 @d half(A) ((A) / 2)
2484 @d halfp(A) ((A) >> 1)
2486 @ A single computation might use several subroutine calls, and it is
2487 desirable to avoid producing multiple error messages in case of arithmetic
2488 overflow. So the routines below set the global variable |arith_error| to |true|
2489 instead of reporting errors directly to the user.
2490 @^overflow in arithmetic@>
2493 boolean arith_error; /* has arithmetic overflow occurred recently? */
2495 @ @<Allocate or ...@>=
2496 mp->arith_error=false;
2498 @ At crucial points the program will say |check_arith|, to test if
2499 an arithmetic error has been detected.
2501 @d check_arith { if ( mp->arith_error ) mp_clear_arith(mp); }
2504 void mp_clear_arith (MP mp) {
2505 print_err("Arithmetic overflow");
2506 @.Arithmetic overflow@>
2507 help4("Uh, oh. A little while ago one of the quantities that I was")
2508 ("computing got too large, so I'm afraid your answers will be")
2509 ("somewhat askew. You'll probably have to adopt different")
2510 ("tactics next time. But I shall try to carry on anyway.");
2512 mp->arith_error=false;
2515 @ Addition is not always checked to make sure that it doesn't overflow,
2516 but in places where overflow isn't too unlikely the |slow_add| routine
2519 @c integer mp_slow_add (MP mp,integer x, integer y) {
2521 if ( y<=el_gordo-x ) {
2524 mp->arith_error=true;
2527 } else if ( -y<=el_gordo+x ) {
2530 mp->arith_error=true;
2535 @ Fixed-point arithmetic is done on {\sl scaled integers\/} that are multiples
2536 of $2^{-16}$. In other words, a binary point is assumed to be sixteen bit
2537 positions from the right end of a binary computer word.
2539 @d quarter_unit 040000 /* $2^{14}$, represents 0.250000 */
2540 @d half_unit 0100000 /* $2^{15}$, represents 0.50000 */
2541 @d three_quarter_unit 0140000 /* $3\cdot2^{14}$, represents 0.75000 */
2542 @d unity 0200000 /* $2^{16}$, represents 1.00000 */
2543 @d two 0400000 /* $2^{17}$, represents 2.00000 */
2544 @d three 0600000 /* $2^{17}+2^{16}$, represents 3.00000 */
2547 typedef integer scaled; /* this type is used for scaled integers */
2548 typedef unsigned char small_number; /* this type is self-explanatory */
2550 @ The following function is used to create a scaled integer from a given decimal
2551 fraction $(.d_0d_1\ldots d_{k-1})$, where |0<=k<=17|. The digit $d_i$ is
2552 given in |dig[i]|, and the calculation produces a correctly rounded result.
2555 scaled mp_round_decimals (MP mp,small_number k) {
2556 /* converts a decimal fraction */
2557 integer a = 0; /* the accumulator */
2559 a=(a+mp->dig[k]*two) / 10;
2564 @ Conversely, here is a procedure analogous to |print_int|. If the output
2565 of this procedure is subsequently read by \MP\ and converted by the
2566 |round_decimals| routine above, it turns out that the original value will
2567 be reproduced exactly. A decimal point is printed only if the value is
2568 not an integer. If there is more than one way to print the result with
2569 the optimum number of digits following the decimal point, the closest
2570 possible value is given.
2572 The invariant relation in the \&{repeat} loop is that a sequence of
2573 decimal digits yet to be printed will yield the original number if and only if
2574 they form a fraction~$f$ in the range $s-\delta\L10\cdot2^{16}f<s$.
2575 We can stop if and only if $f=0$ satisfies this condition; the loop will
2576 terminate before $s$ can possibly become zero.
2578 @<Basic printing...@>=
2579 void mp_print_scaled (MP mp,scaled s) { /* prints scaled real, rounded to five digits */
2580 scaled delta; /* amount of allowable inaccuracy */
2582 mp_print_char(mp, '-');
2583 negate(s); /* print the sign, if negative */
2585 mp_print_int(mp, s / unity); /* print the integer part */
2589 mp_print_char(mp, '.');
2592 s=s+0100000-(delta / 2); /* round the final digit */
2593 mp_print_char(mp, '0'+(s / unity));
2600 @ We often want to print two scaled quantities in parentheses,
2601 separated by a comma.
2603 @<Basic printing...@>=
2604 void mp_print_two (MP mp,scaled x, scaled y) { /* prints `|(x,y)|' */
2605 mp_print_char(mp, '(');
2606 mp_print_scaled(mp, x);
2607 mp_print_char(mp, ',');
2608 mp_print_scaled(mp, y);
2609 mp_print_char(mp, ')');
2612 @ The |scaled| quantities in \MP\ programs are generally supposed to be
2613 less than $2^{12}$ in absolute value, so \MP\ does much of its internal
2614 arithmetic with 28~significant bits of precision. A |fraction| denotes
2615 a scaled integer whose binary point is assumed to be 28 bit positions
2618 @d fraction_half 01000000000 /* $2^{27}$, represents 0.50000000 */
2619 @d fraction_one 02000000000 /* $2^{28}$, represents 1.00000000 */
2620 @d fraction_two 04000000000 /* $2^{29}$, represents 2.00000000 */
2621 @d fraction_three 06000000000 /* $3\cdot2^{28}$, represents 3.00000000 */
2622 @d fraction_four 010000000000 /* $2^{30}$, represents 4.00000000 */
2625 typedef integer fraction; /* this type is used for scaled fractions */
2627 @ In fact, the two sorts of scaling discussed above aren't quite
2628 sufficient; \MP\ has yet another, used internally to keep track of angles
2629 in units of $2^{-20}$ degrees.
2631 @d forty_five_deg 0264000000 /* $45\cdot2^{20}$, represents $45^\circ$ */
2632 @d ninety_deg 0550000000 /* $90\cdot2^{20}$, represents $90^\circ$ */
2633 @d one_eighty_deg 01320000000 /* $180\cdot2^{20}$, represents $180^\circ$ */
2634 @d three_sixty_deg 02640000000 /* $360\cdot2^{20}$, represents $360^\circ$ */
2637 typedef integer angle; /* this type is used for scaled angles */
2639 @ The |make_fraction| routine produces the |fraction| equivalent of
2640 |p/q|, given integers |p| and~|q|; it computes the integer
2641 $f=\lfloor2^{28}p/q+{1\over2}\rfloor$, when $p$ and $q$ are
2642 positive. If |p| and |q| are both of the same scaled type |t|,
2643 the ``type relation'' |make_fraction(t,t)=fraction| is valid;
2644 and it's also possible to use the subroutine ``backwards,'' using
2645 the relation |make_fraction(t,fraction)=t| between scaled types.
2647 If the result would have magnitude $2^{31}$ or more, |make_fraction|
2648 sets |arith_error:=true|. Most of \MP's internal computations have
2649 been designed to avoid this sort of error.
2651 If this subroutine were programmed in assembly language on a typical
2652 machine, we could simply compute |(@t$2^{28}$@>*p)div q|, since a
2653 double-precision product can often be input to a fixed-point division
2654 instruction. But when we are restricted to int-eger arithmetic it
2655 is necessary either to resort to multiple-precision maneuvering
2656 or to use a simple but slow iteration. The multiple-precision technique
2657 would be about three times faster than the code adopted here, but it
2658 would be comparatively long and tricky, involving about sixteen
2659 additional multiplications and divisions.
2661 This operation is part of \MP's ``inner loop''; indeed, it will
2662 consume nearly 10\pct! of the running time (exclusive of input and output)
2663 if the code below is left unchanged. A machine-dependent recoding
2664 will therefore make \MP\ run faster. The present implementation
2665 is highly portable, but slow; it avoids multiplication and division
2666 except in the initial stage. System wizards should be careful to
2667 replace it with a routine that is guaranteed to produce identical
2668 results in all cases.
2669 @^system dependencies@>
2671 As noted below, a few more routines should also be replaced by machine-dependent
2672 code, for efficiency. But when a procedure is not part of the ``inner loop,''
2673 such changes aren't advisable; simplicity and robustness are
2674 preferable to trickery, unless the cost is too high.
2678 fraction mp_make_fraction (MP mp,integer p, integer q);
2679 integer mp_take_scaled (MP mp,integer q, scaled f) ;
2681 @ If FIXPT is not defined, we need these preprocessor values
2683 @d TWEXP31 2147483648.0
2684 @d TWEXP28 268435456.0
2686 @d TWEXP_16 (1.0/65536.0)
2687 @d TWEXP_28 (1.0/268435456.0)
2691 fraction mp_make_fraction (MP mp,integer p, integer q) {
2693 if ( q==0 ) mp_confusion(mp, "/");
2694 @:this can't happen /}{\quad \./@>
2697 integer f; /* the fraction bits, with a leading 1 bit */
2698 integer n; /* the integer part of $\vert p/q\vert$ */
2699 boolean negative = false; /* should the result be negated? */
2701 negate(p); negative=true;
2704 negate(q); negative = ! negative;
2708 mp->arith_error=true;
2709 i= ( negative ? -el_gordo : el_gordo);
2711 n=(n-1)*fraction_one;
2712 @<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>;
2713 i = (negative ? (-(f+n)) : (f+n));
2719 d = TWEXP28 * (double)p /(double)q;
2722 if (d>=TWEXP31) {mp->arith_error=true; return el_gordo;}
2724 if (d==i && ( ((q>0 ? -q : q)&077777)
2725 * (((i&037777)<<1)-1) & 04000)!=0) --i;
2728 if (d<= -TWEXP31) {mp->arith_error=true; return -el_gordo;}
2730 if (d==i && ( ((q>0 ? q : -q)&077777)
2731 * (((i&037777)<<1)+1) & 04000)!=0) ++i;
2738 @ The |repeat| loop here preserves the following invariant relations
2739 between |f|, |p|, and~|q|:
2740 (i)~|0<=p<q|; (ii)~$fq+p=2^k(q+p_0)$, where $k$ is an integer and
2741 $p_0$ is the original value of~$p$.
2743 Notice that the computation specifies
2744 |(p-q)+p| instead of |(p+p)-q|, because the latter could overflow.
2745 Let us hope that optimizing compilers do not miss this point; a
2746 special variable |be_careful| is used to emphasize the necessary
2747 order of computation. Optimizing compilers should keep |be_careful|
2748 in a register, not store it in memory.
2751 @<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>=
2753 integer be_careful; /* disables certain compiler optimizations */
2756 be_careful=p-q; p=be_careful+p;
2762 } while (f<fraction_one);
2764 if ( be_careful+p>=0 ) incr(f);
2767 @ The dual of |make_fraction| is |take_fraction|, which multiplies a
2768 given integer~|q| by a fraction~|f|. When the operands are positive, it
2769 computes $p=\lfloor qf/2^{28}+{1\over2}\rfloor$, a symmetric function
2772 This routine is even more ``inner loopy'' than |make_fraction|;
2773 the present implementation consumes almost 20\pct! of \MP's computation
2774 time during typical jobs, so a machine-language substitute is advisable.
2775 @^inner loop@> @^system dependencies@>
2778 integer mp_take_fraction (MP mp,integer q, fraction f) ;
2782 integer mp_take_fraction (MP mp,integer q, fraction f) {
2783 integer p; /* the fraction so far */
2784 boolean negative; /* should the result be negated? */
2785 integer n; /* additional multiple of $q$ */
2786 integer be_careful; /* disables certain compiler optimizations */
2787 @<Reduce to the case that |f>=0| and |q>=0|@>;
2788 if ( f<fraction_one ) {
2791 n=f / fraction_one; f=f % fraction_one;
2792 if ( q<=el_gordo / n ) {
2795 mp->arith_error=true; n=el_gordo;
2799 @<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>;
2800 be_careful=n-el_gordo;
2801 if ( be_careful+p>0 ){
2802 mp->arith_error=true; n=el_gordo-p;
2809 integer mp_take_fraction (MP mp,integer p, fraction q) {
2812 d = (double)p * (double)q * TWEXP_28;
2816 if (d!=TWEXP31 || (((p&077777)*(q&077777))&040000)==0)
2817 mp->arith_error = true;
2821 if (d==i && (((p&077777)*(q&077777))&040000)!=0) --i;
2825 if (d!= -TWEXP31 || ((-(p&077777)*(q&077777))&040000)==0)
2826 mp->arith_error = true;
2830 if (d==i && ((-(p&077777)*(q&077777))&040000)!=0) ++i;
2836 @ @<Reduce to the case that |f>=0| and |q>=0|@>=
2840 negate( f); negative=true;
2843 negate(q); negative=! negative;
2846 @ The invariant relations in this case are (i)~$\lfloor(qf+p)/2^k\rfloor
2847 =\lfloor qf_0/2^{28}+{1\over2}\rfloor$, where $k$ is an integer and
2848 $f_0$ is the original value of~$f$; (ii)~$2^k\L f<2^{k+1}$.
2851 @<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>=
2852 p=fraction_half; /* that's $2^{27}$; the invariants hold now with $k=28$ */
2853 if ( q<fraction_four ) {
2855 if ( odd(f) ) p=halfp(p+q); else p=halfp(p);
2860 if ( odd(f) ) p=p+halfp(q-p); else p=halfp(p);
2866 @ When we want to multiply something by a |scaled| quantity, we use a scheme
2867 analogous to |take_fraction| but with a different scaling.
2868 Given positive operands, |take_scaled|
2869 computes the quantity $p=\lfloor qf/2^{16}+{1\over2}\rfloor$.
2871 Once again it is a good idea to use a machine-language replacement if
2872 possible; otherwise |take_scaled| will use more than 2\pct! of the running time
2873 when the Computer Modern fonts are being generated.
2878 integer mp_take_scaled (MP mp,integer q, scaled f) {
2879 integer p; /* the fraction so far */
2880 boolean negative; /* should the result be negated? */
2881 integer n; /* additional multiple of $q$ */
2882 integer be_careful; /* disables certain compiler optimizations */
2883 @<Reduce to the case that |f>=0| and |q>=0|@>;
2887 n=f / unity; f=f % unity;
2888 if ( q<=el_gordo / n ) {
2891 mp->arith_error=true; n=el_gordo;
2895 @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>;
2896 be_careful=n-el_gordo;
2897 if ( be_careful+p>0 ) {
2898 mp->arith_error=true; n=el_gordo-p;
2900 return ( negative ?(-(n+p)) :(n+p));
2902 integer mp_take_scaled (MP mp,integer p, scaled q) {
2905 d = (double)p * (double)q * TWEXP_16;
2909 if (d!=TWEXP31 || (((p&077777)*(q&077777))&040000)==0)
2910 mp->arith_error = true;
2914 if (d==i && (((p&077777)*(q&077777))&040000)!=0) --i;
2918 if (d!= -TWEXP31 || ((-(p&077777)*(q&077777))&040000)==0)
2919 mp->arith_error = true;
2923 if (d==i && ((-(p&077777)*(q&077777))&040000)!=0) ++i;
2929 @ @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>=
2930 p=half_unit; /* that's $2^{15}$; the invariants hold now with $k=16$ */
2932 if ( q<fraction_four ) {
2934 p = (odd(f) ? halfp(p+q) : halfp(p));
2939 p = (odd(f) ? p+halfp(q-p) : halfp(p));
2944 @ For completeness, there's also |make_scaled|, which computes a
2945 quotient as a |scaled| number instead of as a |fraction|.
2946 In other words, the result is $\lfloor2^{16}p/q+{1\over2}\rfloor$, if the
2947 operands are positive. \ (This procedure is not used especially often,
2948 so it is not part of \MP's inner loop.)
2950 @<Internal library ...@>=
2951 scaled mp_make_scaled (MP mp,integer p, integer q) ;
2954 scaled mp_make_scaled (MP mp,integer p, integer q) {
2956 if ( q==0 ) mp_confusion(mp, "/");
2957 @:this can't happen /}{\quad \./@>
2960 integer f; /* the fraction bits, with a leading 1 bit */
2961 integer n; /* the integer part of $\vert p/q\vert$ */
2962 boolean negative; /* should the result be negated? */
2963 integer be_careful; /* disables certain compiler optimizations */
2964 if ( p>=0 ) negative=false;
2965 else { negate(p); negative=true; };
2967 negate(q); negative=! negative;
2971 mp->arith_error=true;
2972 return (negative ? (-el_gordo) : el_gordo);
2975 @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>;
2976 i = (negative ? (-(f+n)) :(f+n));
2980 d = TWEXP16 * (double)p /(double)q;
2983 if (d>=TWEXP31) {mp->arith_error=true; return el_gordo;}
2985 if (d==i && ( ((q>0 ? -q : q)&077777)
2986 * (((i&037777)<<1)-1) & 04000)!=0) --i;
2989 if (d<= -TWEXP31) {mp->arith_error=true; return -el_gordo;}
2991 if (d==i && ( ((q>0 ? q : -q)&077777)
2992 * (((i&037777)<<1)+1) & 04000)!=0) ++i;
2999 @ @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>=
3002 be_careful=p-q; p=be_careful+p;
3003 if ( p>=0 ) f=f+f+1;
3004 else { f+=f; p=p+q; };
3007 if ( be_careful+p>=0 ) incr(f)
3009 @ Here is a typical example of how the routines above can be used.
3010 It computes the function
3011 $${1\over3\tau}f(\theta,\phi)=
3012 {\tau^{-1}\bigl(2+\sqrt2\,(\sin\theta-{1\over16}\sin\phi)
3013 (\sin\phi-{1\over16}\sin\theta)(\cos\theta-\cos\phi)\bigr)\over
3014 3\,\bigl(1+{1\over2}(\sqrt5-1)\cos\theta+{1\over2}(3-\sqrt5\,)\cos\phi\bigr)},$$
3015 where $\tau$ is a |scaled| ``tension'' parameter. This is \MP's magic
3016 fudge factor for placing the first control point of a curve that starts
3017 at an angle $\theta$ and ends at an angle $\phi$ from the straight path.
3018 (Actually, if the stated quantity exceeds 4, \MP\ reduces it to~4.)
3020 The trigonometric quantity to be multiplied by $\sqrt2$ is less than $\sqrt2$.
3021 (It's a sum of eight terms whose absolute values can be bounded using
3022 relations such as $\sin\theta\cos\theta\L{1\over2}$.) Thus the numerator
3023 is positive; and since the tension $\tau$ is constrained to be at least
3024 $3\over4$, the numerator is less than $16\over3$. The denominator is
3025 nonnegative and at most~6. Hence the fixed-point calculations below
3026 are guaranteed to stay within the bounds of a 32-bit computer word.
3028 The angles $\theta$ and $\phi$ are given implicitly in terms of |fraction|
3029 arguments |st|, |ct|, |sf|, and |cf|, representing $\sin\theta$, $\cos\theta$,
3030 $\sin\phi$, and $\cos\phi$, respectively.
3033 fraction mp_velocity (MP mp,fraction st, fraction ct, fraction sf,
3034 fraction cf, scaled t) {
3035 integer acc,num,denom; /* registers for intermediate calculations */
3036 acc=mp_take_fraction(mp, st-(sf / 16), sf-(st / 16));
3037 acc=mp_take_fraction(mp, acc,ct-cf);
3038 num=fraction_two+mp_take_fraction(mp, acc,379625062);
3039 /* $2^{28}\sqrt2\approx379625062.497$ */
3040 denom=fraction_three+mp_take_fraction(mp, ct,497706707)+mp_take_fraction(mp, cf,307599661);
3041 /* $3\cdot2^{27}\cdot(\sqrt5-1)\approx497706706.78$ and
3042 $3\cdot2^{27}\cdot(3-\sqrt5\,)\approx307599661.22$ */
3043 if ( t!=unity ) num=mp_make_scaled(mp, num,t);
3044 /* |make_scaled(fraction,scaled)=fraction| */
3045 if ( num / 4>=denom )
3046 return fraction_four;
3048 return mp_make_fraction(mp, num, denom);
3051 @ The following somewhat different subroutine tests rigorously if $ab$ is
3052 greater than, equal to, or less than~$cd$,
3053 given integers $(a,b,c,d)$. In most cases a quick decision is reached.
3054 The result is $+1$, 0, or~$-1$ in the three respective cases.
3056 @d mp_ab_vs_cd(M,A,B,C,D) mp_do_ab_vs_cd(A,B,C,D)
3059 integer mp_do_ab_vs_cd (integer a,integer b, integer c, integer d) {
3060 integer q,r; /* temporary registers */
3061 @<Reduce to the case that |a,c>=0|, |b,d>0|@>;
3063 q = a / d; r = c / b;
3065 return ( q>r ? 1 : -1);
3066 q = a % d; r = c % b;
3069 if ( q==0 ) return -1;
3071 } /* now |a>d>0| and |c>b>0| */
3074 @ @<Reduce to the case that |a...@>=
3075 if ( a<0 ) { negate(a); negate(b); };
3076 if ( c<0 ) { negate(c); negate(d); };
3079 if ( (a==0||b==0)&&(c==0||d==0) ) return 0;
3083 return ( a==0 ? 0 : -1);
3084 q=a; a=c; c=q; q=-b; b=-d; d=q;
3085 } else if ( b<=0 ) {
3086 if ( b<0 ) if ( a>0 ) return -1;
3087 return (c==0 ? 0 : -1);
3090 @ We conclude this set of elementary routines with some simple rounding
3091 and truncation operations.
3093 @<Internal library declarations@>=
3094 #define mp_floor_scaled(M,i) ((i)&(-65536))
3095 #define mp_round_unscaled(M,i) (((i>>15)+1)>>1)
3096 #define mp_round_fraction(M,i) (((i>>11)+1)>>1)
3099 @* \[8] Algebraic and transcendental functions.
3100 \MP\ computes all of the necessary special functions from scratch, without
3101 relying on |real| arithmetic or system subroutines for sines, cosines, etc.
3103 @ To get the square root of a |scaled| number |x|, we want to calculate
3104 $s=\lfloor 2^8\!\sqrt x +{1\over2}\rfloor$. If $x>0$, this is the unique
3105 integer such that $2^{16}x-s\L s^2<2^{16}x+s$. The following subroutine
3106 determines $s$ by an iterative method that maintains the invariant
3107 relations $x=2^{46-2k}x_0\bmod 2^{30}$, $0<y=\lfloor 2^{16-2k}x_0\rfloor
3108 -s^2+s\L q=2s$, where $x_0$ is the initial value of $x$. The value of~$y$
3109 might, however, be zero at the start of the first iteration.
3112 scaled mp_square_rt (MP mp,scaled x) ;
3115 scaled mp_square_rt (MP mp,scaled x) {
3116 small_number k; /* iteration control counter */
3117 integer y,q; /* registers for intermediate calculations */
3119 @<Handle square root of zero or negative argument@>;
3122 while ( x<fraction_two ) { /* i.e., |while x<@t$2^{29}$@>|\unskip */
3125 if ( x<fraction_four ) y=0;
3126 else { x=x-fraction_four; y=1; };
3128 @<Decrease |k| by 1, maintaining the invariant
3129 relations between |x|, |y|, and~|q|@>;
3135 @ @<Handle square root of zero...@>=
3138 print_err("Square root of ");
3139 @.Square root...replaced by 0@>
3140 mp_print_scaled(mp, x); mp_print(mp, " has been replaced by 0");
3141 help2("Since I don't take square roots of negative numbers,")
3142 ("I'm zeroing this one. Proceed, with fingers crossed.");
3148 @ @<Decrease |k| by 1, maintaining...@>=
3150 if ( x>=fraction_four ) { /* note that |fraction_four=@t$2^{30}$@>| */
3151 x=x-fraction_four; incr(y);
3153 x+=x; y=y+y-q; q+=q;
3154 if ( x>=fraction_four ) { x=x-fraction_four; incr(y); };
3155 if ( y>q ){ y=y-q; q=q+2; }
3156 else if ( y<=0 ) { q=q-2; y=y+q; };
3159 @ Pythagorean addition $\psqrt{a^2+b^2}$ is implemented by an elegant
3160 iterative scheme due to Cleve Moler and Donald Morrison [{\sl IBM Journal
3161 @^Moler, Cleve Barry@>
3162 @^Morrison, Donald Ross@>
3163 of Research and Development\/ \bf27} (1983), 577--581]. It modifies |a| and~|b|
3164 in such a way that their Pythagorean sum remains invariant, while the
3165 smaller argument decreases.
3167 @<Internal library ...@>=
3168 integer mp_pyth_add (MP mp,integer a, integer b);
3172 integer mp_pyth_add (MP mp,integer a, integer b) {
3173 fraction r; /* register used to transform |a| and |b| */
3174 boolean big; /* is the result dangerously near $2^{31}$? */
3176 if ( a<b ) { r=b; b=a; a=r; }; /* now |0<=b<=a| */
3178 if ( a<fraction_two ) {
3181 a=a / 4; b=b / 4; big=true;
3182 }; /* we reduced the precision to avoid arithmetic overflow */
3183 @<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>;
3185 if ( a<fraction_two ) {
3188 mp->arith_error=true; a=el_gordo;
3195 @ The key idea here is to reflect the vector $(a,b)$ about the
3196 line through $(a,b/2)$.
3198 @<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>=
3200 r=mp_make_fraction(mp, b,a);
3201 r=mp_take_fraction(mp, r,r); /* now $r\approx b^2/a^2$ */
3203 r=mp_make_fraction(mp, r,fraction_four+r);
3204 a=a+mp_take_fraction(mp, a+a,r); b=mp_take_fraction(mp, b,r);
3208 @ Here is a similar algorithm for $\psqrt{a^2-b^2}$.
3209 It converges slowly when $b$ is near $a$, but otherwise it works fine.
3212 integer mp_pyth_sub (MP mp,integer a, integer b) {
3213 fraction r; /* register used to transform |a| and |b| */
3214 boolean big; /* is the input dangerously near $2^{31}$? */
3217 @<Handle erroneous |pyth_sub| and set |a:=0|@>;
3219 if ( a<fraction_four ) {
3222 a=halfp(a); b=halfp(b); big=true;
3224 @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>;
3225 if ( big ) double(a);
3230 @ @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>=
3232 r=mp_make_fraction(mp, b,a);
3233 r=mp_take_fraction(mp, r,r); /* now $r\approx b^2/a^2$ */
3235 r=mp_make_fraction(mp, r,fraction_four-r);
3236 a=a-mp_take_fraction(mp, a+a,r); b=mp_take_fraction(mp, b,r);
3239 @ @<Handle erroneous |pyth_sub| and set |a:=0|@>=
3242 print_err("Pythagorean subtraction "); mp_print_scaled(mp, a);
3243 mp_print(mp, "+-+"); mp_print_scaled(mp, b);
3244 mp_print(mp, " has been replaced by 0");
3246 help2("Since I don't take square roots of negative numbers,")
3247 ("I'm zeroing this one. Proceed, with fingers crossed.");
3253 @ The subroutines for logarithm and exponential involve two tables.
3254 The first is simple: |two_to_the[k]| equals $2^k$. The second involves
3255 a bit more calculation, which the author claims to have done correctly:
3256 |spec_log[k]| is $2^{27}$ times $\ln\bigl(1/(1-2^{-k})\bigr)=
3257 2^{-k}+{1\over2}2^{-2k}+{1\over3}2^{-3k}+\cdots\,$, rounded to the
3260 @d two_to_the(A) (1<<(A))
3263 static const integer spec_log[29] = { 0, /* special logarithms */
3264 93032640, 38612034, 17922280, 8662214, 4261238, 2113709,
3265 1052693, 525315, 262400, 131136, 65552, 32772, 16385,
3266 8192, 4096, 2048, 1024, 512, 256, 128, 64, 32, 16, 8, 4, 2, 1, 1 };
3268 @ @<Local variables for initialization@>=
3269 integer k; /* all-purpose loop index */
3272 @ Here is the routine that calculates $2^8$ times the natural logarithm
3273 of a |scaled| quantity; it is an integer approximation to $2^{24}\ln(x/2^{16})$,
3274 when |x| is a given positive integer.
3276 The method is based on exercise 1.2.2--25 in {\sl The Art of Computer
3277 Programming\/}: During the main iteration we have $1\L 2^{-30}x<1/(1-2^{1-k})$,
3278 and the logarithm of $2^{30}x$ remains to be added to an accumulator
3279 register called~$y$. Three auxiliary bits of accuracy are retained in~$y$
3280 during the calculation, and sixteen auxiliary bits to extend |y| are
3281 kept in~|z| during the initial argument reduction. (We add
3282 $100\cdot2^{16}=6553600$ to~|z| and subtract 100 from~|y| so that |z| will
3283 not become negative; also, the actual amount subtracted from~|y| is~96,
3284 not~100, because we want to add~4 for rounding before the final division by~8.)
3287 scaled mp_m_log (MP mp,scaled x) {
3288 integer y,z; /* auxiliary registers */
3289 integer k; /* iteration counter */
3291 @<Handle non-positive logarithm@>;
3293 y=1302456956+4-100; /* $14\times2^{27}\ln2\approx1302456956.421063$ */
3294 z=27595+6553600; /* and $2^{16}\times .421063\approx 27595$ */
3295 while ( x<fraction_four ) {
3296 double(x); y-=93032639; z-=48782;
3297 } /* $2^{27}\ln2\approx 93032639.74436163$ and $2^{16}\times.74436163\approx 48782$ */
3298 y=y+(z / unity); k=2;
3299 while ( x>fraction_four+4 ) {
3300 @<Increase |k| until |x| can be multiplied by a
3301 factor of $2^{-k}$, and adjust $y$ accordingly@>;
3307 @ @<Increase |k| until |x| can...@>=
3309 z=((x-1) / two_to_the(k))+1; /* $z=\lceil x/2^k\rceil$ */
3310 while ( x<fraction_four+z ) { z=halfp(z+1); incr(k); };
3311 y+=spec_log[k]; x-=z;
3314 @ @<Handle non-positive logarithm@>=
3316 print_err("Logarithm of ");
3317 @.Logarithm...replaced by 0@>
3318 mp_print_scaled(mp, x); mp_print(mp, " has been replaced by 0");
3319 help2("Since I don't take logs of non-positive numbers,")
3320 ("I'm zeroing this one. Proceed, with fingers crossed.");
3325 @ Conversely, the exponential routine calculates $\exp(x/2^8)$,
3326 when |x| is |scaled|. The result is an integer approximation to
3327 $2^{16}\exp(x/2^{24})$, when |x| is regarded as an integer.
3330 scaled mp_m_exp (MP mp,scaled x) {
3331 small_number k; /* loop control index */
3332 integer y,z; /* auxiliary registers */
3333 if ( x>174436200 ) {
3334 /* $2^{24}\ln((2^{31}-1)/2^{16})\approx 174436199.51$ */
3335 mp->arith_error=true;
3337 } else if ( x<-197694359 ) {
3338 /* $2^{24}\ln(2^{-1}/2^{16})\approx-197694359.45$ */
3342 z=-8*x; y=04000000; /* $y=2^{20}$ */
3344 if ( x<=127919879 ) {
3346 /* $2^{27}\ln((2^{31}-1)/2^{20})\approx 1023359037.125$ */
3348 z=8*(174436200-x); /* |z| is always nonnegative */
3352 @<Multiply |y| by $\exp(-z/2^{27})$@>;
3354 return ((y+8) / 16);
3360 @ The idea here is that subtracting |spec_log[k]| from |z| corresponds
3361 to multiplying |y| by $1-2^{-k}$.
3363 A subtle point (which had to be checked) was that if $x=127919879$, the
3364 value of~|y| will decrease so that |y+8| doesn't overflow. In fact,
3365 $z$ will be 5 in this case, and |y| will decrease by~64 when |k=25|
3366 and by~16 when |k=27|.
3368 @<Multiply |y| by...@>=
3371 while ( z>=spec_log[k] ) {
3373 y=y-1-((y-two_to_the(k-1)) / two_to_the(k));
3378 @ The trigonometric subroutines use an auxiliary table such that
3379 |spec_atan[k]| contains an approximation to the |angle| whose tangent
3380 is~$1/2^k$. $\arctan2^{-k}$ times $2^{20}\cdot180/\pi$
3383 static const angle spec_atan[27] = { 0, 27855475, 14718068, 7471121, 3750058,
3384 1876857, 938658, 469357, 234682, 117342, 58671, 29335, 14668, 7334, 3667,
3385 1833, 917, 458, 229, 115, 57, 29, 14, 7, 4, 2, 1 };
3387 @ Given integers |x| and |y|, not both zero, the |n_arg| function
3388 returns the |angle| whose tangent points in the direction $(x,y)$.
3389 This subroutine first determines the correct octant, then solves the
3390 problem for |0<=y<=x|, then converts the result appropriately to
3391 return an answer in the range |-one_eighty_deg<=@t$\theta$@><=one_eighty_deg|.
3392 (The answer is |+one_eighty_deg| if |y=0| and |x<0|, but an answer of
3393 |-one_eighty_deg| is possible if, for example, |y=-1| and $x=-2^{30}$.)
3395 The octants are represented in a ``Gray code,'' since that turns out
3396 to be computationally simplest.
3402 @d second_octant (first_octant+switch_x_and_y)
3403 @d third_octant (first_octant+switch_x_and_y+negate_x)
3404 @d fourth_octant (first_octant+negate_x)
3405 @d fifth_octant (first_octant+negate_x+negate_y)
3406 @d sixth_octant (first_octant+switch_x_and_y+negate_x+negate_y)
3407 @d seventh_octant (first_octant+switch_x_and_y+negate_y)
3408 @d eighth_octant (first_octant+negate_y)
3411 angle mp_n_arg (MP mp,integer x, integer y) {
3412 angle z; /* auxiliary register */
3413 integer t; /* temporary storage */
3414 small_number k; /* loop counter */
3415 int octant; /* octant code */
3417 octant=first_octant;
3419 negate(x); octant=first_octant+negate_x;
3422 negate(y); octant=octant+negate_y;
3425 t=y; y=x; x=t; octant=octant+switch_x_and_y;
3428 @<Handle undefined arg@>;
3430 @<Set variable |z| to the arg of $(x,y)$@>;
3431 @<Return an appropriate answer based on |z| and |octant|@>;
3435 @ @<Handle undefined arg@>=
3437 print_err("angle(0,0) is taken as zero");
3438 @.angle(0,0)...zero@>
3439 help2("The `angle' between two identical points is undefined.")
3440 ("I'm zeroing this one. Proceed, with fingers crossed.");
3445 @ @<Return an appropriate answer...@>=
3447 case first_octant: return z;
3448 case second_octant: return (ninety_deg-z);
3449 case third_octant: return (ninety_deg+z);
3450 case fourth_octant: return (one_eighty_deg-z);
3451 case fifth_octant: return (z-one_eighty_deg);
3452 case sixth_octant: return (-z-ninety_deg);
3453 case seventh_octant: return (z-ninety_deg);
3454 case eighth_octant: return (-z);
3455 }; /* there are no other cases */
3458 @ At this point we have |x>=y>=0|, and |x>0|. The numbers are scaled up
3459 or down until $2^{28}\L x<2^{29}$, so that accurate fixed-point calculations
3462 @<Set variable |z| to the arg...@>=
3463 while ( x>=fraction_two ) {
3464 x=halfp(x); y=halfp(y);
3468 while ( x<fraction_one ) {
3471 @<Increase |z| to the arg of $(x,y)$@>;
3474 @ During the calculations of this section, variables |x| and~|y|
3475 represent actual coordinates $(x,2^{-k}y)$. We will maintain the
3476 condition |x>=y|, so that the tangent will be at most $2^{-k}$.
3477 If $x<2y$, the tangent is greater than $2^{-k-1}$. The transformation
3478 $(a,b)\mapsto(a+b\tan\phi,b-a\tan\phi)$ replaces $(a,b)$ by
3479 coordinates whose angle has decreased by~$\phi$; in the special case
3480 $a=x$, $b=2^{-k}y$, and $\tan\phi=2^{-k-1}$, this operation reduces
3481 to the particularly simple iteration shown here. [Cf.~John E. Meggitt,
3482 @^Meggitt, John E.@>
3483 {\sl IBM Journal of Research and Development\/ \bf6} (1962), 210--226.]
3485 The initial value of |x| will be multiplied by at most
3486 $(1+{1\over2})(1+{1\over8})(1+{1\over32})\cdots\approx 1.7584$; hence
3487 there is no chance of integer overflow.
3489 @<Increase |z|...@>=
3494 z=z+spec_atan[k]; t=x; x=x+(y / two_to_the(k+k)); y=y-t;
3499 if ( y>x ) { z=z+spec_atan[k]; y=y-x; };
3502 @ Conversely, the |n_sin_cos| routine takes an |angle| and produces the sine
3503 and cosine of that angle. The results of this routine are
3504 stored in global integer variables |n_sin| and |n_cos|.
3507 fraction n_sin;fraction n_cos; /* results computed by |n_sin_cos| */
3509 @ Given an integer |z| that is $2^{20}$ times an angle $\theta$ in degrees,
3510 the purpose of |n_sin_cos(z)| is to set
3511 |x=@t$r\cos\theta$@>| and |y=@t$r\sin\theta$@>| (approximately),
3512 for some rather large number~|r|. The maximum of |x| and |y|
3513 will be between $2^{28}$ and $2^{30}$, so that there will be hardly
3514 any loss of accuracy. Then |x| and~|y| are divided by~|r|.
3517 void mp_n_sin_cos (MP mp,angle z) { /* computes a multiple of the sine
3519 small_number k; /* loop control variable */
3520 int q; /* specifies the quadrant */
3521 fraction r; /* magnitude of |(x,y)| */
3522 integer x,y,t; /* temporary registers */
3523 while ( z<0 ) z=z+three_sixty_deg;
3524 z=z % three_sixty_deg; /* now |0<=z<three_sixty_deg| */
3525 q=z / forty_five_deg; z=z % forty_five_deg;
3526 x=fraction_one; y=x;
3527 if ( ! odd(q) ) z=forty_five_deg-z;
3528 @<Subtract angle |z| from |(x,y)|@>;
3529 @<Convert |(x,y)| to the octant determined by~|q|@>;
3530 r=mp_pyth_add(mp, x,y);
3531 mp->n_cos=mp_make_fraction(mp, x,r);
3532 mp->n_sin=mp_make_fraction(mp, y,r);
3535 @ In this case the octants are numbered sequentially.
3537 @<Convert |(x,...@>=
3540 case 1: t=x; x=y; y=t; break;
3541 case 2: t=x; x=-y; y=t; break;
3542 case 3: negate(x); break;
3543 case 4: negate(x); negate(y); break;
3544 case 5: t=x; x=-y; y=-t; break;
3545 case 6: t=x; x=y; y=-t; break;
3546 case 7: negate(y); break;
3547 } /* there are no other cases */
3549 @ The main iteration of |n_sin_cos| is similar to that of |n_arg| but
3550 applied in reverse. The values of |spec_atan[k]| decrease slowly enough
3551 that this loop is guaranteed to terminate before the (nonexistent) value
3552 |spec_atan[27]| would be required.
3554 @<Subtract angle |z|...@>=
3557 if ( z>=spec_atan[k] ) {
3558 z=z-spec_atan[k]; t=x;
3559 x=t+y / two_to_the(k);
3560 y=y-t / two_to_the(k);
3564 if ( y<0 ) y=0 /* this precaution may never be needed */
3566 @ And now let's complete our collection of numeric utility routines
3567 by considering random number generation.
3568 \MP\ generates pseudo-random numbers with the additive scheme recommended
3569 in Section 3.6 of {\sl The Art of Computer Programming}; however, the
3570 results are random fractions between 0 and |fraction_one-1|, inclusive.
3572 There's an auxiliary array |randoms| that contains 55 pseudo-random
3573 fractions. Using the recurrence $x_n=(x_{n-55}-x_{n-31})\bmod 2^{28}$,
3574 we generate batches of 55 new $x_n$'s at a time by calling |new_randoms|.
3575 The global variable |j_random| tells which element has most recently
3577 The global variable |random_seed| was introduced in version 0.9,
3578 for the sole reason of stressing the fact that the initial value of the
3579 random seed is system-dependant. The initialization code below will initialize
3580 this variable to |(internal[mp_time] div unity)+internal[mp_day]|, but this
3581 is not good enough on modern fast machines that are capable of running
3582 multiple MetaPost processes within the same second.
3583 @^system dependencies@>
3586 fraction randoms[55]; /* the last 55 random values generated */
3587 int j_random; /* the number of unused |randoms| */
3589 @ @<Option variables@>=
3590 int random_seed; /* the default random seed */
3592 @ @<Allocate or initialize ...@>=
3593 mp->random_seed = (scaled)opt->random_seed;
3595 @ To consume a random fraction, the program below will say `|next_random|'
3596 and then it will fetch |randoms[j_random]|.
3598 @d next_random { if ( mp->j_random==0 ) mp_new_randoms(mp);
3599 else decr(mp->j_random); }
3602 void mp_new_randoms (MP mp) {
3603 int k; /* index into |randoms| */
3604 fraction x; /* accumulator */
3605 for (k=0;k<=23;k++) {
3606 x=mp->randoms[k]-mp->randoms[k+31];
3607 if ( x<0 ) x=x+fraction_one;
3610 for (k=24;k<= 54;k++){
3611 x=mp->randoms[k]-mp->randoms[k-24];
3612 if ( x<0 ) x=x+fraction_one;
3619 void mp_init_randoms (MP mp,scaled seed);
3621 @ To initialize the |randoms| table, we call the following routine.
3624 void mp_init_randoms (MP mp,scaled seed) {
3625 fraction j,jj,k; /* more or less random integers */
3626 int i; /* index into |randoms| */
3628 while ( j>=fraction_one ) j=halfp(j);
3630 for (i=0;i<=54;i++ ){
3632 if ( k<0 ) k=k+fraction_one;
3633 mp->randoms[(i*21)% 55]=j;
3637 mp_new_randoms(mp); /* ``warm up'' the array */
3640 @ To produce a uniform random number in the range |0<=u<x| or |0>=u>x|
3641 or |0=u=x|, given a |scaled| value~|x|, we proceed as shown here.
3643 Note that the call of |take_fraction| will produce the values 0 and~|x|
3644 with about half the probability that it will produce any other particular
3645 values between 0 and~|x|, because it rounds its answers.
3648 scaled mp_unif_rand (MP mp,scaled x) {
3649 scaled y; /* trial value */
3650 next_random; y=mp_take_fraction(mp, abs(x),mp->randoms[mp->j_random]);
3651 if ( y==abs(x) ) return 0;
3652 else if ( x>0 ) return y;
3656 @ Finally, a normal deviate with mean zero and unit standard deviation
3657 can readily be obtained with the ratio method (Algorithm 3.4.1R in
3658 {\sl The Art of Computer Programming\/}).
3661 scaled mp_norm_rand (MP mp) {
3662 integer x,u,l; /* what the book would call $2^{16}X$, $2^{28}U$, and $-2^{24}\ln U$ */
3666 x=mp_take_fraction(mp, 112429,mp->randoms[mp->j_random]-fraction_half);
3667 /* $2^{16}\sqrt{8/e}\approx 112428.82793$ */
3668 next_random; u=mp->randoms[mp->j_random];
3669 } while (abs(x)>=u);
3670 x=mp_make_fraction(mp, x,u);
3671 l=139548960-mp_m_log(mp, u); /* $2^{24}\cdot12\ln2\approx139548959.6165$ */
3672 } while (mp_ab_vs_cd(mp, 1024,l,x,x)<0);
3676 @* \[9] Packed data.
3677 In order to make efficient use of storage space, \MP\ bases its major data
3678 structures on a |memory_word|, which contains either a (signed) integer,
3679 possibly scaled, or a small number of fields that are one half or one
3680 quarter of the size used for storing integers.
3682 If |x| is a variable of type |memory_word|, it contains up to four
3683 fields that can be referred to as follows:
3684 $$\vbox{\halign{\hfil#&#\hfil&#\hfil\cr
3685 |x|&.|int|&(an |integer|)\cr
3686 |x|&.|sc|\qquad&(a |scaled| integer)\cr
3687 |x.hh.lh|, |x.hh|&.|rh|&(two halfword fields)\cr
3688 |x.hh.b0|, |x.hh.b1|, |x.hh|&.|rh|&(two quarterword fields, one halfword
3690 |x.qqqq.b0|, |x.qqqq.b1|, |x.qqqq|&.|b2|, |x.qqqq.b3|\hskip-100pt
3691 &\qquad\qquad\qquad(four quarterword fields)\cr}}$$
3692 This is somewhat cumbersome to write, and not very readable either, but
3693 macros will be used to make the notation shorter and more transparent.
3694 The code below gives a formal definition of |memory_word| and
3695 its subsidiary types, using packed variant records. \MP\ makes no
3696 assumptions about the relative positions of the fields within a word.
3698 @d max_quarterword 0x3FFF /* largest allowable value in a |quarterword| */
3699 @d max_halfword 0xFFFFFFF /* largest allowable value in a |halfword| */
3701 @ Here are the inequalities that the quarterword and halfword values
3702 must satisfy (or rather, the inequalities that they mustn't satisfy):
3704 @<Check the ``constant''...@>=
3705 if (mp->ini_version) {
3706 if ( mp->mem_max!=mp->mem_top ) mp->bad=8;
3708 if ( mp->mem_max<mp->mem_top ) mp->bad=8;
3710 if ( mp->mem_max>=max_halfword ) mp->bad=12;
3711 if ( mp->max_strings>max_halfword ) mp->bad=13;
3713 @ The macros |qi| and |qo| are used for input to and output
3714 from quarterwords. These are legacy macros.
3715 @^system dependencies@>
3717 @d qo(A) (A) /* to read eight bits from a quarterword */
3718 @d qi(A) (A) /* to store eight bits in a quarterword */
3720 @ The reader should study the following definitions closely:
3721 @^system dependencies@>
3723 @d sc cint /* |scaled| data is equivalent to |integer| */
3726 typedef short quarterword; /* 1/4 of a word */
3727 typedef int halfword; /* 1/2 of a word */
3732 struct { /* Make B0,B1 overlap the most significant bytes of LH. */
3739 quarterword B2, B3, B0, B1;
3754 @ When debugging, we may want to print a |memory_word| without knowing
3755 what type it is; so we print it in all modes.
3759 void mp_print_word (MP mp,memory_word w) {
3760 /* prints |w| in all ways */
3761 mp_print_int(mp, w.cint); mp_print_char(mp, ' ');
3762 mp_print_scaled(mp, w.sc); mp_print_char(mp, ' ');
3763 mp_print_scaled(mp, w.sc / 010000); mp_print_ln(mp);
3764 mp_print_int(mp, w.hh.lh); mp_print_char(mp, '=');
3765 mp_print_int(mp, w.hh.b0); mp_print_char(mp, ':');
3766 mp_print_int(mp, w.hh.b1); mp_print_char(mp, ';');
3767 mp_print_int(mp, w.hh.rh); mp_print_char(mp, ' ');
3768 mp_print_int(mp, w.qqqq.b0); mp_print_char(mp, ':');
3769 mp_print_int(mp, w.qqqq.b1); mp_print_char(mp, ':');
3770 mp_print_int(mp, w.qqqq.b2); mp_print_char(mp, ':');
3771 mp_print_int(mp, w.qqqq.b3);
3775 @* \[10] Dynamic memory allocation.
3777 The \MP\ system does nearly all of its own memory allocation, so that it
3778 can readily be transported into environments that do not have automatic
3779 facilities for strings, garbage collection, etc., and so that it can be in
3780 control of what error messages the user receives. The dynamic storage
3781 requirements of \MP\ are handled by providing a large array |mem| in
3782 which consecutive blocks of words are used as nodes by the \MP\ routines.
3784 Pointer variables are indices into this array, or into another array
3785 called |eqtb| that will be explained later. A pointer variable might
3786 also be a special flag that lies outside the bounds of |mem|, so we
3787 allow pointers to assume any |halfword| value. The minimum memory
3788 index represents a null pointer.
3790 @d null 0 /* the null pointer */
3791 @d mp_void (null+1) /* a null pointer different from |null| */
3795 typedef halfword pointer; /* a flag or a location in |mem| or |eqtb| */
3797 @ The |mem| array is divided into two regions that are allocated separately,
3798 but the dividing line between these two regions is not fixed; they grow
3799 together until finding their ``natural'' size in a particular job.
3800 Locations less than or equal to |lo_mem_max| are used for storing
3801 variable-length records consisting of two or more words each. This region
3802 is maintained using an algorithm similar to the one described in exercise
3803 2.5--19 of {\sl The Art of Computer Programming}. However, no size field
3804 appears in the allocated nodes; the program is responsible for knowing the
3805 relevant size when a node is freed. Locations greater than or equal to
3806 |hi_mem_min| are used for storing one-word records; a conventional
3807 \.{AVAIL} stack is used for allocation in this region.
3809 Locations of |mem| between |0| and |mem_top| may be dumped as part
3810 of preloaded mem files, by the \.{INIMP} preprocessor.
3812 Production versions of \MP\ may extend the memory at the top end in order to
3813 provide more space; these locations, between |mem_top| and |mem_max|,
3814 are always used for single-word nodes.
3816 The key pointers that govern |mem| allocation have a prescribed order:
3817 $$\hbox{|null=0<lo_mem_max<hi_mem_min<mem_top<=mem_end<=mem_max|.}$$
3820 memory_word *mem; /* the big dynamic storage area */
3821 pointer lo_mem_max; /* the largest location of variable-size memory in use */
3822 pointer hi_mem_min; /* the smallest location of one-word memory in use */
3826 @d xfree(A) do { mp_xfree(A); A=NULL; } while (0)
3827 @d xrealloc(P,A,B) mp_xrealloc(mp,P,A,B)
3828 @d xmalloc(A,B) mp_xmalloc(mp,A,B)
3829 @d xstrdup(A) mp_xstrdup(mp,A)
3830 @d XREALLOC(a,b,c) a = xrealloc(a,(b+1),sizeof(c));
3832 @<Declare helpers@>=
3833 void mp_xfree (void *x);
3834 void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size) ;
3835 void *mp_xmalloc (MP mp, size_t nmem, size_t size) ;
3836 char *mp_xstrdup(MP mp, const char *s);
3837 void mp_do_snprintf(char *str, int size, const char *fmt, ...);
3839 @ The |max_size_test| guards against overflow, on the assumption that
3840 |size_t| is at least 31bits wide.
3842 @d max_size_test 0x7FFFFFFF
3845 void mp_xfree (void *x) {
3846 if (x!=NULL) free(x);
3848 void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size) {
3850 if ((max_size_test/size)<nmem) {
3851 do_fprintf(mp->err_out,"Memory size overflow!\n");
3852 mp->history =mp_fatal_error_stop; mp_jump_out(mp);
3854 w = realloc (p,(nmem*size));
3856 do_fprintf(mp->err_out,"Out of memory!\n");
3857 mp->history =mp_system_error_stop; mp_jump_out(mp);
3861 void *mp_xmalloc (MP mp, size_t nmem, size_t size) {
3863 if ((max_size_test/size)<nmem) {
3864 do_fprintf(mp->err_out,"Memory size overflow!\n");
3865 mp->history =mp_fatal_error_stop; mp_jump_out(mp);
3867 w = malloc (nmem*size);
3869 do_fprintf(mp->err_out,"Out of memory!\n");
3870 mp->history =mp_system_error_stop; mp_jump_out(mp);
3874 char *mp_xstrdup(MP mp, const char *s) {
3880 do_fprintf(mp->err_out,"Out of memory!\n");
3881 mp->history =mp_system_error_stop; mp_jump_out(mp);
3886 @ @<Internal library declarations@>=
3887 #ifdef HAVE_SNPRINTF
3888 #define mp_snprintf (void)snprintf
3890 #define mp_snprintf mp_do_snprintf
3893 @ This internal version is rather stupid, but good enough for its purpose.
3896 void mp_do_snprintf (char *str, int size, const char *format, ...) {
3901 work = (char *)workbuf;
3902 va_start(ap, format);
3904 for (fmt=format;*fmt!='\0';fmt++) {
3910 char *s = va_arg(ap, char *);
3913 if (size-->0) res++;
3920 sprintf(work,"%i",va_arg(ap, int));
3923 if (size-->0) res++;
3929 sprintf(work,"%g",va_arg(ap, double));
3932 if (size-->0) res++;
3938 if (size-->0) res++;
3946 if (size-->0) res++;
3954 @<Allocate or initialize ...@>=
3955 mp->mem = xmalloc ((mp->mem_max+1),sizeof (memory_word));
3956 memset(mp->mem,0,(mp->mem_max+1)*sizeof (memory_word));
3958 @ @<Dealloc variables@>=
3961 @ Users who wish to study the memory requirements of particular applications can
3962 can use optional special features that keep track of current and
3963 maximum memory usage. When code between the delimiters |stat| $\ldots$
3964 |tats| is not ``commented out,'' \MP\ will run a bit slower but it will
3965 report these statistics when |mp_tracing_stats| is positive.
3968 integer var_used; integer dyn_used; /* how much memory is in use */
3970 @ Let's consider the one-word memory region first, since it's the
3971 simplest. The pointer variable |mem_end| holds the highest-numbered location
3972 of |mem| that has ever been used. The free locations of |mem| that
3973 occur between |hi_mem_min| and |mem_end|, inclusive, are of type
3974 |two_halves|, and we write |info(p)| and |link(p)| for the |lh|
3975 and |rh| fields of |mem[p]| when it is of this type. The single-word
3976 free locations form a linked list
3977 $$|avail|,\;\hbox{|link(avail)|},\;\hbox{|link(link(avail))|},\;\ldots$$
3978 terminated by |null|.
3980 @d link(A) mp->mem[(A)].hh.rh /* the |link| field of a memory word */
3981 @d info(A) mp->mem[(A)].hh.lh /* the |info| field of a memory word */
3984 pointer avail; /* head of the list of available one-word nodes */
3985 pointer mem_end; /* the last one-word node used in |mem| */
3987 @ If one-word memory is exhausted, it might mean that the user has forgotten
3988 a token like `\&{enddef}' or `\&{endfor}'. We will define some procedures
3989 later that try to help pinpoint the trouble.
3992 @<Declare the procedure called |show_token_list|@>
3993 @<Declare the procedure called |runaway|@>
3995 @ The function |get_avail| returns a pointer to a new one-word node whose
3996 |link| field is null. However, \MP\ will halt if there is no more room left.
4000 pointer mp_get_avail (MP mp) { /* single-word node allocation */
4001 pointer p; /* the new node being got */
4002 p=mp->avail; /* get top location in the |avail| stack */
4004 mp->avail=link(mp->avail); /* and pop it off */
4005 } else if ( mp->mem_end<mp->mem_max ) { /* or go into virgin territory */
4006 incr(mp->mem_end); p=mp->mem_end;
4008 decr(mp->hi_mem_min); p=mp->hi_mem_min;
4009 if ( mp->hi_mem_min<=mp->lo_mem_max ) {
4010 mp_runaway(mp); /* if memory is exhausted, display possible runaway text */
4011 mp_overflow(mp, "main memory size",mp->mem_max);
4012 /* quit; all one-word nodes are busy */
4013 @:MetaPost capacity exceeded main memory size}{\quad main memory size@>
4016 link(p)=null; /* provide an oft-desired initialization of the new node */
4017 incr(mp->dyn_used);/* maintain statistics */
4021 @ Conversely, a one-word node is recycled by calling |free_avail|.
4023 @d free_avail(A) /* single-word node liberation */
4024 { link((A))=mp->avail; mp->avail=(A); decr(mp->dyn_used); }
4026 @ There's also a |fast_get_avail| routine, which saves the procedure-call
4027 overhead at the expense of extra programming. This macro is used in
4028 the places that would otherwise account for the most calls of |get_avail|.
4031 @d fast_get_avail(A) {
4032 (A)=mp->avail; /* avoid |get_avail| if possible, to save time */
4033 if ( (A)==null ) { (A)=mp_get_avail(mp); }
4034 else { mp->avail=link((A)); link((A))=null; incr(mp->dyn_used); }
4037 @ The available-space list that keeps track of the variable-size portion
4038 of |mem| is a nonempty, doubly-linked circular list of empty nodes,
4039 pointed to by the roving pointer |rover|.
4041 Each empty node has size 2 or more; the first word contains the special
4042 value |max_halfword| in its |link| field and the size in its |info| field;
4043 the second word contains the two pointers for double linking.
4045 Each nonempty node also has size 2 or more. Its first word is of type
4046 |two_halves|\kern-1pt, and its |link| field is never equal to |max_halfword|.
4047 Otherwise there is complete flexibility with respect to the contents
4048 of its other fields and its other words.
4050 (We require |mem_max<max_halfword| because terrible things can happen
4051 when |max_halfword| appears in the |link| field of a nonempty node.)
4053 @d empty_flag max_halfword /* the |link| of an empty variable-size node */
4054 @d is_empty(A) (link((A))==empty_flag) /* tests for empty node */
4055 @d node_size info /* the size field in empty variable-size nodes */
4056 @d llink(A) info((A)+1) /* left link in doubly-linked list of empty nodes */
4057 @d rlink(A) link((A)+1) /* right link in doubly-linked list of empty nodes */
4060 pointer rover; /* points to some node in the list of empties */
4062 @ A call to |get_node| with argument |s| returns a pointer to a new node
4063 of size~|s|, which must be 2~or more. The |link| field of the first word
4064 of this new node is set to null. An overflow stop occurs if no suitable
4067 If |get_node| is called with $s=2^{30}$, it simply merges adjacent free
4068 areas and returns the value |max_halfword|.
4070 @<Internal library declarations@>=
4071 pointer mp_get_node (MP mp,integer s) ;
4074 pointer mp_get_node (MP mp,integer s) { /* variable-size node allocation */
4075 pointer p; /* the node currently under inspection */
4076 pointer q; /* the node physically after node |p| */
4077 integer r; /* the newly allocated node, or a candidate for this honor */
4078 integer t,tt; /* temporary registers */
4081 p=mp->rover; /* start at some free node in the ring */
4083 @<Try to allocate within node |p| and its physical successors,
4084 and |goto found| if allocation was possible@>;
4085 if (rlink(p)==null || (rlink(p)==p && p!=mp->rover)) {
4086 print_err("Free list garbled");
4087 help3("I found an entry in the list of free nodes that links")
4088 ("badly. I will try to ignore the broken link, but something")
4089 ("is seriously amiss. It is wise to warn the maintainers.")
4093 p=rlink(p); /* move to the next node in the ring */
4094 } while (p!=mp->rover); /* repeat until the whole list has been traversed */
4095 if ( s==010000000000 ) {
4096 return max_halfword;
4098 if ( mp->lo_mem_max+2<mp->hi_mem_min ) {
4099 if ( mp->lo_mem_max+2<=max_halfword ) {
4100 @<Grow more variable-size memory and |goto restart|@>;
4103 mp_overflow(mp, "main memory size",mp->mem_max);
4104 /* sorry, nothing satisfactory is left */
4105 @:MetaPost capacity exceeded main memory size}{\quad main memory size@>
4107 link(r)=null; /* this node is now nonempty */
4108 mp->var_used+=s; /* maintain usage statistics */
4112 @ The lower part of |mem| grows by 1000 words at a time, unless
4113 we are very close to going under. When it grows, we simply link
4114 a new node into the available-space list. This method of controlled
4115 growth helps to keep the |mem| usage consecutive when \MP\ is
4116 implemented on ``virtual memory'' systems.
4119 @<Grow more variable-size memory and |goto restart|@>=
4121 if ( mp->hi_mem_min-mp->lo_mem_max>=1998 ) {
4122 t=mp->lo_mem_max+1000;
4124 t=mp->lo_mem_max+1+(mp->hi_mem_min-mp->lo_mem_max) / 2;
4125 /* |lo_mem_max+2<=t<hi_mem_min| */
4127 if ( t>max_halfword ) t=max_halfword;
4128 p=llink(mp->rover); q=mp->lo_mem_max; rlink(p)=q; llink(mp->rover)=q;
4129 rlink(q)=mp->rover; llink(q)=p; link(q)=empty_flag;
4130 node_size(q)=t-mp->lo_mem_max;
4131 mp->lo_mem_max=t; link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null;
4136 @ @<Try to allocate...@>=
4137 q=p+node_size(p); /* find the physical successor */
4138 while ( is_empty(q) ) { /* merge node |p| with node |q| */
4139 t=rlink(q); tt=llink(q);
4141 if ( q==mp->rover ) mp->rover=t;
4142 llink(t)=tt; rlink(tt)=t;
4147 @<Allocate from the top of node |p| and |goto found|@>;
4150 if ( rlink(p)!=p ) {
4151 @<Allocate entire node |p| and |goto found|@>;
4154 node_size(p)=q-p /* reset the size in case it grew */
4156 @ @<Allocate from the top...@>=
4158 node_size(p)=r-p; /* store the remaining size */
4159 mp->rover=p; /* start searching here next time */
4163 @ Here we delete node |p| from the ring, and let |rover| rove around.
4165 @<Allocate entire...@>=
4167 mp->rover=rlink(p); t=llink(p);
4168 llink(mp->rover)=t; rlink(t)=mp->rover;
4172 @ Conversely, when some variable-size node |p| of size |s| is no longer needed,
4173 the operation |free_node(p,s)| will make its words available, by inserting
4174 |p| as a new empty node just before where |rover| now points.
4176 @<Internal library declarations@>=
4177 void mp_free_node (MP mp, pointer p, halfword s) ;
4180 void mp_free_node (MP mp, pointer p, halfword s) { /* variable-size node
4182 pointer q; /* |llink(rover)| */
4183 node_size(p)=s; link(p)=empty_flag;
4185 q=llink(mp->rover); llink(p)=q; rlink(p)=mp->rover; /* set both links */
4186 llink(mp->rover)=p; rlink(q)=p; /* insert |p| into the ring */
4187 mp->var_used-=s; /* maintain statistics */
4190 @ Just before \.{INIMP} writes out the memory, it sorts the doubly linked
4191 available space list. The list is probably very short at such times, so a
4192 simple insertion sort is used. The smallest available location will be
4193 pointed to by |rover|, the next-smallest by |rlink(rover)|, etc.
4196 void mp_sort_avail (MP mp) { /* sorts the available variable-size nodes
4198 pointer p,q,r; /* indices into |mem| */
4199 pointer old_rover; /* initial |rover| setting */
4200 p=mp_get_node(mp, 010000000000); /* merge adjacent free areas */
4201 p=rlink(mp->rover); rlink(mp->rover)=max_halfword; old_rover=mp->rover;
4202 while ( p!=old_rover ) {
4203 @<Sort |p| into the list starting at |rover|
4204 and advance |p| to |rlink(p)|@>;
4207 while ( rlink(p)!=max_halfword ) {
4208 llink(rlink(p))=p; p=rlink(p);
4210 rlink(p)=mp->rover; llink(mp->rover)=p;
4213 @ The following |while| loop is guaranteed to
4214 terminate, since the list that starts at
4215 |rover| ends with |max_halfword| during the sorting procedure.
4218 if ( p<mp->rover ) {
4219 q=p; p=rlink(q); rlink(q)=mp->rover; mp->rover=q;
4222 while ( rlink(q)<p ) q=rlink(q);
4223 r=rlink(p); rlink(p)=rlink(q); rlink(q)=p; p=r;
4226 @* \[11] Memory layout.
4227 Some areas of |mem| are dedicated to fixed usage, since static allocation is
4228 more efficient than dynamic allocation when we can get away with it. For
4229 example, locations |0| to |1| are always used to store a
4230 two-word dummy token whose second word is zero.
4231 The following macro definitions accomplish the static allocation by giving
4232 symbolic names to the fixed positions. Static variable-size nodes appear
4233 in locations |0| through |lo_mem_stat_max|, and static single-word nodes
4234 appear in locations |hi_mem_stat_min| through |mem_top|, inclusive.
4236 @d null_dash (2) /* the first two words are reserved for a null value */
4237 @d dep_head (null_dash+3) /* we will define |dash_node_size=3| */
4238 @d zero_val (dep_head+2) /* two words for a permanently zero value */
4239 @d temp_val (zero_val+2) /* two words for a temporary value node */
4240 @d end_attr temp_val /* we use |end_attr+2| only */
4241 @d inf_val (end_attr+2) /* and |inf_val+1| only */
4242 @d test_pen (inf_val+2)
4243 /* nine words for a pen used when testing the turning number */
4244 @d bad_vardef (test_pen+9) /* two words for \&{vardef} error recovery */
4245 @d lo_mem_stat_max (bad_vardef+1) /* largest statically
4246 allocated word in the variable-size |mem| */
4248 @d sentinel mp->mem_top /* end of sorted lists */
4249 @d temp_head (mp->mem_top-1) /* head of a temporary list of some kind */
4250 @d hold_head (mp->mem_top-2) /* head of a temporary list of another kind */
4251 @d spec_head (mp->mem_top-3) /* head of a list of unprocessed \&{special} items */
4252 @d hi_mem_stat_min (mp->mem_top-3) /* smallest statically allocated word in
4253 the one-word |mem| */
4255 @ The following code gets the dynamic part of |mem| off to a good start,
4256 when \MP\ is initializing itself the slow way.
4258 @<Initialize table entries (done by \.{INIMP} only)@>=
4259 mp->rover=lo_mem_stat_max+1; /* initialize the dynamic memory */
4260 link(mp->rover)=empty_flag;
4261 node_size(mp->rover)=1000; /* which is a 1000-word available node */
4262 llink(mp->rover)=mp->rover; rlink(mp->rover)=mp->rover;
4263 mp->lo_mem_max=mp->rover+1000;
4264 link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null;
4265 for (k=hi_mem_stat_min;k<=(int)mp->mem_top;k++) {
4266 mp->mem[k]=mp->mem[mp->lo_mem_max]; /* clear list heads */
4268 mp->avail=null; mp->mem_end=mp->mem_top;
4269 mp->hi_mem_min=hi_mem_stat_min; /* initialize the one-word memory */
4270 mp->var_used=lo_mem_stat_max+1;
4271 mp->dyn_used=mp->mem_top+1-(hi_mem_stat_min); /* initialize statistics */
4272 @<Initialize a pen at |test_pen| so that it fits in nine words@>;
4274 @ The procedure |flush_list(p)| frees an entire linked list of one-word
4275 nodes that starts at a given position, until coming to |sentinel| or a
4276 pointer that is not in the one-word region. Another procedure,
4277 |flush_node_list|, frees an entire linked list of one-word and two-word
4278 nodes, until coming to a |null| pointer.
4282 void mp_flush_list (MP mp,pointer p) { /* makes list of single-word nodes available */
4283 pointer q,r; /* list traversers */
4284 if ( p>=mp->hi_mem_min ) if ( p!=sentinel ) {
4289 if ( r<mp->hi_mem_min ) break;
4290 } while (r!=sentinel);
4291 /* now |q| is the last node on the list */
4292 link(q)=mp->avail; mp->avail=p;
4296 void mp_flush_node_list (MP mp,pointer p) {
4297 pointer q; /* the node being recycled */
4300 if ( q<mp->hi_mem_min )
4301 mp_free_node(mp, q,2);
4307 @ If \MP\ is extended improperly, the |mem| array might get screwed up.
4308 For example, some pointers might be wrong, or some ``dead'' nodes might not
4309 have been freed when the last reference to them disappeared. Procedures
4310 |check_mem| and |search_mem| are available to help diagnose such
4311 problems. These procedures make use of two arrays called |free| and
4312 |was_free| that are present only if \MP's debugging routines have
4313 been included. (You may want to decrease the size of |mem| while you
4317 Because |boolean|s are typedef-d as ints, it is better to use
4318 unsigned chars here.
4321 unsigned char *free; /* free cells */
4322 unsigned char *was_free; /* previously free cells */
4323 pointer was_mem_end; pointer was_lo_max; pointer was_hi_min;
4324 /* previous |mem_end|, |lo_mem_max|,and |hi_mem_min| */
4325 boolean panicking; /* do we want to check memory constantly? */
4327 @ @<Allocate or initialize ...@>=
4328 mp->free = xmalloc ((mp->mem_max+1),sizeof (unsigned char));
4329 mp->was_free = xmalloc ((mp->mem_max+1), sizeof (unsigned char));
4331 @ @<Dealloc variables@>=
4333 xfree(mp->was_free);
4335 @ @<Allocate or ...@>=
4336 mp->was_hi_min=mp->mem_max;
4337 mp->panicking=false;
4339 @ @<Declare |mp_reallocate| functions@>=
4340 void mp_reallocate_memory(MP mp, int l) ;
4343 void mp_reallocate_memory(MP mp, int l) {
4344 XREALLOC(mp->free, l, unsigned char);
4345 XREALLOC(mp->was_free, l, unsigned char);
4347 int newarea = l-mp->mem_max;
4348 XREALLOC(mp->mem, l, memory_word);
4349 memset (mp->mem+(mp->mem_max+1),0,sizeof(memory_word)*(newarea));
4351 XREALLOC(mp->mem, l, memory_word);
4352 memset(mp->mem,0,sizeof(memory_word)*(l+1));
4355 if (mp->ini_version)
4361 @ Procedure |check_mem| makes sure that the available space lists of
4362 |mem| are well formed, and it optionally prints out all locations
4363 that are reserved now but were free the last time this procedure was called.
4366 void mp_check_mem (MP mp,boolean print_locs ) {
4367 pointer p,q,r; /* current locations of interest in |mem| */
4368 boolean clobbered; /* is something amiss? */
4369 for (p=0;p<=mp->lo_mem_max;p++) {
4370 mp->free[p]=false; /* you can probably do this faster */
4372 for (p=mp->hi_mem_min;p<= mp->mem_end;p++) {
4373 mp->free[p]=false; /* ditto */
4375 @<Check single-word |avail| list@>;
4376 @<Check variable-size |avail| list@>;
4377 @<Check flags of unavailable nodes@>;
4378 @<Check the list of linear dependencies@>;
4380 @<Print newly busy locations@>;
4382 memcpy(mp->was_free,mp->free, sizeof(char)*(mp->mem_end+1));
4383 mp->was_mem_end=mp->mem_end;
4384 mp->was_lo_max=mp->lo_mem_max;
4385 mp->was_hi_min=mp->hi_mem_min;
4388 @ @<Check single-word...@>=
4389 p=mp->avail; q=null; clobbered=false;
4391 if ( (p>mp->mem_end)||(p<mp->hi_mem_min) ) clobbered=true;
4392 else if ( mp->free[p] ) clobbered=true;
4394 mp_print_nl(mp, "AVAIL list clobbered at ");
4395 @.AVAIL list clobbered...@>
4396 mp_print_int(mp, q); break;
4398 mp->free[p]=true; q=p; p=link(q);
4401 @ @<Check variable-size...@>=
4402 p=mp->rover; q=null; clobbered=false;
4404 if ( (p>=mp->lo_mem_max)||(p<0) ) clobbered=true;
4405 else if ( (rlink(p)>=mp->lo_mem_max)||(rlink(p)<0) ) clobbered=true;
4406 else if ( !(is_empty(p))||(node_size(p)<2)||
4407 (p+node_size(p)>mp->lo_mem_max)|| (llink(rlink(p))!=p) ) clobbered=true;
4409 mp_print_nl(mp, "Double-AVAIL list clobbered at ");
4410 @.Double-AVAIL list clobbered...@>
4411 mp_print_int(mp, q); break;
4413 for (q=p;q<=p+node_size(p)-1;q++) { /* mark all locations free */
4414 if ( mp->free[q] ) {
4415 mp_print_nl(mp, "Doubly free location at ");
4416 @.Doubly free location...@>
4417 mp_print_int(mp, q); break;
4422 } while (p!=mp->rover)
4425 @ @<Check flags...@>=
4427 while ( p<=mp->lo_mem_max ) { /* node |p| should not be empty */
4428 if ( is_empty(p) ) {
4429 mp_print_nl(mp, "Bad flag at "); mp_print_int(mp, p);
4432 while ( (p<=mp->lo_mem_max) && ! mp->free[p] ) incr(p);
4433 while ( (p<=mp->lo_mem_max) && mp->free[p] ) incr(p);
4436 @ @<Print newly busy...@>=
4438 @<Do intialization required before printing new busy locations@>;
4439 mp_print_nl(mp, "New busy locs:");
4441 for (p=0;p<= mp->lo_mem_max;p++ ) {
4442 if ( ! mp->free[p] && ((p>mp->was_lo_max) || mp->was_free[p]) ) {
4443 @<Indicate that |p| is a new busy location@>;
4446 for (p=mp->hi_mem_min;p<=mp->mem_end;p++ ) {
4447 if ( ! mp->free[p] &&
4448 ((p<mp->was_hi_min) || (p>mp->was_mem_end) || mp->was_free[p]) ) {
4449 @<Indicate that |p| is a new busy location@>;
4452 @<Finish printing new busy locations@>;
4455 @ There might be many new busy locations so we are careful to print contiguous
4456 blocks compactly. During this operation |q| is the last new busy location and
4457 |r| is the start of the block containing |q|.
4459 @<Indicate that |p| is a new busy location@>=
4463 mp_print(mp, ".."); mp_print_int(mp, q);
4465 mp_print_char(mp, ' '); mp_print_int(mp, p);
4471 @ @<Do intialization required before printing new busy locations@>=
4472 q=mp->mem_max; r=mp->mem_max
4474 @ @<Finish printing new busy locations@>=
4476 mp_print(mp, ".."); mp_print_int(mp, q);
4479 @ The |search_mem| procedure attempts to answer the question ``Who points
4480 to node~|p|?'' In doing so, it fetches |link| and |info| fields of |mem|
4481 that might not be of type |two_halves|. Strictly speaking, this is
4482 undefined, and it can lead to ``false drops'' (words that seem to
4483 point to |p| purely by coincidence). But for debugging purposes, we want
4484 to rule out the places that do {\sl not\/} point to |p|, so a few false
4485 drops are tolerable.
4488 void mp_search_mem (MP mp, pointer p) { /* look for pointers to |p| */
4489 integer q; /* current position being searched */
4490 for (q=0;q<=mp->lo_mem_max;q++) {
4492 mp_print_nl(mp, "LINK("); mp_print_int(mp, q); mp_print_char(mp, ')');
4495 mp_print_nl(mp, "INFO("); mp_print_int(mp, q); mp_print_char(mp, ')');
4498 for (q=mp->hi_mem_min;q<=mp->mem_end;q++) {
4500 mp_print_nl(mp, "LINK("); mp_print_int(mp, q); mp_print_char(mp, ')');
4503 mp_print_nl(mp, "INFO("); mp_print_int(mp, q); mp_print_char(mp, ')');
4506 @<Search |eqtb| for equivalents equal to |p|@>;
4509 @* \[12] The command codes.
4510 Before we can go much further, we need to define symbolic names for the internal
4511 code numbers that represent the various commands obeyed by \MP. These codes
4512 are somewhat arbitrary, but not completely so. For example,
4513 some codes have been made adjacent so that |case| statements in the
4514 program need not consider cases that are widely spaced, or so that |case|
4515 statements can be replaced by |if| statements. A command can begin an
4516 expression if and only if its code lies between |min_primary_command| and
4517 |max_primary_command|, inclusive. The first token of a statement that doesn't
4518 begin with an expression has a command code between |min_command| and
4519 |max_statement_command|, inclusive. Anything less than |min_command| is
4520 eliminated during macro expansions, and anything no more than |max_pre_command|
4521 is eliminated when expanding \TeX\ material. Ranges such as
4522 |min_secondary_command..max_secondary_command| are used when parsing
4523 expressions, but the relative ordering within such a range is generally not
4526 The ordering of the highest-numbered commands
4527 (|comma<semicolon<end_group<stop|) is crucial for the parsing and
4528 error-recovery methods of this program as is the ordering |if_test<fi_or_else|
4529 for the smallest two commands. The ordering is also important in the ranges
4530 |numeric_token..plus_or_minus| and |left_brace..ampersand|.
4532 At any rate, here is the list, for future reference.
4534 @d start_tex 1 /* begin \TeX\ material (\&{btex}, \&{verbatimtex}) */
4535 @d etex_marker 2 /* end \TeX\ material (\&{etex}) */
4536 @d mpx_break 3 /* stop reading an \.{MPX} file (\&{mpxbreak}) */
4537 @d max_pre_command mpx_break
4538 @d if_test 4 /* conditional text (\&{if}) */
4539 @d fi_or_else 5 /* delimiters for conditionals (\&{elseif}, \&{else}, \&{fi}) */
4540 @d input 6 /* input a source file (\&{input}, \&{endinput}) */
4541 @d iteration 7 /* iterate (\&{for}, \&{forsuffixes}, \&{forever}, \&{endfor}) */
4542 @d repeat_loop 8 /* special command substituted for \&{endfor} */
4543 @d exit_test 9 /* premature exit from a loop (\&{exitif}) */
4544 @d relax 10 /* do nothing (\.{\char`\\}) */
4545 @d scan_tokens 11 /* put a string into the input buffer */
4546 @d expand_after 12 /* look ahead one token */
4547 @d defined_macro 13 /* a macro defined by the user */
4548 @d min_command (defined_macro+1)
4549 @d save_command 14 /* save a list of tokens (\&{save}) */
4550 @d interim_command 15 /* save an internal quantity (\&{interim}) */
4551 @d let_command 16 /* redefine a symbolic token (\&{let}) */
4552 @d new_internal 17 /* define a new internal quantity (\&{newinternal}) */
4553 @d macro_def 18 /* define a macro (\&{def}, \&{vardef}, etc.) */
4554 @d ship_out_command 19 /* output a character (\&{shipout}) */
4555 @d add_to_command 20 /* add to edges (\&{addto}) */
4556 @d bounds_command 21 /* add bounding path to edges (\&{setbounds}, \&{clip}) */
4557 @d tfm_command 22 /* command for font metric info (\&{ligtable}, etc.) */
4558 @d protection_command 23 /* set protection flag (\&{outer}, \&{inner}) */
4559 @d show_command 24 /* diagnostic output (\&{show}, \&{showvariable}, etc.) */
4560 @d mode_command 25 /* set interaction level (\&{batchmode}, etc.) */
4561 @d mp_random_seed 26 /* initialize random number generator (\&{randomseed}) */
4562 @d message_command 27 /* communicate to user (\&{message}, \&{errmessage}) */
4563 @d every_job_command 28 /* designate a starting token (\&{everyjob}) */
4564 @d delimiters 29 /* define a pair of delimiters (\&{delimiters}) */
4565 @d special_command 30 /* output special info (\&{special})
4566 or font map info (\&{fontmapfile}, \&{fontmapline}) */
4567 @d write_command 31 /* write text to a file (\&{write}) */
4568 @d type_name 32 /* declare a type (\&{numeric}, \&{pair}, etc.) */
4569 @d max_statement_command type_name
4570 @d min_primary_command type_name
4571 @d left_delimiter 33 /* the left delimiter of a matching pair */
4572 @d begin_group 34 /* beginning of a group (\&{begingroup}) */
4573 @d nullary 35 /* an operator without arguments (e.g., \&{normaldeviate}) */
4574 @d unary 36 /* an operator with one argument (e.g., \&{sqrt}) */
4575 @d str_op 37 /* convert a suffix to a string (\&{str}) */
4576 @d cycle 38 /* close a cyclic path (\&{cycle}) */
4577 @d primary_binary 39 /* binary operation taking `\&{of}' (e.g., \&{point}) */
4578 @d capsule_token 40 /* a value that has been put into a token list */
4579 @d string_token 41 /* a string constant (e.g., |"hello"|) */
4580 @d internal_quantity 42 /* internal numeric parameter (e.g., \&{pausing}) */
4581 @d min_suffix_token internal_quantity
4582 @d tag_token 43 /* a symbolic token without a primitive meaning */
4583 @d numeric_token 44 /* a numeric constant (e.g., \.{3.14159}) */
4584 @d max_suffix_token numeric_token
4585 @d plus_or_minus 45 /* either `\.+' or `\.-' */
4586 @d max_primary_command plus_or_minus /* should also be |numeric_token+1| */
4587 @d min_tertiary_command plus_or_minus
4588 @d tertiary_secondary_macro 46 /* a macro defined by \&{secondarydef} */
4589 @d tertiary_binary 47 /* an operator at the tertiary level (e.g., `\.{++}') */
4590 @d max_tertiary_command tertiary_binary
4591 @d left_brace 48 /* the operator `\.{\char`\{}' */
4592 @d min_expression_command left_brace
4593 @d path_join 49 /* the operator `\.{..}' */
4594 @d ampersand 50 /* the operator `\.\&' */
4595 @d expression_tertiary_macro 51 /* a macro defined by \&{tertiarydef} */
4596 @d expression_binary 52 /* an operator at the expression level (e.g., `\.<') */
4597 @d equals 53 /* the operator `\.=' */
4598 @d max_expression_command equals
4599 @d and_command 54 /* the operator `\&{and}' */
4600 @d min_secondary_command and_command
4601 @d secondary_primary_macro 55 /* a macro defined by \&{primarydef} */
4602 @d slash 56 /* the operator `\./' */
4603 @d secondary_binary 57 /* an operator at the binary level (e.g., \&{shifted}) */
4604 @d max_secondary_command secondary_binary
4605 @d param_type 58 /* type of parameter (\&{primary}, \&{expr}, \&{suffix}, etc.) */
4606 @d controls 59 /* specify control points explicitly (\&{controls}) */
4607 @d tension 60 /* specify tension between knots (\&{tension}) */
4608 @d at_least 61 /* bounded tension value (\&{atleast}) */
4609 @d curl_command 62 /* specify curl at an end knot (\&{curl}) */
4610 @d macro_special 63 /* special macro operators (\&{quote}, \.{\#\AT!}, etc.) */
4611 @d right_delimiter 64 /* the right delimiter of a matching pair */
4612 @d left_bracket 65 /* the operator `\.[' */
4613 @d right_bracket 66 /* the operator `\.]' */
4614 @d right_brace 67 /* the operator `\.{\char`\}}' */
4615 @d with_option 68 /* option for filling (\&{withpen}, \&{withweight}, etc.) */
4617 /* variant of \&{addto} (\&{contour}, \&{doublepath}, \&{also}) */
4618 @d of_token 70 /* the operator `\&{of}' */
4619 @d to_token 71 /* the operator `\&{to}' */
4620 @d step_token 72 /* the operator `\&{step}' */
4621 @d until_token 73 /* the operator `\&{until}' */
4622 @d within_token 74 /* the operator `\&{within}' */
4623 @d lig_kern_token 75
4624 /* the operators `\&{kern}' and `\.{=:}' and `\.{=:\char'174}', etc. */
4625 @d assignment 76 /* the operator `\.{:=}' */
4626 @d skip_to 77 /* the operation `\&{skipto}' */
4627 @d bchar_label 78 /* the operator `\.{\char'174\char'174:}' */
4628 @d double_colon 79 /* the operator `\.{::}' */
4629 @d colon 80 /* the operator `\.:' */
4631 @d comma 81 /* the operator `\.,', must be |colon+1| */
4632 @d end_of_statement (mp->cur_cmd>comma)
4633 @d semicolon 82 /* the operator `\.;', must be |comma+1| */
4634 @d end_group 83 /* end a group (\&{endgroup}), must be |semicolon+1| */
4635 @d stop 84 /* end a job (\&{end}, \&{dump}), must be |end_group+1| */
4636 @d max_command_code stop
4637 @d outer_tag (max_command_code+1) /* protection code added to command code */
4640 typedef int command_code;
4642 @ Variables and capsules in \MP\ have a variety of ``types,''
4643 distinguished by the code numbers defined here. These numbers are also
4644 not completely arbitrary. Things that get expanded must have types
4645 |>mp_independent|; a type remaining after expansion is numeric if and only if
4646 its code number is at least |numeric_type|; objects containing numeric
4647 parts must have types between |transform_type| and |pair_type|;
4648 all other types must be smaller than |transform_type|; and among the types
4649 that are not unknown or vacuous, the smallest two must be |boolean_type|
4650 and |string_type| in that order.
4652 @d undefined 0 /* no type has been declared */
4653 @d unknown_tag 1 /* this constant is added to certain type codes below */
4654 @d unknown_types mp_unknown_boolean: case mp_unknown_string:
4655 case mp_unknown_pen: case mp_unknown_picture: case mp_unknown_path
4658 enum mp_variable_type {
4659 mp_vacuous=1, /* no expression was present */
4660 mp_boolean_type, /* \&{boolean} with a known value */
4662 mp_string_type, /* \&{string} with a known value */
4664 mp_pen_type, /* \&{pen} with a known value */
4666 mp_path_type, /* \&{path} with a known value */
4668 mp_picture_type, /* \&{picture} with a known value */
4670 mp_transform_type, /* \&{transform} variable or capsule */
4671 mp_color_type, /* \&{color} variable or capsule */
4672 mp_cmykcolor_type, /* \&{cmykcolor} variable or capsule */
4673 mp_pair_type, /* \&{pair} variable or capsule */
4674 mp_numeric_type, /* variable that has been declared \&{numeric} but not used */
4675 mp_known, /* \&{numeric} with a known value */
4676 mp_dependent, /* a linear combination with |fraction| coefficients */
4677 mp_proto_dependent, /* a linear combination with |scaled| coefficients */
4678 mp_independent, /* \&{numeric} with unknown value */
4679 mp_token_list, /* variable name or suffix argument or text argument */
4680 mp_structured, /* variable with subscripts and attributes */
4681 mp_unsuffixed_macro, /* variable defined with \&{vardef} but no \.{\AT!\#} */
4682 mp_suffixed_macro /* variable defined with \&{vardef} and \.{\AT!\#} */
4686 void mp_print_type (MP mp,small_number t) ;
4688 @ @<Basic printing procedures@>=
4689 void mp_print_type (MP mp,small_number t) {
4691 case mp_vacuous:mp_print(mp, "mp_vacuous"); break;
4692 case mp_boolean_type:mp_print(mp, "boolean"); break;
4693 case mp_unknown_boolean:mp_print(mp, "unknown boolean"); break;
4694 case mp_string_type:mp_print(mp, "string"); break;
4695 case mp_unknown_string:mp_print(mp, "unknown string"); break;
4696 case mp_pen_type:mp_print(mp, "pen"); break;
4697 case mp_unknown_pen:mp_print(mp, "unknown pen"); break;
4698 case mp_path_type:mp_print(mp, "path"); break;
4699 case mp_unknown_path:mp_print(mp, "unknown path"); break;
4700 case mp_picture_type:mp_print(mp, "picture"); break;
4701 case mp_unknown_picture:mp_print(mp, "unknown picture"); break;
4702 case mp_transform_type:mp_print(mp, "transform"); break;
4703 case mp_color_type:mp_print(mp, "color"); break;
4704 case mp_cmykcolor_type:mp_print(mp, "cmykcolor"); break;
4705 case mp_pair_type:mp_print(mp, "pair"); break;
4706 case mp_known:mp_print(mp, "known numeric"); break;
4707 case mp_dependent:mp_print(mp, "dependent"); break;
4708 case mp_proto_dependent:mp_print(mp, "proto-dependent"); break;
4709 case mp_numeric_type:mp_print(mp, "numeric"); break;
4710 case mp_independent:mp_print(mp, "independent"); break;
4711 case mp_token_list:mp_print(mp, "token list"); break;
4712 case mp_structured:mp_print(mp, "mp_structured"); break;
4713 case mp_unsuffixed_macro:mp_print(mp, "unsuffixed macro"); break;
4714 case mp_suffixed_macro:mp_print(mp, "suffixed macro"); break;
4715 default: mp_print(mp, "undefined"); break;
4719 @ Values inside \MP\ are stored in two-word nodes that have a |name_type|
4720 as well as a |type|. The possibilities for |name_type| are defined
4721 here; they will be explained in more detail later.
4725 mp_root=0, /* |name_type| at the top level of a variable */
4726 mp_saved_root, /* same, when the variable has been saved */
4727 mp_structured_root, /* |name_type| where a |mp_structured| branch occurs */
4728 mp_subscr, /* |name_type| in a subscript node */
4729 mp_attr, /* |name_type| in an attribute node */
4730 mp_x_part_sector, /* |name_type| in the \&{xpart} of a node */
4731 mp_y_part_sector, /* |name_type| in the \&{ypart} of a node */
4732 mp_xx_part_sector, /* |name_type| in the \&{xxpart} of a node */
4733 mp_xy_part_sector, /* |name_type| in the \&{xypart} of a node */
4734 mp_yx_part_sector, /* |name_type| in the \&{yxpart} of a node */
4735 mp_yy_part_sector, /* |name_type| in the \&{yypart} of a node */
4736 mp_red_part_sector, /* |name_type| in the \&{redpart} of a node */
4737 mp_green_part_sector, /* |name_type| in the \&{greenpart} of a node */
4738 mp_blue_part_sector, /* |name_type| in the \&{bluepart} of a node */
4739 mp_cyan_part_sector, /* |name_type| in the \&{redpart} of a node */
4740 mp_magenta_part_sector, /* |name_type| in the \&{greenpart} of a node */
4741 mp_yellow_part_sector, /* |name_type| in the \&{bluepart} of a node */
4742 mp_black_part_sector, /* |name_type| in the \&{greenpart} of a node */
4743 mp_grey_part_sector, /* |name_type| in the \&{bluepart} of a node */
4744 mp_capsule, /* |name_type| in stashed-away subexpressions */
4745 mp_token /* |name_type| in a numeric token or string token */
4748 @ Primitive operations that produce values have a secondary identification
4749 code in addition to their command code; it's something like genera and species.
4750 For example, `\.*' has the command code |primary_binary|, and its
4751 secondary identification is |times|. The secondary codes start at 30 so that
4752 they don't overlap with the type codes; some type codes (e.g., |mp_string_type|)
4753 are used as operators as well as type identifications. The relative values
4754 are not critical, except for |true_code..false_code|, |or_op..and_op|,
4755 and |filled_op..bounded_op|. The restrictions are that
4756 |and_op-false_code=or_op-true_code|, that the ordering of
4757 |x_part...blue_part| must match that of |x_part_sector..mp_blue_part_sector|,
4758 and the ordering of |filled_op..bounded_op| must match that of the code
4759 values they test for.
4761 @d true_code 30 /* operation code for \.{true} */
4762 @d false_code 31 /* operation code for \.{false} */
4763 @d null_picture_code 32 /* operation code for \.{nullpicture} */
4764 @d null_pen_code 33 /* operation code for \.{nullpen} */
4765 @d job_name_op 34 /* operation code for \.{jobname} */
4766 @d read_string_op 35 /* operation code for \.{readstring} */
4767 @d pen_circle 36 /* operation code for \.{pencircle} */
4768 @d normal_deviate 37 /* operation code for \.{normaldeviate} */
4769 @d read_from_op 38 /* operation code for \.{readfrom} */
4770 @d close_from_op 39 /* operation code for \.{closefrom} */
4771 @d odd_op 40 /* operation code for \.{odd} */
4772 @d known_op 41 /* operation code for \.{known} */
4773 @d unknown_op 42 /* operation code for \.{unknown} */
4774 @d not_op 43 /* operation code for \.{not} */
4775 @d decimal 44 /* operation code for \.{decimal} */
4776 @d reverse 45 /* operation code for \.{reverse} */
4777 @d make_path_op 46 /* operation code for \.{makepath} */
4778 @d make_pen_op 47 /* operation code for \.{makepen} */
4779 @d oct_op 48 /* operation code for \.{oct} */
4780 @d hex_op 49 /* operation code for \.{hex} */
4781 @d ASCII_op 50 /* operation code for \.{ASCII} */
4782 @d char_op 51 /* operation code for \.{char} */
4783 @d length_op 52 /* operation code for \.{length} */
4784 @d turning_op 53 /* operation code for \.{turningnumber} */
4785 @d color_model_part 54 /* operation code for \.{colormodel} */
4786 @d x_part 55 /* operation code for \.{xpart} */
4787 @d y_part 56 /* operation code for \.{ypart} */
4788 @d xx_part 57 /* operation code for \.{xxpart} */
4789 @d xy_part 58 /* operation code for \.{xypart} */
4790 @d yx_part 59 /* operation code for \.{yxpart} */
4791 @d yy_part 60 /* operation code for \.{yypart} */
4792 @d red_part 61 /* operation code for \.{redpart} */
4793 @d green_part 62 /* operation code for \.{greenpart} */
4794 @d blue_part 63 /* operation code for \.{bluepart} */
4795 @d cyan_part 64 /* operation code for \.{cyanpart} */
4796 @d magenta_part 65 /* operation code for \.{magentapart} */
4797 @d yellow_part 66 /* operation code for \.{yellowpart} */
4798 @d black_part 67 /* operation code for \.{blackpart} */
4799 @d grey_part 68 /* operation code for \.{greypart} */
4800 @d font_part 69 /* operation code for \.{fontpart} */
4801 @d text_part 70 /* operation code for \.{textpart} */
4802 @d path_part 71 /* operation code for \.{pathpart} */
4803 @d pen_part 72 /* operation code for \.{penpart} */
4804 @d dash_part 73 /* operation code for \.{dashpart} */
4805 @d sqrt_op 74 /* operation code for \.{sqrt} */
4806 @d m_exp_op 75 /* operation code for \.{mexp} */
4807 @d m_log_op 76 /* operation code for \.{mlog} */
4808 @d sin_d_op 77 /* operation code for \.{sind} */
4809 @d cos_d_op 78 /* operation code for \.{cosd} */
4810 @d floor_op 79 /* operation code for \.{floor} */
4811 @d uniform_deviate 80 /* operation code for \.{uniformdeviate} */
4812 @d char_exists_op 81 /* operation code for \.{charexists} */
4813 @d font_size 82 /* operation code for \.{fontsize} */
4814 @d ll_corner_op 83 /* operation code for \.{llcorner} */
4815 @d lr_corner_op 84 /* operation code for \.{lrcorner} */
4816 @d ul_corner_op 85 /* operation code for \.{ulcorner} */
4817 @d ur_corner_op 86 /* operation code for \.{urcorner} */
4818 @d arc_length 87 /* operation code for \.{arclength} */
4819 @d angle_op 88 /* operation code for \.{angle} */
4820 @d cycle_op 89 /* operation code for \.{cycle} */
4821 @d filled_op 90 /* operation code for \.{filled} */
4822 @d stroked_op 91 /* operation code for \.{stroked} */
4823 @d textual_op 92 /* operation code for \.{textual} */
4824 @d clipped_op 93 /* operation code for \.{clipped} */
4825 @d bounded_op 94 /* operation code for \.{bounded} */
4826 @d plus 95 /* operation code for \.+ */
4827 @d minus 96 /* operation code for \.- */
4828 @d times 97 /* operation code for \.* */
4829 @d over 98 /* operation code for \./ */
4830 @d pythag_add 99 /* operation code for \.{++} */
4831 @d pythag_sub 100 /* operation code for \.{+-+} */
4832 @d or_op 101 /* operation code for \.{or} */
4833 @d and_op 102 /* operation code for \.{and} */
4834 @d less_than 103 /* operation code for \.< */
4835 @d less_or_equal 104 /* operation code for \.{<=} */
4836 @d greater_than 105 /* operation code for \.> */
4837 @d greater_or_equal 106 /* operation code for \.{>=} */
4838 @d equal_to 107 /* operation code for \.= */
4839 @d unequal_to 108 /* operation code for \.{<>} */
4840 @d concatenate 109 /* operation code for \.\& */
4841 @d rotated_by 110 /* operation code for \.{rotated} */
4842 @d slanted_by 111 /* operation code for \.{slanted} */
4843 @d scaled_by 112 /* operation code for \.{scaled} */
4844 @d shifted_by 113 /* operation code for \.{shifted} */
4845 @d transformed_by 114 /* operation code for \.{transformed} */
4846 @d x_scaled 115 /* operation code for \.{xscaled} */
4847 @d y_scaled 116 /* operation code for \.{yscaled} */
4848 @d z_scaled 117 /* operation code for \.{zscaled} */
4849 @d in_font 118 /* operation code for \.{infont} */
4850 @d intersect 119 /* operation code for \.{intersectiontimes} */
4851 @d double_dot 120 /* operation code for improper \.{..} */
4852 @d substring_of 121 /* operation code for \.{substring} */
4853 @d min_of substring_of
4854 @d subpath_of 122 /* operation code for \.{subpath} */
4855 @d direction_time_of 123 /* operation code for \.{directiontime} */
4856 @d point_of 124 /* operation code for \.{point} */
4857 @d precontrol_of 125 /* operation code for \.{precontrol} */
4858 @d postcontrol_of 126 /* operation code for \.{postcontrol} */
4859 @d pen_offset_of 127 /* operation code for \.{penoffset} */
4860 @d arc_time_of 128 /* operation code for \.{arctime} */
4861 @d mp_version 129 /* operation code for \.{mpversion} */
4862 @d envelope_of 130 /* operation code for \.{envelope} */
4864 @c void mp_print_op (MP mp,quarterword c) {
4865 if (c<=mp_numeric_type ) {
4866 mp_print_type(mp, c);
4869 case true_code:mp_print(mp, "true"); break;
4870 case false_code:mp_print(mp, "false"); break;
4871 case null_picture_code:mp_print(mp, "nullpicture"); break;
4872 case null_pen_code:mp_print(mp, "nullpen"); break;
4873 case job_name_op:mp_print(mp, "jobname"); break;
4874 case read_string_op:mp_print(mp, "readstring"); break;
4875 case pen_circle:mp_print(mp, "pencircle"); break;
4876 case normal_deviate:mp_print(mp, "normaldeviate"); break;
4877 case read_from_op:mp_print(mp, "readfrom"); break;
4878 case close_from_op:mp_print(mp, "closefrom"); break;
4879 case odd_op:mp_print(mp, "odd"); break;
4880 case known_op:mp_print(mp, "known"); break;
4881 case unknown_op:mp_print(mp, "unknown"); break;
4882 case not_op:mp_print(mp, "not"); break;
4883 case decimal:mp_print(mp, "decimal"); break;
4884 case reverse:mp_print(mp, "reverse"); break;
4885 case make_path_op:mp_print(mp, "makepath"); break;
4886 case make_pen_op:mp_print(mp, "makepen"); break;
4887 case oct_op:mp_print(mp, "oct"); break;
4888 case hex_op:mp_print(mp, "hex"); break;
4889 case ASCII_op:mp_print(mp, "ASCII"); break;
4890 case char_op:mp_print(mp, "char"); break;
4891 case length_op:mp_print(mp, "length"); break;
4892 case turning_op:mp_print(mp, "turningnumber"); break;
4893 case x_part:mp_print(mp, "xpart"); break;
4894 case y_part:mp_print(mp, "ypart"); break;
4895 case xx_part:mp_print(mp, "xxpart"); break;
4896 case xy_part:mp_print(mp, "xypart"); break;
4897 case yx_part:mp_print(mp, "yxpart"); break;
4898 case yy_part:mp_print(mp, "yypart"); break;
4899 case red_part:mp_print(mp, "redpart"); break;
4900 case green_part:mp_print(mp, "greenpart"); break;
4901 case blue_part:mp_print(mp, "bluepart"); break;
4902 case cyan_part:mp_print(mp, "cyanpart"); break;
4903 case magenta_part:mp_print(mp, "magentapart"); break;
4904 case yellow_part:mp_print(mp, "yellowpart"); break;
4905 case black_part:mp_print(mp, "blackpart"); break;
4906 case grey_part:mp_print(mp, "greypart"); break;
4907 case color_model_part:mp_print(mp, "colormodel"); break;
4908 case font_part:mp_print(mp, "fontpart"); break;
4909 case text_part:mp_print(mp, "textpart"); break;
4910 case path_part:mp_print(mp, "pathpart"); break;
4911 case pen_part:mp_print(mp, "penpart"); break;
4912 case dash_part:mp_print(mp, "dashpart"); break;
4913 case sqrt_op:mp_print(mp, "sqrt"); break;
4914 case m_exp_op:mp_print(mp, "mexp"); break;
4915 case m_log_op:mp_print(mp, "mlog"); break;
4916 case sin_d_op:mp_print(mp, "sind"); break;
4917 case cos_d_op:mp_print(mp, "cosd"); break;
4918 case floor_op:mp_print(mp, "floor"); break;
4919 case uniform_deviate:mp_print(mp, "uniformdeviate"); break;
4920 case char_exists_op:mp_print(mp, "charexists"); break;
4921 case font_size:mp_print(mp, "fontsize"); break;
4922 case ll_corner_op:mp_print(mp, "llcorner"); break;
4923 case lr_corner_op:mp_print(mp, "lrcorner"); break;
4924 case ul_corner_op:mp_print(mp, "ulcorner"); break;
4925 case ur_corner_op:mp_print(mp, "urcorner"); break;
4926 case arc_length:mp_print(mp, "arclength"); break;
4927 case angle_op:mp_print(mp, "angle"); break;
4928 case cycle_op:mp_print(mp, "cycle"); break;
4929 case filled_op:mp_print(mp, "filled"); break;
4930 case stroked_op:mp_print(mp, "stroked"); break;
4931 case textual_op:mp_print(mp, "textual"); break;
4932 case clipped_op:mp_print(mp, "clipped"); break;
4933 case bounded_op:mp_print(mp, "bounded"); break;
4934 case plus:mp_print_char(mp, '+'); break;
4935 case minus:mp_print_char(mp, '-'); break;
4936 case times:mp_print_char(mp, '*'); break;
4937 case over:mp_print_char(mp, '/'); break;
4938 case pythag_add:mp_print(mp, "++"); break;
4939 case pythag_sub:mp_print(mp, "+-+"); break;
4940 case or_op:mp_print(mp, "or"); break;
4941 case and_op:mp_print(mp, "and"); break;
4942 case less_than:mp_print_char(mp, '<'); break;
4943 case less_or_equal:mp_print(mp, "<="); break;
4944 case greater_than:mp_print_char(mp, '>'); break;
4945 case greater_or_equal:mp_print(mp, ">="); break;
4946 case equal_to:mp_print_char(mp, '='); break;
4947 case unequal_to:mp_print(mp, "<>"); break;
4948 case concatenate:mp_print(mp, "&"); break;
4949 case rotated_by:mp_print(mp, "rotated"); break;
4950 case slanted_by:mp_print(mp, "slanted"); break;
4951 case scaled_by:mp_print(mp, "scaled"); break;
4952 case shifted_by:mp_print(mp, "shifted"); break;
4953 case transformed_by:mp_print(mp, "transformed"); break;
4954 case x_scaled:mp_print(mp, "xscaled"); break;
4955 case y_scaled:mp_print(mp, "yscaled"); break;
4956 case z_scaled:mp_print(mp, "zscaled"); break;
4957 case in_font:mp_print(mp, "infont"); break;
4958 case intersect:mp_print(mp, "intersectiontimes"); break;
4959 case substring_of:mp_print(mp, "substring"); break;
4960 case subpath_of:mp_print(mp, "subpath"); break;
4961 case direction_time_of:mp_print(mp, "directiontime"); break;
4962 case point_of:mp_print(mp, "point"); break;
4963 case precontrol_of:mp_print(mp, "precontrol"); break;
4964 case postcontrol_of:mp_print(mp, "postcontrol"); break;
4965 case pen_offset_of:mp_print(mp, "penoffset"); break;
4966 case arc_time_of:mp_print(mp, "arctime"); break;
4967 case mp_version:mp_print(mp, "mpversion"); break;
4968 case envelope_of:mp_print(mp, "envelope"); break;
4969 default: mp_print(mp, ".."); break;
4974 @ \MP\ also has a bunch of internal parameters that a user might want to
4975 fuss with. Every such parameter has an identifying code number, defined here.
4978 enum mp_given_internal {
4979 mp_tracing_titles=1, /* show titles online when they appear */
4980 mp_tracing_equations, /* show each variable when it becomes known */
4981 mp_tracing_capsules, /* show capsules too */
4982 mp_tracing_choices, /* show the control points chosen for paths */
4983 mp_tracing_specs, /* show path subdivision prior to filling with polygonal a pen */
4984 mp_tracing_commands, /* show commands and operations before they are performed */
4985 mp_tracing_restores, /* show when a variable or internal is restored */
4986 mp_tracing_macros, /* show macros before they are expanded */
4987 mp_tracing_output, /* show digitized edges as they are output */
4988 mp_tracing_stats, /* show memory usage at end of job */
4989 mp_tracing_lost_chars, /* show characters that aren't \&{infont} */
4990 mp_tracing_online, /* show long diagnostics on terminal and in the log file */
4991 mp_year, /* the current year (e.g., 1984) */
4992 mp_month, /* the current month (e.g., 3 $\equiv$ March) */
4993 mp_day, /* the current day of the month */
4994 mp_time, /* the number of minutes past midnight when this job started */
4995 mp_char_code, /* the number of the next character to be output */
4996 mp_char_ext, /* the extension code of the next character to be output */
4997 mp_char_wd, /* the width of the next character to be output */
4998 mp_char_ht, /* the height of the next character to be output */
4999 mp_char_dp, /* the depth of the next character to be output */
5000 mp_char_ic, /* the italic correction of the next character to be output */
5001 mp_design_size, /* the unit of measure used for |mp_char_wd..mp_char_ic|, in points */
5002 mp_pausing, /* positive to display lines on the terminal before they are read */
5003 mp_showstopping, /* positive to stop after each \&{show} command */
5004 mp_fontmaking, /* positive if font metric output is to be produced */
5005 mp_linejoin, /* as in \ps: 0 for mitered, 1 for round, 2 for beveled */
5006 mp_linecap, /* as in \ps: 0 for butt, 1 for round, 2 for square */
5007 mp_miterlimit, /* controls miter length as in \ps */
5008 mp_warning_check, /* controls error message when variable value is large */
5009 mp_boundary_char, /* the right boundary character for ligatures */
5010 mp_prologues, /* positive to output conforming PostScript using built-in fonts */
5011 mp_true_corners, /* positive to make \&{llcorner} etc. ignore \&{setbounds} */
5012 mp_default_color_model, /* the default color model for unspecified items */
5013 mp_restore_clip_color,
5014 mp_procset, /* wether or not create PostScript command shortcuts */
5015 mp_gtroffmode /* whether the user specified |-troff| on the command line */
5020 @d max_given_internal mp_gtroffmode
5023 scaled *internal; /* the values of internal quantities */
5024 char **int_name; /* their names */
5025 int int_ptr; /* the maximum internal quantity defined so far */
5026 int max_internal; /* current maximum number of internal quantities */
5028 @ @<Option variables@>=
5031 @ @<Allocate or initialize ...@>=
5032 mp->max_internal=2*max_given_internal;
5033 mp->internal = xmalloc ((mp->max_internal+1), sizeof(scaled));
5034 memset(mp->internal,0,(mp->max_internal+1)* sizeof(scaled));
5035 mp->int_name = xmalloc ((mp->max_internal+1), sizeof(char *));
5036 memset(mp->int_name,0,(mp->max_internal+1) * sizeof(char *));
5037 mp->troff_mode=(opt->troff_mode>0 ? true : false);
5039 @ @<Exported function ...@>=
5040 int mp_troff_mode(MP mp);
5043 int mp_troff_mode(MP mp) { return mp->troff_mode; }
5045 @ @<Set initial ...@>=
5046 mp->int_ptr=max_given_internal;
5048 @ The symbolic names for internal quantities are put into \MP's hash table
5049 by using a routine called |primitive|, which will be defined later. Let us
5050 enter them now, so that we don't have to list all those names again
5053 @<Put each of \MP's primitives into the hash table@>=
5054 mp_primitive(mp, "tracingtitles",internal_quantity,mp_tracing_titles);
5055 @:tracingtitles_}{\&{tracingtitles} primitive@>
5056 mp_primitive(mp, "tracingequations",internal_quantity,mp_tracing_equations);
5057 @:mp_tracing_equations_}{\&{tracingequations} primitive@>
5058 mp_primitive(mp, "tracingcapsules",internal_quantity,mp_tracing_capsules);
5059 @:mp_tracing_capsules_}{\&{tracingcapsules} primitive@>
5060 mp_primitive(mp, "tracingchoices",internal_quantity,mp_tracing_choices);
5061 @:mp_tracing_choices_}{\&{tracingchoices} primitive@>
5062 mp_primitive(mp, "tracingspecs",internal_quantity,mp_tracing_specs);
5063 @:mp_tracing_specs_}{\&{tracingspecs} primitive@>
5064 mp_primitive(mp, "tracingcommands",internal_quantity,mp_tracing_commands);
5065 @:mp_tracing_commands_}{\&{tracingcommands} primitive@>
5066 mp_primitive(mp, "tracingrestores",internal_quantity,mp_tracing_restores);
5067 @:mp_tracing_restores_}{\&{tracingrestores} primitive@>
5068 mp_primitive(mp, "tracingmacros",internal_quantity,mp_tracing_macros);
5069 @:mp_tracing_macros_}{\&{tracingmacros} primitive@>
5070 mp_primitive(mp, "tracingoutput",internal_quantity,mp_tracing_output);
5071 @:mp_tracing_output_}{\&{tracingoutput} primitive@>
5072 mp_primitive(mp, "tracingstats",internal_quantity,mp_tracing_stats);
5073 @:mp_tracing_stats_}{\&{tracingstats} primitive@>
5074 mp_primitive(mp, "tracinglostchars",internal_quantity,mp_tracing_lost_chars);
5075 @:mp_tracing_lost_chars_}{\&{tracinglostchars} primitive@>
5076 mp_primitive(mp, "tracingonline",internal_quantity,mp_tracing_online);
5077 @:mp_tracing_online_}{\&{tracingonline} primitive@>
5078 mp_primitive(mp, "year",internal_quantity,mp_year);
5079 @:mp_year_}{\&{year} primitive@>
5080 mp_primitive(mp, "month",internal_quantity,mp_month);
5081 @:mp_month_}{\&{month} primitive@>
5082 mp_primitive(mp, "day",internal_quantity,mp_day);
5083 @:mp_day_}{\&{day} primitive@>
5084 mp_primitive(mp, "time",internal_quantity,mp_time);
5085 @:time_}{\&{time} primitive@>
5086 mp_primitive(mp, "charcode",internal_quantity,mp_char_code);
5087 @:mp_char_code_}{\&{charcode} primitive@>
5088 mp_primitive(mp, "charext",internal_quantity,mp_char_ext);
5089 @:mp_char_ext_}{\&{charext} primitive@>
5090 mp_primitive(mp, "charwd",internal_quantity,mp_char_wd);
5091 @:mp_char_wd_}{\&{charwd} primitive@>
5092 mp_primitive(mp, "charht",internal_quantity,mp_char_ht);
5093 @:mp_char_ht_}{\&{charht} primitive@>
5094 mp_primitive(mp, "chardp",internal_quantity,mp_char_dp);
5095 @:mp_char_dp_}{\&{chardp} primitive@>
5096 mp_primitive(mp, "charic",internal_quantity,mp_char_ic);
5097 @:mp_char_ic_}{\&{charic} primitive@>
5098 mp_primitive(mp, "designsize",internal_quantity,mp_design_size);
5099 @:mp_design_size_}{\&{designsize} primitive@>
5100 mp_primitive(mp, "pausing",internal_quantity,mp_pausing);
5101 @:mp_pausing_}{\&{pausing} primitive@>
5102 mp_primitive(mp, "showstopping",internal_quantity,mp_showstopping);
5103 @:mp_showstopping_}{\&{showstopping} primitive@>
5104 mp_primitive(mp, "fontmaking",internal_quantity,mp_fontmaking);
5105 @:mp_fontmaking_}{\&{fontmaking} primitive@>
5106 mp_primitive(mp, "linejoin",internal_quantity,mp_linejoin);
5107 @:mp_linejoin_}{\&{linejoin} primitive@>
5108 mp_primitive(mp, "linecap",internal_quantity,mp_linecap);
5109 @:mp_linecap_}{\&{linecap} primitive@>
5110 mp_primitive(mp, "miterlimit",internal_quantity,mp_miterlimit);
5111 @:mp_miterlimit_}{\&{miterlimit} primitive@>
5112 mp_primitive(mp, "warningcheck",internal_quantity,mp_warning_check);
5113 @:mp_warning_check_}{\&{warningcheck} primitive@>
5114 mp_primitive(mp, "boundarychar",internal_quantity,mp_boundary_char);
5115 @:mp_boundary_char_}{\&{boundarychar} primitive@>
5116 mp_primitive(mp, "prologues",internal_quantity,mp_prologues);
5117 @:mp_prologues_}{\&{prologues} primitive@>
5118 mp_primitive(mp, "truecorners",internal_quantity,mp_true_corners);
5119 @:mp_true_corners_}{\&{truecorners} primitive@>
5120 mp_primitive(mp, "mpprocset",internal_quantity,mp_procset);
5121 @:mp_procset_}{\&{mpprocset} primitive@>
5122 mp_primitive(mp, "troffmode",internal_quantity,mp_gtroffmode);
5123 @:troffmode_}{\&{troffmode} primitive@>
5124 mp_primitive(mp, "defaultcolormodel",internal_quantity,mp_default_color_model);
5125 @:mp_default_color_model_}{\&{defaultcolormodel} primitive@>
5126 mp_primitive(mp, "restoreclipcolor",internal_quantity,mp_restore_clip_color);
5127 @:mp_restore_clip_color_}{\&{restoreclipcolor} primitive@>
5129 @ Colors can be specified in four color models. In the special
5130 case of |no_model|, MetaPost does not output any color operator to
5131 the postscript output.
5133 Note: these values are passed directly on to |with_option|. This only
5134 works because the other possible values passed to |with_option| are
5135 8 and 10 respectively (from |with_pen| and |with_picture|).
5137 There is a first state, that is only used for |gs_colormodel|. It flags
5138 the fact that there has not been any kind of color specification by
5139 the user so far in the game.
5142 enum mp_color_model {
5147 mp_uninitialized_model=9
5151 @ @<Initialize table entries (done by \.{INIMP} only)@>=
5152 mp->internal[mp_default_color_model]=(mp_rgb_model*unity);
5153 mp->internal[mp_restore_clip_color]=unity;
5155 @ Well, we do have to list the names one more time, for use in symbolic
5158 @<Initialize table...@>=
5159 mp->int_name[mp_tracing_titles]=xstrdup("tracingtitles");
5160 mp->int_name[mp_tracing_equations]=xstrdup("tracingequations");
5161 mp->int_name[mp_tracing_capsules]=xstrdup("tracingcapsules");
5162 mp->int_name[mp_tracing_choices]=xstrdup("tracingchoices");
5163 mp->int_name[mp_tracing_specs]=xstrdup("tracingspecs");
5164 mp->int_name[mp_tracing_commands]=xstrdup("tracingcommands");
5165 mp->int_name[mp_tracing_restores]=xstrdup("tracingrestores");
5166 mp->int_name[mp_tracing_macros]=xstrdup("tracingmacros");
5167 mp->int_name[mp_tracing_output]=xstrdup("tracingoutput");
5168 mp->int_name[mp_tracing_stats]=xstrdup("tracingstats");
5169 mp->int_name[mp_tracing_lost_chars]=xstrdup("tracinglostchars");
5170 mp->int_name[mp_tracing_online]=xstrdup("tracingonline");
5171 mp->int_name[mp_year]=xstrdup("year");
5172 mp->int_name[mp_month]=xstrdup("month");
5173 mp->int_name[mp_day]=xstrdup("day");
5174 mp->int_name[mp_time]=xstrdup("time");
5175 mp->int_name[mp_char_code]=xstrdup("charcode");
5176 mp->int_name[mp_char_ext]=xstrdup("charext");
5177 mp->int_name[mp_char_wd]=xstrdup("charwd");
5178 mp->int_name[mp_char_ht]=xstrdup("charht");
5179 mp->int_name[mp_char_dp]=xstrdup("chardp");
5180 mp->int_name[mp_char_ic]=xstrdup("charic");
5181 mp->int_name[mp_design_size]=xstrdup("designsize");
5182 mp->int_name[mp_pausing]=xstrdup("pausing");
5183 mp->int_name[mp_showstopping]=xstrdup("showstopping");
5184 mp->int_name[mp_fontmaking]=xstrdup("fontmaking");
5185 mp->int_name[mp_linejoin]=xstrdup("linejoin");
5186 mp->int_name[mp_linecap]=xstrdup("linecap");
5187 mp->int_name[mp_miterlimit]=xstrdup("miterlimit");
5188 mp->int_name[mp_warning_check]=xstrdup("warningcheck");
5189 mp->int_name[mp_boundary_char]=xstrdup("boundarychar");
5190 mp->int_name[mp_prologues]=xstrdup("prologues");
5191 mp->int_name[mp_true_corners]=xstrdup("truecorners");
5192 mp->int_name[mp_default_color_model]=xstrdup("defaultcolormodel");
5193 mp->int_name[mp_procset]=xstrdup("mpprocset");
5194 mp->int_name[mp_gtroffmode]=xstrdup("troffmode");
5195 mp->int_name[mp_restore_clip_color]=xstrdup("restoreclipcolor");
5197 @ The following procedure, which is called just before \MP\ initializes its
5198 input and output, establishes the initial values of the date and time.
5199 @^system dependencies@>
5201 Note that the values are |scaled| integers. Hence \MP\ can no longer
5202 be used after the year 32767.
5205 void mp_fix_date_and_time (MP mp) {
5206 time_t aclock = time ((time_t *) 0);
5207 struct tm *tmptr = localtime (&aclock);
5208 mp->internal[mp_time]=
5209 (tmptr->tm_hour*60+tmptr->tm_min)*unity; /* minutes since midnight */
5210 mp->internal[mp_day]=(tmptr->tm_mday)*unity; /* fourth day of the month */
5211 mp->internal[mp_month]=(tmptr->tm_mon+1)*unity; /* seventh month of the year */
5212 mp->internal[mp_year]=(tmptr->tm_year+1900)*unity; /* Anno Domini */
5216 void mp_fix_date_and_time (MP mp) ;
5218 @ \MP\ is occasionally supposed to print diagnostic information that
5219 goes only into the transcript file, unless |mp_tracing_online| is positive.
5220 Now that we have defined |mp_tracing_online| we can define
5221 two routines that adjust the destination of print commands:
5224 void mp_begin_diagnostic (MP mp) ;
5225 void mp_end_diagnostic (MP mp,boolean blank_line);
5226 void mp_print_diagnostic (MP mp, const char *s, const char *t, boolean nuline) ;
5228 @ @<Basic printing...@>=
5229 @<Declare a function called |true_line|@>
5230 void mp_begin_diagnostic (MP mp) { /* prepare to do some tracing */
5231 mp->old_setting=mp->selector;
5232 if ((mp->internal[mp_tracing_online]<=0)&&(mp->selector==term_and_log)){
5234 if ( mp->history==mp_spotless ) mp->history=mp_warning_issued;
5238 void mp_end_diagnostic (MP mp,boolean blank_line) {
5239 /* restore proper conditions after tracing */
5240 mp_print_nl(mp, "");
5241 if ( blank_line ) mp_print_ln(mp);
5242 mp->selector=mp->old_setting;
5248 unsigned int old_setting;
5250 @ We will occasionally use |begin_diagnostic| in connection with line-number
5251 printing, as follows. (The parameter |s| is typically |"Path"| or
5252 |"Cycle spec"|, etc.)
5254 @<Basic printing...@>=
5255 void mp_print_diagnostic (MP mp, const char *s, const char *t, boolean nuline) {
5256 mp_begin_diagnostic(mp);
5257 if ( nuline ) mp_print_nl(mp, s); else mp_print(mp, s);
5258 mp_print(mp, " at line ");
5259 mp_print_int(mp, mp_true_line(mp));
5260 mp_print(mp, t); mp_print_char(mp, ':');
5263 @ The 256 |ASCII_code| characters are grouped into classes by means of
5264 the |char_class| table. Individual class numbers have no semantic
5265 or syntactic significance, except in a few instances defined here.
5266 There's also |max_class|, which can be used as a basis for additional
5267 class numbers in nonstandard extensions of \MP.
5269 @d digit_class 0 /* the class number of \.{0123456789} */
5270 @d period_class 1 /* the class number of `\..' */
5271 @d space_class 2 /* the class number of spaces and nonstandard characters */
5272 @d percent_class 3 /* the class number of `\.\%' */
5273 @d string_class 4 /* the class number of `\."' */
5274 @d right_paren_class 8 /* the class number of `\.)' */
5275 @d isolated_classes 5: case 6: case 7: case 8 /* characters that make length-one tokens only */
5276 @d letter_class 9 /* letters and the underline character */
5277 @d left_bracket_class 17 /* `\.[' */
5278 @d right_bracket_class 18 /* `\.]' */
5279 @d invalid_class 20 /* bad character in the input */
5280 @d max_class 20 /* the largest class number */
5283 int char_class[256]; /* the class numbers */
5285 @ If changes are made to accommodate non-ASCII character sets, they should
5286 follow the guidelines in Appendix~C of {\sl The {\logos METAFONT\/}book}.
5287 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
5288 @^system dependencies@>
5290 @<Set initial ...@>=
5291 for (k='0';k<='9';k++)
5292 mp->char_class[k]=digit_class;
5293 mp->char_class['.']=period_class;
5294 mp->char_class[' ']=space_class;
5295 mp->char_class['%']=percent_class;
5296 mp->char_class['"']=string_class;
5297 mp->char_class[',']=5;
5298 mp->char_class[';']=6;
5299 mp->char_class['(']=7;
5300 mp->char_class[')']=right_paren_class;
5301 for (k='A';k<= 'Z';k++ )
5302 mp->char_class[k]=letter_class;
5303 for (k='a';k<='z';k++)
5304 mp->char_class[k]=letter_class;
5305 mp->char_class['_']=letter_class;
5306 mp->char_class['<']=10;
5307 mp->char_class['=']=10;
5308 mp->char_class['>']=10;
5309 mp->char_class[':']=10;
5310 mp->char_class['|']=10;
5311 mp->char_class['`']=11;
5312 mp->char_class['\'']=11;
5313 mp->char_class['+']=12;
5314 mp->char_class['-']=12;
5315 mp->char_class['/']=13;
5316 mp->char_class['*']=13;
5317 mp->char_class['\\']=13;
5318 mp->char_class['!']=14;
5319 mp->char_class['?']=14;
5320 mp->char_class['#']=15;
5321 mp->char_class['&']=15;
5322 mp->char_class['@@']=15;
5323 mp->char_class['$']=15;
5324 mp->char_class['^']=16;
5325 mp->char_class['~']=16;
5326 mp->char_class['[']=left_bracket_class;
5327 mp->char_class[']']=right_bracket_class;
5328 mp->char_class['{']=19;
5329 mp->char_class['}']=19;
5331 mp->char_class[k]=invalid_class;
5332 mp->char_class['\t']=space_class;
5333 mp->char_class['\f']=space_class;
5334 for (k=127;k<=255;k++)
5335 mp->char_class[k]=invalid_class;
5337 @* \[13] The hash table.
5338 Symbolic tokens are stored and retrieved by means of a fairly standard hash
5339 table algorithm called the method of ``coalescing lists'' (cf.\ Algorithm 6.4C
5340 in {\sl The Art of Computer Programming\/}). Once a symbolic token enters the
5341 table, it is never removed.
5343 The actual sequence of characters forming a symbolic token is
5344 stored in the |str_pool| array together with all the other strings. An
5345 auxiliary array |hash| consists of items with two halfword fields per
5346 word. The first of these, called |next(p)|, points to the next identifier
5347 belonging to the same coalesced list as the identifier corresponding to~|p|;
5348 and the other, called |text(p)|, points to the |str_start| entry for
5349 |p|'s identifier. If position~|p| of the hash table is empty, we have
5350 |text(p)=0|; if position |p| is either empty or the end of a coalesced
5351 hash list, we have |next(p)=0|.
5353 An auxiliary pointer variable called |hash_used| is maintained in such a
5354 way that all locations |p>=hash_used| are nonempty. The global variable
5355 |st_count| tells how many symbolic tokens have been defined, if statistics
5358 The first 256 locations of |hash| are reserved for symbols of length one.
5360 There's a parallel array called |eqtb| that contains the current equivalent
5361 values of each symbolic token. The entries of this array consist of
5362 two halfwords called |eq_type| (a command code) and |equiv| (a secondary
5363 piece of information that qualifies the |eq_type|).
5365 @d next(A) mp->hash[(A)].lh /* link for coalesced lists */
5366 @d text(A) mp->hash[(A)].rh /* string number for symbolic token name */
5367 @d eq_type(A) mp->eqtb[(A)].lh /* the current ``meaning'' of a symbolic token */
5368 @d equiv(A) mp->eqtb[(A)].rh /* parametric part of a token's meaning */
5369 @d hash_base 257 /* hashing actually starts here */
5370 @d hash_is_full (mp->hash_used==hash_base) /* are all positions occupied? */
5373 pointer hash_used; /* allocation pointer for |hash| */
5374 integer st_count; /* total number of known identifiers */
5376 @ Certain entries in the hash table are ``frozen'' and not redefinable,
5377 since they are used in error recovery.
5379 @d hash_top (hash_base+mp->hash_size) /* the first location of the frozen area */
5380 @d frozen_inaccessible hash_top /* |hash| location to protect the frozen area */
5381 @d frozen_repeat_loop (hash_top+1) /* |hash| location of a loop-repeat token */
5382 @d frozen_right_delimiter (hash_top+2) /* |hash| location of a permanent `\.)' */
5383 @d frozen_left_bracket (hash_top+3) /* |hash| location of a permanent `\.[' */
5384 @d frozen_slash (hash_top+4) /* |hash| location of a permanent `\./' */
5385 @d frozen_colon (hash_top+5) /* |hash| location of a permanent `\.:' */
5386 @d frozen_semicolon (hash_top+6) /* |hash| location of a permanent `\.;' */
5387 @d frozen_end_for (hash_top+7) /* |hash| location of a permanent \&{endfor} */
5388 @d frozen_end_def (hash_top+8) /* |hash| location of a permanent \&{enddef} */
5389 @d frozen_fi (hash_top+9) /* |hash| location of a permanent \&{fi} */
5390 @d frozen_end_group (hash_top+10) /* |hash| location of a permanent `\.{endgroup}' */
5391 @d frozen_etex (hash_top+11) /* |hash| location of a permanent \&{etex} */
5392 @d frozen_mpx_break (hash_top+12) /* |hash| location of a permanent \&{mpxbreak} */
5393 @d frozen_bad_vardef (hash_top+13) /* |hash| location of `\.{a bad variable}' */
5394 @d frozen_undefined (hash_top+14) /* |hash| location that never gets defined */
5395 @d hash_end (hash_top+14) /* the actual size of the |hash| and |eqtb| arrays */
5398 two_halves *hash; /* the hash table */
5399 two_halves *eqtb; /* the equivalents */
5401 @ @<Allocate or initialize ...@>=
5402 mp->hash = xmalloc((hash_end+1),sizeof(two_halves));
5403 mp->eqtb = xmalloc((hash_end+1),sizeof(two_halves));
5405 @ @<Dealloc variables@>=
5410 next(1)=0; text(1)=0; eq_type(1)=tag_token; equiv(1)=null;
5411 for (k=2;k<=hash_end;k++) {
5412 mp->hash[k]=mp->hash[1]; mp->eqtb[k]=mp->eqtb[1];
5415 @ @<Initialize table entries...@>=
5416 mp->hash_used=frozen_inaccessible; /* nothing is used */
5418 text(frozen_bad_vardef)=intern("a bad variable");
5419 text(frozen_etex)=intern("etex");
5420 text(frozen_mpx_break)=intern("mpxbreak");
5421 text(frozen_fi)=intern("fi");
5422 text(frozen_end_group)=intern("endgroup");
5423 text(frozen_end_def)=intern("enddef");
5424 text(frozen_end_for)=intern("endfor");
5425 text(frozen_semicolon)=intern(";");
5426 text(frozen_colon)=intern(":");
5427 text(frozen_slash)=intern("/");
5428 text(frozen_left_bracket)=intern("[");
5429 text(frozen_right_delimiter)=intern(")");
5430 text(frozen_inaccessible)=intern(" INACCESSIBLE");
5431 eq_type(frozen_right_delimiter)=right_delimiter;
5433 @ @<Check the ``constant'' values...@>=
5434 if ( hash_end+mp->max_internal>max_halfword ) mp->bad=17;
5436 @ Here is the subroutine that searches the hash table for an identifier
5437 that matches a given string of length~|l| appearing in |buffer[j..
5438 (j+l-1)]|. If the identifier is not found, it is inserted; hence it
5439 will always be found, and the corresponding hash table address
5443 pointer mp_id_lookup (MP mp,integer j, integer l) { /* search the hash table */
5444 integer h; /* hash code */
5445 pointer p; /* index in |hash| array */
5446 pointer k; /* index in |buffer| array */
5448 @<Treat special case of length 1 and |break|@>;
5450 @<Compute the hash code |h|@>;
5451 p=h+hash_base; /* we start searching here; note that |0<=h<hash_prime| */
5453 if (text(p)>0 && length(text(p))==l && mp_str_eq_buf(mp, text(p),j))
5456 @<Insert a new symbolic token after |p|, then
5457 make |p| point to it and |break|@>;
5464 @ @<Treat special case of length 1...@>=
5465 p=mp->buffer[j]+1; text(p)=p-1; return p;
5468 @ @<Insert a new symbolic...@>=
5473 mp_overflow(mp, "hash size",mp->hash_size);
5474 @:MetaPost capacity exceeded hash size}{\quad hash size@>
5475 decr(mp->hash_used);
5476 } while (text(mp->hash_used)!=0); /* search for an empty location in |hash| */
5477 next(p)=mp->hash_used;
5481 for (k=j;k<=j+l-1;k++) {
5482 append_char(mp->buffer[k]);
5484 text(p)=mp_make_string(mp);
5485 mp->str_ref[text(p)]=max_str_ref;
5491 @ The value of |hash_prime| should be roughly 85\pct! of |hash_size|, and it
5492 should be a prime number. The theory of hashing tells us to expect fewer
5493 than two table probes, on the average, when the search is successful.
5494 [See J.~S. Vitter, {\sl Journal of the ACM\/ \bf30} (1983), 231--258.]
5495 @^Vitter, Jeffrey Scott@>
5497 @<Compute the hash code |h|@>=
5499 for (k=j+1;k<=j+l-1;k++){
5500 h=h+h+mp->buffer[k];
5501 while ( h>=mp->hash_prime ) h=h-mp->hash_prime;
5504 @ @<Search |eqtb| for equivalents equal to |p|@>=
5505 for (q=1;q<=hash_end;q++) {
5506 if ( equiv(q)==p ) {
5507 mp_print_nl(mp, "EQUIV(");
5508 mp_print_int(mp, q);
5509 mp_print_char(mp, ')');
5513 @ We need to put \MP's ``primitive'' symbolic tokens into the hash
5514 table, together with their command code (which will be the |eq_type|)
5515 and an operand (which will be the |equiv|). The |primitive| procedure
5516 does this, in a way that no \MP\ user can. The global value |cur_sym|
5517 contains the new |eqtb| pointer after |primitive| has acted.
5520 void mp_primitive (MP mp, const char *ss, halfword c, halfword o) {
5521 pool_pointer k; /* index into |str_pool| */
5522 small_number j; /* index into |buffer| */
5523 small_number l; /* length of the string */
5526 k=mp->str_start[s]; l=str_stop(s)-k;
5527 /* we will move |s| into the (empty) |buffer| */
5528 for (j=0;j<=l-1;j++) {
5529 mp->buffer[j]=mp->str_pool[k+j];
5531 mp->cur_sym=mp_id_lookup(mp, 0,l);
5532 if ( s>=256 ) { /* we don't want to have the string twice */
5533 mp_flush_string(mp, text(mp->cur_sym)); text(mp->cur_sym)=s;
5535 eq_type(mp->cur_sym)=c;
5536 equiv(mp->cur_sym)=o;
5540 @ Many of \MP's primitives need no |equiv|, since they are identifiable
5541 by their |eq_type| alone. These primitives are loaded into the hash table
5544 @<Put each of \MP's primitives into the hash table@>=
5545 mp_primitive(mp, "..",path_join,0);
5546 @:.._}{\.{..} primitive@>
5547 mp_primitive(mp, "[",left_bracket,0); mp->eqtb[frozen_left_bracket]=mp->eqtb[mp->cur_sym];
5548 @:[ }{\.{[} primitive@>
5549 mp_primitive(mp, "]",right_bracket,0);
5550 @:] }{\.{]} primitive@>
5551 mp_primitive(mp, "}",right_brace,0);
5552 @:]]}{\.{\char`\}} primitive@>
5553 mp_primitive(mp, "{",left_brace,0);
5554 @:][}{\.{\char`\{} primitive@>
5555 mp_primitive(mp, ":",colon,0); mp->eqtb[frozen_colon]=mp->eqtb[mp->cur_sym];
5556 @:: }{\.{:} primitive@>
5557 mp_primitive(mp, "::",double_colon,0);
5558 @::: }{\.{::} primitive@>
5559 mp_primitive(mp, "||:",bchar_label,0);
5560 @:::: }{\.{\char'174\char'174:} primitive@>
5561 mp_primitive(mp, ":=",assignment,0);
5562 @::=_}{\.{:=} primitive@>
5563 mp_primitive(mp, ",",comma,0);
5564 @:, }{\., primitive@>
5565 mp_primitive(mp, ";",semicolon,0); mp->eqtb[frozen_semicolon]=mp->eqtb[mp->cur_sym];
5566 @:; }{\.; primitive@>
5567 mp_primitive(mp, "\\",relax,0);
5568 @:]]\\}{\.{\char`\\} primitive@>
5570 mp_primitive(mp, "addto",add_to_command,0);
5571 @:add_to_}{\&{addto} primitive@>
5572 mp_primitive(mp, "atleast",at_least,0);
5573 @:at_least_}{\&{atleast} primitive@>
5574 mp_primitive(mp, "begingroup",begin_group,0); mp->bg_loc=mp->cur_sym;
5575 @:begin_group_}{\&{begingroup} primitive@>
5576 mp_primitive(mp, "controls",controls,0);
5577 @:controls_}{\&{controls} primitive@>
5578 mp_primitive(mp, "curl",curl_command,0);
5579 @:curl_}{\&{curl} primitive@>
5580 mp_primitive(mp, "delimiters",delimiters,0);
5581 @:delimiters_}{\&{delimiters} primitive@>
5582 mp_primitive(mp, "endgroup",end_group,0);
5583 mp->eqtb[frozen_end_group]=mp->eqtb[mp->cur_sym]; mp->eg_loc=mp->cur_sym;
5584 @:endgroup_}{\&{endgroup} primitive@>
5585 mp_primitive(mp, "everyjob",every_job_command,0);
5586 @:every_job_}{\&{everyjob} primitive@>
5587 mp_primitive(mp, "exitif",exit_test,0);
5588 @:exit_if_}{\&{exitif} primitive@>
5589 mp_primitive(mp, "expandafter",expand_after,0);
5590 @:expand_after_}{\&{expandafter} primitive@>
5591 mp_primitive(mp, "interim",interim_command,0);
5592 @:interim_}{\&{interim} primitive@>
5593 mp_primitive(mp, "let",let_command,0);
5594 @:let_}{\&{let} primitive@>
5595 mp_primitive(mp, "newinternal",new_internal,0);
5596 @:new_internal_}{\&{newinternal} primitive@>
5597 mp_primitive(mp, "of",of_token,0);
5598 @:of_}{\&{of} primitive@>
5599 mp_primitive(mp, "randomseed",mp_random_seed,0);
5600 @:mp_random_seed_}{\&{randomseed} primitive@>
5601 mp_primitive(mp, "save",save_command,0);
5602 @:save_}{\&{save} primitive@>
5603 mp_primitive(mp, "scantokens",scan_tokens,0);
5604 @:scan_tokens_}{\&{scantokens} primitive@>
5605 mp_primitive(mp, "shipout",ship_out_command,0);
5606 @:ship_out_}{\&{shipout} primitive@>
5607 mp_primitive(mp, "skipto",skip_to,0);
5608 @:skip_to_}{\&{skipto} primitive@>
5609 mp_primitive(mp, "special",special_command,0);
5610 @:special}{\&{special} primitive@>
5611 mp_primitive(mp, "fontmapfile",special_command,1);
5612 @:fontmapfile}{\&{fontmapfile} primitive@>
5613 mp_primitive(mp, "fontmapline",special_command,2);
5614 @:fontmapline}{\&{fontmapline} primitive@>
5615 mp_primitive(mp, "step",step_token,0);
5616 @:step_}{\&{step} primitive@>
5617 mp_primitive(mp, "str",str_op,0);
5618 @:str_}{\&{str} primitive@>
5619 mp_primitive(mp, "tension",tension,0);
5620 @:tension_}{\&{tension} primitive@>
5621 mp_primitive(mp, "to",to_token,0);
5622 @:to_}{\&{to} primitive@>
5623 mp_primitive(mp, "until",until_token,0);
5624 @:until_}{\&{until} primitive@>
5625 mp_primitive(mp, "within",within_token,0);
5626 @:within_}{\&{within} primitive@>
5627 mp_primitive(mp, "write",write_command,0);
5628 @:write_}{\&{write} primitive@>
5630 @ Each primitive has a corresponding inverse, so that it is possible to
5631 display the cryptic numeric contents of |eqtb| in symbolic form.
5632 Every call of |primitive| in this program is therefore accompanied by some
5633 straightforward code that forms part of the |print_cmd_mod| routine
5636 @<Cases of |print_cmd_mod| for symbolic printing of primitives@>=
5637 case add_to_command:mp_print(mp, "addto"); break;
5638 case assignment:mp_print(mp, ":="); break;
5639 case at_least:mp_print(mp, "atleast"); break;
5640 case bchar_label:mp_print(mp, "||:"); break;
5641 case begin_group:mp_print(mp, "begingroup"); break;
5642 case colon:mp_print(mp, ":"); break;
5643 case comma:mp_print(mp, ","); break;
5644 case controls:mp_print(mp, "controls"); break;
5645 case curl_command:mp_print(mp, "curl"); break;
5646 case delimiters:mp_print(mp, "delimiters"); break;
5647 case double_colon:mp_print(mp, "::"); break;
5648 case end_group:mp_print(mp, "endgroup"); break;
5649 case every_job_command:mp_print(mp, "everyjob"); break;
5650 case exit_test:mp_print(mp, "exitif"); break;
5651 case expand_after:mp_print(mp, "expandafter"); break;
5652 case interim_command:mp_print(mp, "interim"); break;
5653 case left_brace:mp_print(mp, "{"); break;
5654 case left_bracket:mp_print(mp, "["); break;
5655 case let_command:mp_print(mp, "let"); break;
5656 case new_internal:mp_print(mp, "newinternal"); break;
5657 case of_token:mp_print(mp, "of"); break;
5658 case path_join:mp_print(mp, ".."); break;
5659 case mp_random_seed:mp_print(mp, "randomseed"); break;
5660 case relax:mp_print_char(mp, '\\'); break;
5661 case right_brace:mp_print(mp, "}"); break;
5662 case right_bracket:mp_print(mp, "]"); break;
5663 case save_command:mp_print(mp, "save"); break;
5664 case scan_tokens:mp_print(mp, "scantokens"); break;
5665 case semicolon:mp_print(mp, ";"); break;
5666 case ship_out_command:mp_print(mp, "shipout"); break;
5667 case skip_to:mp_print(mp, "skipto"); break;
5668 case special_command: if ( m==2 ) mp_print(mp, "fontmapline"); else
5669 if ( m==1 ) mp_print(mp, "fontmapfile"); else
5670 mp_print(mp, "special"); break;
5671 case step_token:mp_print(mp, "step"); break;
5672 case str_op:mp_print(mp, "str"); break;
5673 case tension:mp_print(mp, "tension"); break;
5674 case to_token:mp_print(mp, "to"); break;
5675 case until_token:mp_print(mp, "until"); break;
5676 case within_token:mp_print(mp, "within"); break;
5677 case write_command:mp_print(mp, "write"); break;
5679 @ We will deal with the other primitives later, at some point in the program
5680 where their |eq_type| and |equiv| values are more meaningful. For example,
5681 the primitives for macro definitions will be loaded when we consider the
5682 routines that define macros.
5683 It is easy to find where each particular
5684 primitive was treated by looking in the index at the end; for example, the
5685 section where |"def"| entered |eqtb| is listed under `\&{def} primitive'.
5687 @* \[14] Token lists.
5688 A \MP\ token is either symbolic or numeric or a string, or it denotes
5689 a macro parameter or capsule; so there are five corresponding ways to encode it
5691 internally: (1)~A symbolic token whose hash code is~|p|
5692 is represented by the number |p|, in the |info| field of a single-word
5693 node in~|mem|. (2)~A numeric token whose |scaled| value is~|v| is
5694 represented in a two-word node of~|mem|; the |type| field is |known|,
5695 the |name_type| field is |token|, and the |value| field holds~|v|.
5696 The fact that this token appears in a two-word node rather than a
5697 one-word node is, of course, clear from the node address.
5698 (3)~A string token is also represented in a two-word node; the |type|
5699 field is |mp_string_type|, the |name_type| field is |token|, and the
5700 |value| field holds the corresponding |str_number|. (4)~Capsules have
5701 |name_type=capsule|, and their |type| and |value| fields represent
5702 arbitrary values (in ways to be explained later). (5)~Macro parameters
5703 are like symbolic tokens in that they appear in |info| fields of
5704 one-word nodes. The $k$th parameter is represented by |expr_base+k| if it
5705 is of type \&{expr}, or by |suffix_base+k| if it is of type \&{suffix}, or
5706 by |text_base+k| if it is of type \&{text}. (Here |0<=k<param_size|.)
5707 Actual values of these parameters are kept in a separate stack, as we will
5708 see later. The constants |expr_base|, |suffix_base|, and |text_base| are,
5709 of course, chosen so that there will be no confusion between symbolic
5710 tokens and parameters of various types.
5713 the `\\{type}' field of a node has nothing to do with ``type'' in a
5714 printer's sense. It's curious that the same word is used in such different ways.
5716 @d type(A) mp->mem[(A)].hh.b0 /* identifies what kind of value this is */
5717 @d name_type(A) mp->mem[(A)].hh.b1 /* a clue to the name of this value */
5718 @d token_node_size 2 /* the number of words in a large token node */
5719 @d value_loc(A) ((A)+1) /* the word that contains the |value| field */
5720 @d value(A) mp->mem[value_loc((A))].cint /* the value stored in a large token node */
5721 @d expr_base (hash_end+1) /* code for the zeroth \&{expr} parameter */
5722 @d suffix_base (expr_base+mp->param_size) /* code for the zeroth \&{suffix} parameter */
5723 @d text_base (suffix_base+mp->param_size) /* code for the zeroth \&{text} parameter */
5725 @<Check the ``constant''...@>=
5726 if ( text_base+mp->param_size>max_halfword ) mp->bad=18;
5728 @ We have set aside a two word node beginning at |null| so that we can have
5729 |value(null)=0|. We will make use of this coincidence later.
5731 @<Initialize table entries...@>=
5732 link(null)=null; value(null)=0;
5734 @ A numeric token is created by the following trivial routine.
5737 pointer mp_new_num_tok (MP mp,scaled v) {
5738 pointer p; /* the new node */
5739 p=mp_get_node(mp, token_node_size); value(p)=v;
5740 type(p)=mp_known; name_type(p)=mp_token;
5744 @ A token list is a singly linked list of nodes in |mem|, where
5745 each node contains a token and a link. Here's a subroutine that gets rid
5746 of a token list when it is no longer needed.
5748 @c void mp_flush_token_list (MP mp,pointer p) {
5749 pointer q; /* the node being recycled */
5752 if ( q>=mp->hi_mem_min ) {
5756 case mp_vacuous: case mp_boolean_type: case mp_known:
5758 case mp_string_type:
5759 delete_str_ref(value(q));
5761 case unknown_types: case mp_pen_type: case mp_path_type:
5762 case mp_picture_type: case mp_pair_type: case mp_color_type:
5763 case mp_cmykcolor_type: case mp_transform_type: case mp_dependent:
5764 case mp_proto_dependent: case mp_independent:
5765 mp_recycle_value(mp,q);
5767 default: mp_confusion(mp, "token");
5768 @:this can't happen token}{\quad token@>
5770 mp_free_node(mp, q,token_node_size);
5775 @ The procedure |show_token_list|, which prints a symbolic form of
5776 the token list that starts at a given node |p|, illustrates these
5777 conventions. The token list being displayed should not begin with a reference
5778 count. However, the procedure is intended to be fairly robust, so that if the
5779 memory links are awry or if |p| is not really a pointer to a token list,
5780 almost nothing catastrophic can happen.
5782 An additional parameter |q| is also given; this parameter is either null
5783 or it points to a node in the token list where a certain magic computation
5784 takes place that will be explained later. (Basically, |q| is non-null when
5785 we are printing the two-line context information at the time of an error
5786 message; |q| marks the place corresponding to where the second line
5789 The generation will stop, and `\.{\char`\ ETC.}' will be printed, if the length
5790 of printing exceeds a given limit~|l|; the length of printing upon entry is
5791 assumed to be a given amount called |null_tally|. (Note that
5792 |show_token_list| sometimes uses itself recursively to print
5793 variable names within a capsule.)
5796 Unusual entries are printed in the form of all-caps tokens
5797 preceded by a space, e.g., `\.{\char`\ BAD}'.
5799 @<Declare the procedure called |show_token_list|@>=
5800 void mp_show_token_list (MP mp, integer p, integer q, integer l,
5801 integer null_tally) ;
5804 void mp_show_token_list (MP mp, integer p, integer q, integer l,
5805 integer null_tally) {
5806 small_number class,c; /* the |char_class| of previous and new tokens */
5807 integer r,v; /* temporary registers */
5808 class=percent_class;
5809 mp->tally=null_tally;
5810 while ( (p!=null) && (mp->tally<l) ) {
5812 @<Do magic computation@>;
5813 @<Display token |p| and set |c| to its class;
5814 but |return| if there are problems@>;
5818 mp_print(mp, " ETC.");
5823 @ @<Display token |p| and set |c| to its class...@>=
5824 c=letter_class; /* the default */
5825 if ( (p<0)||(p>mp->mem_end) ) {
5826 mp_print(mp, " CLOBBERED"); return;
5829 if ( p<mp->hi_mem_min ) {
5830 @<Display two-word token@>;
5833 if ( r>=expr_base ) {
5834 @<Display a parameter token@>;
5838 @<Display a collective subscript@>
5840 mp_print(mp, " IMPOSSIBLE");
5845 if ( (r<0)||(r>mp->max_str_ptr) ) {
5846 mp_print(mp, " NONEXISTENT");
5849 @<Print string |r| as a symbolic token
5850 and set |c| to its class@>;
5856 @ @<Display two-word token@>=
5857 if ( name_type(p)==mp_token ) {
5858 if ( type(p)==mp_known ) {
5859 @<Display a numeric token@>;
5860 } else if ( type(p)!=mp_string_type ) {
5861 mp_print(mp, " BAD");
5864 mp_print_char(mp, '"'); mp_print_str(mp, value(p)); mp_print_char(mp, '"');
5867 } else if ((name_type(p)!=mp_capsule)||(type(p)<mp_vacuous)||(type(p)>mp_independent) ) {
5868 mp_print(mp, " BAD");
5870 mp_print_capsule(mp,p); c=right_paren_class;
5873 @ @<Display a numeric token@>=
5874 if ( class==digit_class )
5875 mp_print_char(mp, ' ');
5878 if ( class==left_bracket_class )
5879 mp_print_char(mp, ' ');
5880 mp_print_char(mp, '['); mp_print_scaled(mp, v); mp_print_char(mp, ']');
5881 c=right_bracket_class;
5883 mp_print_scaled(mp, v); c=digit_class;
5887 @ Strictly speaking, a genuine token will never have |info(p)=0|.
5888 But we will see later (in the |print_variable_name| routine) that
5889 it is convenient to let |info(p)=0| stand for `\.{[]}'.
5891 @<Display a collective subscript@>=
5893 if ( class==left_bracket_class )
5894 mp_print_char(mp, ' ');
5895 mp_print(mp, "[]"); c=right_bracket_class;
5898 @ @<Display a parameter token@>=
5900 if ( r<suffix_base ) {
5901 mp_print(mp, "(EXPR"); r=r-(expr_base);
5903 } else if ( r<text_base ) {
5904 mp_print(mp, "(SUFFIX"); r=r-(suffix_base);
5907 mp_print(mp, "(TEXT"); r=r-(text_base);
5910 mp_print_int(mp, r); mp_print_char(mp, ')'); c=right_paren_class;
5914 @ @<Print string |r| as a symbolic token...@>=
5916 c=mp->char_class[mp->str_pool[mp->str_start[r]]];
5919 case letter_class:mp_print_char(mp, '.'); break;
5920 case isolated_classes: break;
5921 default: mp_print_char(mp, ' '); break;
5924 mp_print_str(mp, r);
5928 void mp_print_capsule (MP mp, pointer p);
5930 @ @<Declare miscellaneous procedures that were declared |forward|@>=
5931 void mp_print_capsule (MP mp, pointer p) {
5932 mp_print_char(mp, '('); mp_print_exp(mp,p,0); mp_print_char(mp, ')');
5935 @ Macro definitions are kept in \MP's memory in the form of token lists
5936 that have a few extra one-word nodes at the beginning.
5938 The first node contains a reference count that is used to tell when the
5939 list is no longer needed. To emphasize the fact that a reference count is
5940 present, we shall refer to the |info| field of this special node as the
5942 @^reference counts@>
5944 The next node or nodes after the reference count serve to describe the
5945 formal parameters. They consist of zero or more parameter tokens followed
5946 by a code for the type of macro.
5949 /* reference count preceding a macro definition or picture header */
5950 @d add_mac_ref(A) incr(ref_count((A))) /* make a new reference to a macro list */
5951 @d general_macro 0 /* preface to a macro defined with a parameter list */
5952 @d primary_macro 1 /* preface to a macro with a \&{primary} parameter */
5953 @d secondary_macro 2 /* preface to a macro with a \&{secondary} parameter */
5954 @d tertiary_macro 3 /* preface to a macro with a \&{tertiary} parameter */
5955 @d expr_macro 4 /* preface to a macro with an undelimited \&{expr} parameter */
5956 @d of_macro 5 /* preface to a macro with
5957 undelimited `\&{expr} |x| \&{of}~|y|' parameters */
5958 @d suffix_macro 6 /* preface to a macro with an undelimited \&{suffix} parameter */
5959 @d text_macro 7 /* preface to a macro with an undelimited \&{text} parameter */
5962 void mp_delete_mac_ref (MP mp,pointer p) {
5963 /* |p| points to the reference count of a macro list that is
5964 losing one reference */
5965 if ( ref_count(p)==null ) mp_flush_token_list(mp, p);
5966 else decr(ref_count(p));
5969 @ The following subroutine displays a macro, given a pointer to its
5973 @<Declare the procedure called |print_cmd_mod|@>
5974 void mp_show_macro (MP mp, pointer p, integer q, integer l) {
5975 pointer r; /* temporary storage */
5976 p=link(p); /* bypass the reference count */
5977 while ( info(p)>text_macro ){
5978 r=link(p); link(p)=null;
5979 mp_show_token_list(mp, p,null,l,0); link(p)=r; p=r;
5980 if ( l>0 ) l=l-mp->tally; else return;
5981 } /* control printing of `\.{ETC.}' */
5985 case general_macro:mp_print(mp, "->"); break;
5987 case primary_macro: case secondary_macro: case tertiary_macro:
5988 mp_print_char(mp, '<');
5989 mp_print_cmd_mod(mp, param_type,info(p));
5990 mp_print(mp, ">->");
5992 case expr_macro:mp_print(mp, "<expr>->"); break;
5993 case of_macro:mp_print(mp, "<expr>of<primary>->"); break;
5994 case suffix_macro:mp_print(mp, "<suffix>->"); break;
5995 case text_macro:mp_print(mp, "<text>->"); break;
5996 } /* there are no other cases */
5997 mp_show_token_list(mp, link(p),q,l-mp->tally,0);
6000 @* \[15] Data structures for variables.
6001 The variables of \MP\ programs can be simple, like `\.x', or they can
6002 combine the structural properties of arrays and records, like `\.{x20a.b}'.
6003 A \MP\ user assigns a type to a variable like \.{x20a.b} by saying, for
6004 example, `\.{boolean} \.{x[]a.b}'. It's time for us to study how such
6005 things are represented inside of the computer.
6007 Each variable value occupies two consecutive words, either in a two-word
6008 node called a value node, or as a two-word subfield of a larger node. One
6009 of those two words is called the |value| field; it is an integer,
6010 containing either a |scaled| numeric value or the representation of some
6011 other type of quantity. (It might also be subdivided into halfwords, in
6012 which case it is referred to by other names instead of |value|.) The other
6013 word is broken into subfields called |type|, |name_type|, and |link|. The
6014 |type| field is a quarterword that specifies the variable's type, and
6015 |name_type| is a quarterword from which \MP\ can reconstruct the
6016 variable's name (sometimes by using the |link| field as well). Thus, only
6017 1.25 words are actually devoted to the value itself; the other
6018 three-quarters of a word are overhead, but they aren't wasted because they
6019 allow \MP\ to deal with sparse arrays and to provide meaningful diagnostics.
6021 In this section we shall be concerned only with the structural aspects of
6022 variables, not their values. Later parts of the program will change the
6023 |type| and |value| fields, but we shall treat those fields as black boxes
6024 whose contents should not be touched.
6026 However, if the |type| field is |mp_structured|, there is no |value| field,
6027 and the second word is broken into two pointer fields called |attr_head|
6028 and |subscr_head|. Those fields point to additional nodes that
6029 contain structural information, as we shall see.
6031 @d subscr_head_loc(A) (A)+1 /* where |value|, |subscr_head| and |attr_head| are */
6032 @d attr_head(A) info(subscr_head_loc((A))) /* pointer to attribute info */
6033 @d subscr_head(A) link(subscr_head_loc((A))) /* pointer to subscript info */
6034 @d value_node_size 2 /* the number of words in a value node */
6036 @ An attribute node is three words long. Two of these words contain |type|
6037 and |value| fields as described above, and the third word contains
6038 additional information: There is an |attr_loc| field, which contains the
6039 hash address of the token that names this attribute; and there's also a
6040 |parent| field, which points to the value node of |mp_structured| type at the
6041 next higher level (i.e., at the level to which this attribute is
6042 subsidiary). The |name_type| in an attribute node is `|attr|'. The
6043 |link| field points to the next attribute with the same parent; these are
6044 arranged in increasing order, so that |attr_loc(link(p))>attr_loc(p)|. The
6045 final attribute node links to the constant |end_attr|, whose |attr_loc|
6046 field is greater than any legal hash address. The |attr_head| in the
6047 parent points to a node whose |name_type| is |mp_structured_root|; this
6048 node represents the null attribute, i.e., the variable that is relevant
6049 when no attributes are attached to the parent. The |attr_head| node
6050 has the fields of either
6051 a value node, a subscript node, or an attribute node, depending on what
6052 the parent would be if it were not structured; but the subscript and
6053 attribute fields are ignored, so it effectively contains only the data of
6054 a value node. The |link| field in this special node points to an attribute
6055 node whose |attr_loc| field is zero; the latter node represents a collective
6056 subscript `\.{[]}' attached to the parent, and its |link| field points to
6057 the first non-special attribute node (or to |end_attr| if there are none).
6059 A subscript node likewise occupies three words, with |type| and |value| fields
6060 plus extra information; its |name_type| is |subscr|. In this case the
6061 third word is called the |subscript| field, which is a |scaled| integer.
6062 The |link| field points to the subscript node with the next larger
6063 subscript, if any; otherwise the |link| points to the attribute node
6064 for collective subscripts at this level. We have seen that the latter node
6065 contains an upward pointer, so that the parent can be deduced.
6067 The |name_type| in a parent-less value node is |root|, and the |link|
6068 is the hash address of the token that names this value.
6070 In other words, variables have a hierarchical structure that includes
6071 enough threads running around so that the program is able to move easily
6072 between siblings, parents, and children. An example should be helpful:
6073 (The reader is advised to draw a picture while reading the following
6074 description, since that will help to firm up the ideas.)
6075 Suppose that `\.x' and `\.{x.a}' and `\.{x[]b}' and `\.{x5}'
6076 and `\.{x20b}' have been mentioned in a user's program, where
6077 \.{x[]b} has been declared to be of \&{boolean} type. Let |h(x)|, |h(a)|,
6078 and |h(b)| be the hash addresses of \.x, \.a, and~\.b. Then
6079 |eq_type(h(x))=name| and |equiv(h(x))=p|, where |p|~is a two-word value
6080 node with |name_type(p)=root| and |link(p)=h(x)|. We have |type(p)=mp_structured|,
6081 |attr_head(p)=q|, and |subscr_head(p)=r|, where |q| points to a value
6082 node and |r| to a subscript node. (Are you still following this? Use
6083 a pencil to draw a diagram.) The lone variable `\.x' is represented by
6084 |type(q)| and |value(q)|; furthermore
6085 |name_type(q)=mp_structured_root| and |link(q)=q1|, where |q1| points
6086 to an attribute node representing `\.{x[]}'. Thus |name_type(q1)=attr|,
6087 |attr_loc(q1)=collective_subscript=0|, |parent(q1)=p|,
6088 |type(q1)=mp_structured|, |attr_head(q1)=qq|, and |subscr_head(q1)=qq1|;
6089 |qq| is a three-word ``attribute-as-value'' node with |type(qq)=numeric_type|
6090 (assuming that \.{x5} is numeric, because |qq| represents `\.{x[]}'
6091 with no further attributes), |name_type(qq)=structured_root|,
6092 |attr_loc(qq)=0|, |parent(qq)=p|, and
6093 |link(qq)=qq1|. (Now pay attention to the next part.) Node |qq1| is
6094 an attribute node representing `\.{x[][]}', which has never yet
6095 occurred; its |type| field is |undefined|, and its |value| field is
6096 undefined. We have |name_type(qq1)=attr|, |attr_loc(qq1)=collective_subscript|,
6097 |parent(qq1)=q1|, and |link(qq1)=qq2|. Since |qq2| represents
6098 `\.{x[]b}', |type(qq2)=mp_unknown_boolean|; also |attr_loc(qq2)=h(b)|,
6099 |parent(qq2)=q1|, |name_type(qq2)=attr|, |link(qq2)=end_attr|.
6100 (Maybe colored lines will help untangle your picture.)
6101 Node |r| is a subscript node with |type| and |value|
6102 representing `\.{x5}'; |name_type(r)=subscr|, |subscript(r)=5.0|,
6103 and |link(r)=r1| is another subscript node. To complete the picture,
6104 see if you can guess what |link(r1)| is; give up? It's~|q1|.
6105 Furthermore |subscript(r1)=20.0|, |name_type(r1)=subscr|,
6106 |type(r1)=mp_structured|, |attr_head(r1)=qqq|, |subscr_head(r1)=qqq1|,
6107 and we finish things off with three more nodes
6108 |qqq|, |qqq1|, and |qqq2| hung onto~|r1|. (Perhaps you should start again
6109 with a larger sheet of paper.) The value of variable \.{x20b}
6110 appears in node~|qqq2|, as you can well imagine.
6112 If the example in the previous paragraph doesn't make things crystal
6113 clear, a glance at some of the simpler subroutines below will reveal how
6114 things work out in practice.
6116 The only really unusual thing about these conventions is the use of
6117 collective subscript attributes. The idea is to avoid repeating a lot of
6118 type information when many elements of an array are identical macros
6119 (for which distinct values need not be stored) or when they don't have
6120 all of the possible attributes. Branches of the structure below collective
6121 subscript attributes do not carry actual values except for macro identifiers;
6122 branches of the structure below subscript nodes do not carry significant
6123 information in their collective subscript attributes.
6125 @d attr_loc_loc(A) ((A)+2) /* where the |attr_loc| and |parent| fields are */
6126 @d attr_loc(A) info(attr_loc_loc((A))) /* hash address of this attribute */
6127 @d parent(A) link(attr_loc_loc((A))) /* pointer to |mp_structured| variable */
6128 @d subscript_loc(A) ((A)+2) /* where the |subscript| field lives */
6129 @d subscript(A) mp->mem[subscript_loc((A))].sc /* subscript of this variable */
6130 @d attr_node_size 3 /* the number of words in an attribute node */
6131 @d subscr_node_size 3 /* the number of words in a subscript node */
6132 @d collective_subscript 0 /* code for the attribute `\.{[]}' */
6134 @<Initialize table...@>=
6135 attr_loc(end_attr)=hash_end+1; parent(end_attr)=null;
6137 @ Variables of type \&{pair} will have values that point to four-word
6138 nodes containing two numeric values. The first of these values has
6139 |name_type=mp_x_part_sector| and the second has |name_type=mp_y_part_sector|;
6140 the |link| in the first points back to the node whose |value| points
6141 to this four-word node.
6143 Variables of type \&{transform} are similar, but in this case their
6144 |value| points to a 12-word node containing six values, identified by
6145 |x_part_sector|, |y_part_sector|, |mp_xx_part_sector|, |mp_xy_part_sector|,
6146 |mp_yx_part_sector|, and |mp_yy_part_sector|.
6147 Finally, variables of type \&{color} have 3~values in 6~words
6148 identified by |mp_red_part_sector|, |mp_green_part_sector|, and |mp_blue_part_sector|.
6150 When an entire structured variable is saved, the |root| indication
6151 is temporarily replaced by |saved_root|.
6153 Some variables have no name; they just are used for temporary storage
6154 while expressions are being evaluated. We call them {\sl capsules}.
6156 @d x_part_loc(A) (A) /* where the \&{xpart} is found in a pair or transform node */
6157 @d y_part_loc(A) ((A)+2) /* where the \&{ypart} is found in a pair or transform node */
6158 @d xx_part_loc(A) ((A)+4) /* where the \&{xxpart} is found in a transform node */
6159 @d xy_part_loc(A) ((A)+6) /* where the \&{xypart} is found in a transform node */
6160 @d yx_part_loc(A) ((A)+8) /* where the \&{yxpart} is found in a transform node */
6161 @d yy_part_loc(A) ((A)+10) /* where the \&{yypart} is found in a transform node */
6162 @d red_part_loc(A) (A) /* where the \&{redpart} is found in a color node */
6163 @d green_part_loc(A) ((A)+2) /* where the \&{greenpart} is found in a color node */
6164 @d blue_part_loc(A) ((A)+4) /* where the \&{bluepart} is found in a color node */
6165 @d cyan_part_loc(A) (A) /* where the \&{cyanpart} is found in a color node */
6166 @d magenta_part_loc(A) ((A)+2) /* where the \&{magentapart} is found in a color node */
6167 @d yellow_part_loc(A) ((A)+4) /* where the \&{yellowpart} is found in a color node */
6168 @d black_part_loc(A) ((A)+6) /* where the \&{blackpart} is found in a color node */
6169 @d grey_part_loc(A) (A) /* where the \&{greypart} is found in a color node */
6171 @d pair_node_size 4 /* the number of words in a pair node */
6172 @d transform_node_size 12 /* the number of words in a transform node */
6173 @d color_node_size 6 /* the number of words in a color node */
6174 @d cmykcolor_node_size 8 /* the number of words in a color node */
6177 small_number big_node_size[mp_pair_type+1];
6178 small_number sector0[mp_pair_type+1];
6179 small_number sector_offset[mp_black_part_sector+1];
6181 @ The |sector0| array gives for each big node type, |name_type| values
6182 for its first subfield; the |sector_offset| array gives for each
6183 |name_type| value, the offset from the first subfield in words;
6184 and the |big_node_size| array gives the size in words for each type of
6188 mp->big_node_size[mp_transform_type]=transform_node_size;
6189 mp->big_node_size[mp_pair_type]=pair_node_size;
6190 mp->big_node_size[mp_color_type]=color_node_size;
6191 mp->big_node_size[mp_cmykcolor_type]=cmykcolor_node_size;
6192 mp->sector0[mp_transform_type]=mp_x_part_sector;
6193 mp->sector0[mp_pair_type]=mp_x_part_sector;
6194 mp->sector0[mp_color_type]=mp_red_part_sector;
6195 mp->sector0[mp_cmykcolor_type]=mp_cyan_part_sector;
6196 for (k=mp_x_part_sector;k<= mp_yy_part_sector;k++ ) {
6197 mp->sector_offset[k]=2*(k-mp_x_part_sector);
6199 for (k=mp_red_part_sector;k<= mp_blue_part_sector ; k++) {
6200 mp->sector_offset[k]=2*(k-mp_red_part_sector);
6202 for (k=mp_cyan_part_sector;k<= mp_black_part_sector;k++ ) {
6203 mp->sector_offset[k]=2*(k-mp_cyan_part_sector);
6206 @ If |type(p)=mp_pair_type| or |mp_transform_type| and if |value(p)=null|, the
6207 procedure call |init_big_node(p)| will allocate a pair or transform node
6208 for~|p|. The individual parts of such nodes are initially of type
6212 void mp_init_big_node (MP mp,pointer p) {
6213 pointer q; /* the new node */
6214 small_number s; /* its size */
6215 s=mp->big_node_size[type(p)]; q=mp_get_node(mp, s);
6218 @<Make variable |q+s| newly independent@>;
6219 name_type(q+s)=halfp(s)+mp->sector0[type(p)];
6222 link(q)=p; value(p)=q;
6225 @ The |id_transform| function creates a capsule for the
6226 identity transformation.
6229 pointer mp_id_transform (MP mp) {
6230 pointer p,q,r; /* list manipulation registers */
6231 p=mp_get_node(mp, value_node_size); type(p)=mp_transform_type;
6232 name_type(p)=mp_capsule; value(p)=null; mp_init_big_node(mp, p); q=value(p);
6233 r=q+transform_node_size;
6236 type(r)=mp_known; value(r)=0;
6238 value(xx_part_loc(q))=unity;
6239 value(yy_part_loc(q))=unity;
6243 @ Tokens are of type |tag_token| when they first appear, but they point
6244 to |null| until they are first used as the root of a variable.
6245 The following subroutine establishes the root node on such grand occasions.
6248 void mp_new_root (MP mp,pointer x) {
6249 pointer p; /* the new node */
6250 p=mp_get_node(mp, value_node_size); type(p)=undefined; name_type(p)=mp_root;
6251 link(p)=x; equiv(x)=p;
6254 @ These conventions for variable representation are illustrated by the
6255 |print_variable_name| routine, which displays the full name of a
6256 variable given only a pointer to its two-word value packet.
6259 void mp_print_variable_name (MP mp, pointer p);
6262 void mp_print_variable_name (MP mp, pointer p) {
6263 pointer q; /* a token list that will name the variable's suffix */
6264 pointer r; /* temporary for token list creation */
6265 while ( name_type(p)>=mp_x_part_sector ) {
6266 @<Preface the output with a part specifier; |return| in the
6267 case of a capsule@>;
6270 while ( name_type(p)>mp_saved_root ) {
6271 @<Ascend one level, pushing a token onto list |q|
6272 and replacing |p| by its parent@>;
6274 r=mp_get_avail(mp); info(r)=link(p); link(r)=q;
6275 if ( name_type(p)==mp_saved_root ) mp_print(mp, "(SAVED)");
6277 mp_show_token_list(mp, r,null,el_gordo,mp->tally);
6278 mp_flush_token_list(mp, r);
6281 @ @<Ascend one level, pushing a token onto list |q|...@>=
6283 if ( name_type(p)==mp_subscr ) {
6284 r=mp_new_num_tok(mp, subscript(p));
6287 } while (name_type(p)!=mp_attr);
6288 } else if ( name_type(p)==mp_structured_root ) {
6289 p=link(p); goto FOUND;
6291 if ( name_type(p)!=mp_attr ) mp_confusion(mp, "var");
6292 @:this can't happen var}{\quad var@>
6293 r=mp_get_avail(mp); info(r)=attr_loc(p);
6300 @ @<Preface the output with a part specifier...@>=
6301 { switch (name_type(p)) {
6302 case mp_x_part_sector: mp_print_char(mp, 'x'); break;
6303 case mp_y_part_sector: mp_print_char(mp, 'y'); break;
6304 case mp_xx_part_sector: mp_print(mp, "xx"); break;
6305 case mp_xy_part_sector: mp_print(mp, "xy"); break;
6306 case mp_yx_part_sector: mp_print(mp, "yx"); break;
6307 case mp_yy_part_sector: mp_print(mp, "yy"); break;
6308 case mp_red_part_sector: mp_print(mp, "red"); break;
6309 case mp_green_part_sector: mp_print(mp, "green"); break;
6310 case mp_blue_part_sector: mp_print(mp, "blue"); break;
6311 case mp_cyan_part_sector: mp_print(mp, "cyan"); break;
6312 case mp_magenta_part_sector: mp_print(mp, "magenta"); break;
6313 case mp_yellow_part_sector: mp_print(mp, "yellow"); break;
6314 case mp_black_part_sector: mp_print(mp, "black"); break;
6315 case mp_grey_part_sector: mp_print(mp, "grey"); break;
6317 mp_print(mp, "%CAPSULE"); mp_print_int(mp, p-null); return;
6320 } /* there are no other cases */
6321 mp_print(mp, "part ");
6322 p=link(p-mp->sector_offset[name_type(p)]);
6325 @ The |interesting| function returns |true| if a given variable is not
6326 in a capsule, or if the user wants to trace capsules.
6329 boolean mp_interesting (MP mp,pointer p) {
6330 small_number t; /* a |name_type| */
6331 if ( mp->internal[mp_tracing_capsules]>0 ) {
6335 if ( t>=mp_x_part_sector ) if ( t!=mp_capsule )
6336 t=name_type(link(p-mp->sector_offset[t]));
6337 return (t!=mp_capsule);
6341 @ Now here is a subroutine that converts an unstructured type into an
6342 equivalent structured type, by inserting a |mp_structured| node that is
6343 capable of growing. This operation is done only when |name_type(p)=root|,
6344 |subscr|, or |attr|.
6346 The procedure returns a pointer to the new node that has taken node~|p|'s
6347 place in the structure. Node~|p| itself does not move, nor are its
6348 |value| or |type| fields changed in any way.
6351 pointer mp_new_structure (MP mp,pointer p) {
6352 pointer q,r=0; /* list manipulation registers */
6353 switch (name_type(p)) {
6355 q=link(p); r=mp_get_node(mp, value_node_size); equiv(q)=r;
6358 @<Link a new subscript node |r| in place of node |p|@>;
6361 @<Link a new attribute node |r| in place of node |p|@>;
6364 mp_confusion(mp, "struct");
6365 @:this can't happen struct}{\quad struct@>
6368 link(r)=link(p); type(r)=mp_structured; name_type(r)=name_type(p);
6369 attr_head(r)=p; name_type(p)=mp_structured_root;
6370 q=mp_get_node(mp, attr_node_size); link(p)=q; subscr_head(r)=q;
6371 parent(q)=r; type(q)=undefined; name_type(q)=mp_attr; link(q)=end_attr;
6372 attr_loc(q)=collective_subscript;
6376 @ @<Link a new subscript node |r| in place of node |p|@>=
6381 } while (name_type(q)!=mp_attr);
6382 q=parent(q); r=subscr_head_loc(q); /* |link(r)=subscr_head(q)| */
6386 r=mp_get_node(mp, subscr_node_size);
6387 link(q)=r; subscript(r)=subscript(p);
6390 @ If the attribute is |collective_subscript|, there are two pointers to
6391 node~|p|, so we must change both of them.
6393 @<Link a new attribute node |r| in place of node |p|@>=
6395 q=parent(p); r=attr_head(q);
6399 r=mp_get_node(mp, attr_node_size); link(q)=r;
6400 mp->mem[attr_loc_loc(r)]=mp->mem[attr_loc_loc(p)]; /* copy |attr_loc| and |parent| */
6401 if ( attr_loc(p)==collective_subscript ) {
6402 q=subscr_head_loc(parent(p));
6403 while ( link(q)!=p ) q=link(q);
6408 @ The |find_variable| routine is given a pointer~|t| to a nonempty token
6409 list of suffixes; it returns a pointer to the corresponding two-word
6410 value. For example, if |t| points to token \.x followed by a numeric
6411 token containing the value~7, |find_variable| finds where the value of
6412 \.{x7} is stored in memory. This may seem a simple task, and it
6413 usually is, except when \.{x7} has never been referenced before.
6414 Indeed, \.x may never have even been subscripted before; complexities
6415 arise with respect to updating the collective subscript information.
6417 If a macro type is detected anywhere along path~|t|, or if the first
6418 item on |t| isn't a |tag_token|, the value |null| is returned.
6419 Otherwise |p| will be a non-null pointer to a node such that
6420 |undefined<type(p)<mp_structured|.
6422 @d abort_find { return null; }
6425 pointer mp_find_variable (MP mp,pointer t) {
6426 pointer p,q,r,s; /* nodes in the ``value'' line */
6427 pointer pp,qq,rr,ss; /* nodes in the ``collective'' line */
6428 integer n; /* subscript or attribute */
6429 memory_word save_word; /* temporary storage for a word of |mem| */
6431 p=info(t); t=link(t);
6432 if ( (eq_type(p) % outer_tag) != tag_token ) abort_find;
6433 if ( equiv(p)==null ) mp_new_root(mp, p);
6436 @<Make sure that both nodes |p| and |pp| are of |mp_structured| type@>;
6437 if ( t<mp->hi_mem_min ) {
6438 @<Descend one level for the subscript |value(t)|@>
6440 @<Descend one level for the attribute |info(t)|@>;
6444 if ( type(pp)>=mp_structured ) {
6445 if ( type(pp)==mp_structured ) pp=attr_head(pp); else abort_find;
6447 if ( type(p)==mp_structured ) p=attr_head(p);
6448 if ( type(p)==undefined ) {
6449 if ( type(pp)==undefined ) { type(pp)=mp_numeric_type; value(pp)=null; };
6450 type(p)=type(pp); value(p)=null;
6455 @ Although |pp| and |p| begin together, they diverge when a subscript occurs;
6456 |pp|~stays in the collective line while |p|~goes through actual subscript
6459 @<Make sure that both nodes |p| and |pp|...@>=
6460 if ( type(pp)!=mp_structured ) {
6461 if ( type(pp)>mp_structured ) abort_find;
6462 ss=mp_new_structure(mp, pp);
6465 }; /* now |type(pp)=mp_structured| */
6466 if ( type(p)!=mp_structured ) /* it cannot be |>mp_structured| */
6467 p=mp_new_structure(mp, p) /* now |type(p)=mp_structured| */
6469 @ We want this part of the program to be reasonably fast, in case there are
6471 lots of subscripts at the same level of the data structure. Therefore
6472 we store an ``infinite'' value in the word that appears at the end of the
6473 subscript list, even though that word isn't part of a subscript node.
6475 @<Descend one level for the subscript |value(t)|@>=
6478 pp=link(attr_head(pp)); /* now |attr_loc(pp)=collective_subscript| */
6479 q=link(attr_head(p)); save_word=mp->mem[subscript_loc(q)];
6480 subscript(q)=el_gordo; s=subscr_head_loc(p); /* |link(s)=subscr_head(p)| */
6483 } while (n>subscript(s));
6484 if ( n==subscript(s) ) {
6487 p=mp_get_node(mp, subscr_node_size); link(r)=p; link(p)=s;
6488 subscript(p)=n; name_type(p)=mp_subscr; type(p)=undefined;
6490 mp->mem[subscript_loc(q)]=save_word;
6493 @ @<Descend one level for the attribute |info(t)|@>=
6499 } while (n>attr_loc(ss));
6500 if ( n<attr_loc(ss) ) {
6501 qq=mp_get_node(mp, attr_node_size); link(rr)=qq; link(qq)=ss;
6502 attr_loc(qq)=n; name_type(qq)=mp_attr; type(qq)=undefined;
6503 parent(qq)=pp; ss=qq;
6508 pp=ss; s=attr_head(p);
6511 } while (n>attr_loc(s));
6512 if ( n==attr_loc(s) ) {
6515 q=mp_get_node(mp, attr_node_size); link(r)=q; link(q)=s;
6516 attr_loc(q)=n; name_type(q)=mp_attr; type(q)=undefined;
6522 @ Variables lose their former values when they appear in a type declaration,
6523 or when they are defined to be macros or \&{let} equal to something else.
6524 A subroutine will be defined later that recycles the storage associated
6525 with any particular |type| or |value|; our goal now is to study a higher
6526 level process called |flush_variable|, which selectively frees parts of a
6529 This routine has some complexity because of examples such as
6530 `\hbox{\tt numeric x[]a[]b}'
6531 which recycles all variables of the form \.{x[i]a[j]b} (and no others), while
6532 `\hbox{\tt vardef x[]a[]=...}'
6533 discards all variables of the form \.{x[i]a[j]} followed by an arbitrary
6534 suffix, except for the collective node \.{x[]a[]} itself. The obvious way
6535 to handle such examples is to use recursion; so that's what we~do.
6538 Parameter |p| points to the root information of the variable;
6539 parameter |t| points to a list of one-word nodes that represent
6540 suffixes, with |info=collective_subscript| for subscripts.
6543 @<Declare subroutines for printing expressions@>
6544 @<Declare basic dependency-list subroutines@>
6545 @<Declare the recycling subroutines@>
6546 void mp_flush_cur_exp (MP mp,scaled v) ;
6547 @<Declare the procedure called |flush_below_variable|@>
6550 void mp_flush_variable (MP mp,pointer p, pointer t, boolean discard_suffixes) {
6551 pointer q,r; /* list manipulation */
6552 halfword n; /* attribute to match */
6554 if ( type(p)!=mp_structured ) return;
6555 n=info(t); t=link(t);
6556 if ( n==collective_subscript ) {
6557 r=subscr_head_loc(p); q=link(r); /* |q=subscr_head(p)| */
6558 while ( name_type(q)==mp_subscr ){
6559 mp_flush_variable(mp, q,t,discard_suffixes);
6561 if ( type(q)==mp_structured ) r=q;
6562 else { link(r)=link(q); mp_free_node(mp, q,subscr_node_size); }
6572 } while (attr_loc(p)<n);
6573 if ( attr_loc(p)!=n ) return;
6575 if ( discard_suffixes ) {
6576 mp_flush_below_variable(mp, p);
6578 if ( type(p)==mp_structured ) p=attr_head(p);
6579 mp_recycle_value(mp, p);
6583 @ The next procedure is simpler; it wipes out everything but |p| itself,
6584 which becomes undefined.
6586 @<Declare the procedure called |flush_below_variable|@>=
6587 void mp_flush_below_variable (MP mp, pointer p);
6590 void mp_flush_below_variable (MP mp,pointer p) {
6591 pointer q,r; /* list manipulation registers */
6592 if ( type(p)!=mp_structured ) {
6593 mp_recycle_value(mp, p); /* this sets |type(p)=undefined| */
6596 while ( name_type(q)==mp_subscr ) {
6597 mp_flush_below_variable(mp, q); r=q; q=link(q);
6598 mp_free_node(mp, r,subscr_node_size);
6600 r=attr_head(p); q=link(r); mp_recycle_value(mp, r);
6601 if ( name_type(p)<=mp_saved_root ) mp_free_node(mp, r,value_node_size);
6602 else mp_free_node(mp, r,subscr_node_size);
6603 /* we assume that |subscr_node_size=attr_node_size| */
6605 mp_flush_below_variable(mp, q); r=q; q=link(q); mp_free_node(mp, r,attr_node_size);
6606 } while (q!=end_attr);
6611 @ Just before assigning a new value to a variable, we will recycle the
6612 old value and make the old value undefined. The |und_type| routine
6613 determines what type of undefined value should be given, based on
6614 the current type before recycling.
6617 small_number mp_und_type (MP mp,pointer p) {
6619 case undefined: case mp_vacuous:
6621 case mp_boolean_type: case mp_unknown_boolean:
6622 return mp_unknown_boolean;
6623 case mp_string_type: case mp_unknown_string:
6624 return mp_unknown_string;
6625 case mp_pen_type: case mp_unknown_pen:
6626 return mp_unknown_pen;
6627 case mp_path_type: case mp_unknown_path:
6628 return mp_unknown_path;
6629 case mp_picture_type: case mp_unknown_picture:
6630 return mp_unknown_picture;
6631 case mp_transform_type: case mp_color_type: case mp_cmykcolor_type:
6632 case mp_pair_type: case mp_numeric_type:
6634 case mp_known: case mp_dependent: case mp_proto_dependent: case mp_independent:
6635 return mp_numeric_type;
6636 } /* there are no other cases */
6640 @ The |clear_symbol| routine is used when we want to redefine the equivalent
6641 of a symbolic token. It must remove any variable structure or macro
6642 definition that is currently attached to that symbol. If the |saving|
6643 parameter is true, a subsidiary structure is saved instead of destroyed.
6646 void mp_clear_symbol (MP mp,pointer p, boolean saving) {
6647 pointer q; /* |equiv(p)| */
6649 switch (eq_type(p) % outer_tag) {
6651 case secondary_primary_macro:
6652 case tertiary_secondary_macro:
6653 case expression_tertiary_macro:
6654 if ( ! saving ) mp_delete_mac_ref(mp, q);
6659 name_type(q)=mp_saved_root;
6661 mp_flush_below_variable(mp, q);
6662 mp_free_node(mp,q,value_node_size);
6669 mp->eqtb[p]=mp->eqtb[frozen_undefined];
6672 @* \[16] Saving and restoring equivalents.
6673 The nested structure given by \&{begingroup} and \&{endgroup}
6674 allows |eqtb| entries to be saved and restored, so that temporary changes
6675 can be made without difficulty. When the user requests a current value to
6676 be saved, \MP\ puts that value into its ``save stack.'' An appearance of
6677 \&{endgroup} ultimately causes the old values to be removed from the save
6678 stack and put back in their former places.
6680 The save stack is a linked list containing three kinds of entries,
6681 distinguished by their |info| fields. If |p| points to a saved item,
6685 |info(p)=0| stands for a group boundary; each \&{begingroup} contributes
6686 such an item to the save stack and each \&{endgroup} cuts back the stack
6687 until the most recent such entry has been removed.
6690 |info(p)=q|, where |1<=q<=hash_end|, means that |mem[p+1]| holds the former
6691 contents of |eqtb[q]|. Such save stack entries are generated by \&{save}
6695 |info(p)=hash_end+q|, where |q>0|, means that |value(p)| is a |scaled|
6696 integer to be restored to internal parameter number~|q|. Such entries
6697 are generated by \&{interim} commands.
6700 The global variable |save_ptr| points to the top item on the save stack.
6702 @d save_node_size 2 /* number of words per non-boundary save-stack node */
6703 @d saved_equiv(A) mp->mem[(A)+1].hh /* where an |eqtb| entry gets saved */
6704 @d save_boundary_item(A) { (A)=mp_get_avail(mp); info((A))=0;
6705 link((A))=mp->save_ptr; mp->save_ptr=(A);
6709 pointer save_ptr; /* the most recently saved item */
6711 @ @<Set init...@>=mp->save_ptr=null;
6713 @ The |save_variable| routine is given a hash address |q|; it salts this
6714 address in the save stack, together with its current equivalent,
6715 then makes token~|q| behave as though it were brand new.
6717 Nothing is stacked when |save_ptr=null|, however; there's no way to remove
6718 things from the stack when the program is not inside a group, so there's
6719 no point in wasting the space.
6721 @c void mp_save_variable (MP mp,pointer q) {
6722 pointer p; /* temporary register */
6723 if ( mp->save_ptr!=null ){
6724 p=mp_get_node(mp, save_node_size); info(p)=q; link(p)=mp->save_ptr;
6725 saved_equiv(p)=mp->eqtb[q]; mp->save_ptr=p;
6727 mp_clear_symbol(mp, q,(mp->save_ptr!=null));
6730 @ Similarly, |save_internal| is given the location |q| of an internal
6731 quantity like |mp_tracing_pens|. It creates a save stack entry of the
6734 @c void mp_save_internal (MP mp,halfword q) {
6735 pointer p; /* new item for the save stack */
6736 if ( mp->save_ptr!=null ){
6737 p=mp_get_node(mp, save_node_size); info(p)=hash_end+q;
6738 link(p)=mp->save_ptr; value(p)=mp->internal[q]; mp->save_ptr=p;
6742 @ At the end of a group, the |unsave| routine restores all of the saved
6743 equivalents in reverse order. This routine will be called only when there
6744 is at least one boundary item on the save stack.
6747 void mp_unsave (MP mp) {
6748 pointer q; /* index to saved item */
6749 pointer p; /* temporary register */
6750 while ( info(mp->save_ptr)!=0 ) {
6751 q=info(mp->save_ptr);
6753 if ( mp->internal[mp_tracing_restores]>0 ) {
6754 mp_begin_diagnostic(mp); mp_print_nl(mp, "{restoring ");
6755 mp_print(mp, mp->int_name[q-(hash_end)]); mp_print_char(mp, '=');
6756 mp_print_scaled(mp, value(mp->save_ptr)); mp_print_char(mp, '}');
6757 mp_end_diagnostic(mp, false);
6759 mp->internal[q-(hash_end)]=value(mp->save_ptr);
6761 if ( mp->internal[mp_tracing_restores]>0 ) {
6762 mp_begin_diagnostic(mp); mp_print_nl(mp, "{restoring ");
6763 mp_print_text(q); mp_print_char(mp, '}');
6764 mp_end_diagnostic(mp, false);
6766 mp_clear_symbol(mp, q,false);
6767 mp->eqtb[q]=saved_equiv(mp->save_ptr);
6768 if ( eq_type(q) % outer_tag==tag_token ) {
6770 if ( p!=null ) name_type(p)=mp_root;
6773 p=link(mp->save_ptr);
6774 mp_free_node(mp, mp->save_ptr,save_node_size); mp->save_ptr=p;
6776 p=link(mp->save_ptr); free_avail(mp->save_ptr); mp->save_ptr=p;
6779 @* \[17] Data structures for paths.
6780 When a \MP\ user specifies a path, \MP\ will create a list of knots
6781 and control points for the associated cubic spline curves. If the
6782 knots are $z_0$, $z_1$, \dots, $z_n$, there are control points
6783 $z_k^+$ and $z_{k+1}^-$ such that the cubic splines between knots
6784 $z_k$ and $z_{k+1}$ are defined by B\'ezier's formula
6785 @:Bezier}{B\'ezier, Pierre Etienne@>
6786 $$\eqalign{z(t)&=B(z_k,z_k^+,z_{k+1}^-,z_{k+1};t)\cr
6787 &=(1-t)^3z_k+3(1-t)^2tz_k^++3(1-t)t^2z_{k+1}^-+t^3z_{k+1}\cr}$$
6790 There is a 8-word node for each knot $z_k$, containing one word of
6791 control information and six words for the |x| and |y| coordinates of
6792 $z_k^-$ and $z_k$ and~$z_k^+$. The control information appears in the
6793 |left_type| and |right_type| fields, which each occupy a quarter of
6794 the first word in the node; they specify properties of the curve as it
6795 enters and leaves the knot. There's also a halfword |link| field,
6796 which points to the following knot, and a final supplementary word (of
6797 which only a quarter is used).
6799 If the path is a closed contour, knots 0 and |n| are identical;
6800 i.e., the |link| in knot |n-1| points to knot~0. But if the path
6801 is not closed, the |left_type| of knot~0 and the |right_type| of knot~|n|
6802 are equal to |endpoint|. In the latter case the |link| in knot~|n| points
6803 to knot~0, and the control points $z_0^-$ and $z_n^+$ are not used.
6805 @d left_type(A) mp->mem[(A)].hh.b0 /* characterizes the path entering this knot */
6806 @d right_type(A) mp->mem[(A)].hh.b1 /* characterizes the path leaving this knot */
6807 @d x_coord(A) mp->mem[(A)+1].sc /* the |x| coordinate of this knot */
6808 @d y_coord(A) mp->mem[(A)+2].sc /* the |y| coordinate of this knot */
6809 @d left_x(A) mp->mem[(A)+3].sc /* the |x| coordinate of previous control point */
6810 @d left_y(A) mp->mem[(A)+4].sc /* the |y| coordinate of previous control point */
6811 @d right_x(A) mp->mem[(A)+5].sc /* the |x| coordinate of next control point */
6812 @d right_y(A) mp->mem[(A)+6].sc /* the |y| coordinate of next control point */
6813 @d x_loc(A) ((A)+1) /* where the |x| coordinate is stored in a knot */
6814 @d y_loc(A) ((A)+2) /* where the |y| coordinate is stored in a knot */
6815 @d knot_coord(A) mp->mem[(A)].sc /* |x| or |y| coordinate given |x_loc| or |y_loc| */
6816 @d left_coord(A) mp->mem[(A)+2].sc
6817 /* coordinate of previous control point given |x_loc| or |y_loc| */
6818 @d right_coord(A) mp->mem[(A)+4].sc
6819 /* coordinate of next control point given |x_loc| or |y_loc| */
6820 @d knot_node_size 8 /* number of words in a knot node */
6824 mp_endpoint=0, /* |left_type| at path beginning and |right_type| at path end */
6825 mp_explicit, /* |left_type| or |right_type| when control points are known */
6826 mp_given, /* |left_type| or |right_type| when a direction is given */
6827 mp_curl, /* |left_type| or |right_type| when a curl is desired */
6828 mp_open, /* |left_type| or |right_type| when \MP\ should choose the direction */
6832 @ Before the B\'ezier control points have been calculated, the memory
6833 space they will ultimately occupy is taken up by information that can be
6834 used to compute them. There are four cases:
6837 \textindent{$\bullet$} If |right_type=mp_open|, the curve should leave
6838 the knot in the same direction it entered; \MP\ will figure out a
6842 \textindent{$\bullet$} If |right_type=mp_curl|, the curve should leave the
6843 knot in a direction depending on the angle at which it enters the next
6844 knot and on the curl parameter stored in |right_curl|.
6847 \textindent{$\bullet$} If |right_type=mp_given|, the curve should leave the
6848 knot in a nonzero direction stored as an |angle| in |right_given|.
6851 \textindent{$\bullet$} If |right_type=mp_explicit|, the B\'ezier control
6852 point for leaving this knot has already been computed; it is in the
6853 |right_x| and |right_y| fields.
6856 The rules for |left_type| are similar, but they refer to the curve entering
6857 the knot, and to \\{left} fields instead of \\{right} fields.
6859 Non-|explicit| control points will be chosen based on ``tension'' parameters
6860 in the |left_tension| and |right_tension| fields. The
6861 `\&{atleast}' option is represented by negative tension values.
6862 @:at_least_}{\&{atleast} primitive@>
6864 For example, the \MP\ path specification
6865 $$\.{z0..z1..tension atleast 1..\{curl 2\}z2..z3\{-1,-2\}..tension
6867 where \.p is the path `\.{z4..controls z45 and z54..z5}', will be represented
6869 \def\lodash{\hbox to 1.1em{\thinspace\hrulefill\thinspace}}
6870 $$\vbox{\halign{#\hfil&&\qquad#\hfil\cr
6871 |left_type|&\\{left} info&|x_coord,y_coord|&|right_type|&\\{right} info\cr
6873 |endpoint|&\lodash$,\,$\lodash&$x_0,y_0$&|curl|&$1.0,1.0$\cr
6874 |open|&\lodash$,1.0$&$x_1,y_1$&|open|&\lodash$,-1.0$\cr
6875 |curl|&$2.0,-1.0$&$x_2,y_2$&|curl|&$2.0,1.0$\cr
6876 |given|&$d,1.0$&$x_3,y_3$&|given|&$d,3.0$\cr
6877 |open|&\lodash$,4.0$&$x_4,y_4$&|explicit|&$x_{45},y_{45}$\cr
6878 |explicit|&$x_{54},y_{54}$&$x_5,y_5$&|endpoint|&\lodash$,\,$\lodash\cr}}$$
6879 Here |d| is the |angle| obtained by calling |n_arg(-unity,-two)|.
6880 Of course, this example is more complicated than anything a normal user
6883 These types must satisfy certain restrictions because of the form of \MP's
6885 (i)~|open| type never appears in the same node together with |endpoint|,
6887 (ii)~The |right_type| of a node is |explicit| if and only if the
6888 |left_type| of the following node is |explicit|.
6889 (iii)~|endpoint| types occur only at the ends, as mentioned above.
6891 @d left_curl left_x /* curl information when entering this knot */
6892 @d left_given left_x /* given direction when entering this knot */
6893 @d left_tension left_y /* tension information when entering this knot */
6894 @d right_curl right_x /* curl information when leaving this knot */
6895 @d right_given right_x /* given direction when leaving this knot */
6896 @d right_tension right_y /* tension information when leaving this knot */
6898 @ Knots can be user-supplied, or they can be created by program code,
6899 like the |split_cubic| function, or |copy_path|. The distinction is
6900 needed for the cleanup routine that runs after |split_cubic|, because
6901 it should only delete knots it has previously inserted, and never
6902 anything that was user-supplied. In order to be able to differentiate
6903 one knot from another, we will set |originator(p):=mp_metapost_user| when
6904 it appeared in the actual metapost program, and
6905 |originator(p):=mp_program_code| in all other cases.
6907 @d originator(A) mp->mem[(A)+7].hh.b0 /* the creator of this knot */
6911 mp_program_code=0, /* not created by a user */
6912 mp_metapost_user /* created by a user */
6915 @ Here is a routine that prints a given knot list
6916 in symbolic form. It illustrates the conventions discussed above,
6917 and checks for anomalies that might arise while \MP\ is being debugged.
6919 @<Declare subroutines for printing expressions@>=
6920 void mp_pr_path (MP mp,pointer h);
6923 void mp_pr_path (MP mp,pointer h) {
6924 pointer p,q; /* for list traversal */
6928 if ( (p==null)||(q==null) ) {
6929 mp_print_nl(mp, "???"); return; /* this won't happen */
6932 @<Print information for adjacent knots |p| and |q|@>;
6935 if ( (p!=h)||(left_type(h)!=mp_endpoint) ) {
6936 @<Print two dots, followed by |given| or |curl| if present@>;
6939 if ( left_type(h)!=mp_endpoint )
6940 mp_print(mp, "cycle");
6943 @ @<Print information for adjacent knots...@>=
6944 mp_print_two(mp, x_coord(p),y_coord(p));
6945 switch (right_type(p)) {
6947 if ( left_type(p)==mp_open ) mp_print(mp, "{open?}"); /* can't happen */
6949 if ( (left_type(q)!=mp_endpoint)||(q!=h) ) q=null; /* force an error */
6953 @<Print control points between |p| and |q|, then |goto done1|@>;
6956 @<Print information for a curve that begins |open|@>;
6960 @<Print information for a curve that begins |curl| or |given|@>;
6963 mp_print(mp, "???"); /* can't happen */
6967 if ( left_type(q)<=mp_explicit ) {
6968 mp_print(mp, "..control?"); /* can't happen */
6970 } else if ( (right_tension(p)!=unity)||(left_tension(q)!=unity) ) {
6971 @<Print tension between |p| and |q|@>;
6974 @ Since |n_sin_cos| produces |fraction| results, which we will print as if they
6975 were |scaled|, the magnitude of a |given| direction vector will be~4096.
6977 @<Print two dots...@>=
6979 mp_print_nl(mp, " ..");
6980 if ( left_type(p)==mp_given ) {
6981 mp_n_sin_cos(mp, left_given(p)); mp_print_char(mp, '{');
6982 mp_print_scaled(mp, mp->n_cos); mp_print_char(mp, ',');
6983 mp_print_scaled(mp, mp->n_sin); mp_print_char(mp, '}');
6984 } else if ( left_type(p)==mp_curl ){
6985 mp_print(mp, "{curl ");
6986 mp_print_scaled(mp, left_curl(p)); mp_print_char(mp, '}');
6990 @ @<Print tension between |p| and |q|@>=
6992 mp_print(mp, "..tension ");
6993 if ( right_tension(p)<0 ) mp_print(mp, "atleast");
6994 mp_print_scaled(mp, abs(right_tension(p)));
6995 if ( right_tension(p)!=left_tension(q) ){
6996 mp_print(mp, " and ");
6997 if ( left_tension(q)<0 ) mp_print(mp, "atleast");
6998 mp_print_scaled(mp, abs(left_tension(q)));
7002 @ @<Print control points between |p| and |q|, then |goto done1|@>=
7004 mp_print(mp, "..controls ");
7005 mp_print_two(mp, right_x(p),right_y(p));
7006 mp_print(mp, " and ");
7007 if ( left_type(q)!=mp_explicit ) {
7008 mp_print(mp, "??"); /* can't happen */
7011 mp_print_two(mp, left_x(q),left_y(q));
7016 @ @<Print information for a curve that begins |open|@>=
7017 if ( (left_type(p)!=mp_explicit)&&(left_type(p)!=mp_open) ) {
7018 mp_print(mp, "{open?}"); /* can't happen */
7022 @ A curl of 1 is shown explicitly, so that the user sees clearly that
7023 \MP's default curl is present.
7025 @<Print information for a curve that begins |curl|...@>=
7027 if ( left_type(p)==mp_open )
7028 mp_print(mp, "??"); /* can't happen */
7030 if ( right_type(p)==mp_curl ) {
7031 mp_print(mp, "{curl "); mp_print_scaled(mp, right_curl(p));
7033 mp_n_sin_cos(mp, right_given(p)); mp_print_char(mp, '{');
7034 mp_print_scaled(mp, mp->n_cos); mp_print_char(mp, ',');
7035 mp_print_scaled(mp, mp->n_sin);
7037 mp_print_char(mp, '}');
7040 @ It is convenient to have another version of |pr_path| that prints the path
7041 as a diagnostic message.
7043 @<Declare subroutines for printing expressions@>=
7044 void mp_print_path (MP mp,pointer h, const char *s, boolean nuline) {
7045 mp_print_diagnostic(mp, "Path", s, nuline); mp_print_ln(mp);
7048 mp_end_diagnostic(mp, true);
7051 @ If we want to duplicate a knot node, we can say |copy_knot|:
7054 pointer mp_copy_knot (MP mp,pointer p) {
7055 pointer q; /* the copy */
7056 int k; /* runs through the words of a knot node */
7057 q=mp_get_node(mp, knot_node_size);
7058 for (k=0;k<knot_node_size;k++) {
7059 mp->mem[q+k]=mp->mem[p+k];
7061 originator(q)=originator(p);
7065 @ The |copy_path| routine makes a clone of a given path.
7068 pointer mp_copy_path (MP mp, pointer p) {
7069 pointer q,pp,qq; /* for list manipulation */
7070 q=mp_copy_knot(mp, p);
7073 link(qq)=mp_copy_knot(mp, pp);
7082 @ Just before |ship_out|, knot lists are exported for printing.
7084 The |gr_XXXX| macros are defined in |mppsout.h|.
7087 mp_knot *mp_export_knot (MP mp,pointer p) {
7088 mp_knot *q; /* the copy */
7091 q = mp_xmalloc(mp, 1, sizeof (mp_knot));
7092 memset(q,0,sizeof (mp_knot));
7093 gr_left_type(q) = left_type(p);
7094 gr_right_type(q) = right_type(p);
7095 gr_x_coord(q) = x_coord(p);
7096 gr_y_coord(q) = y_coord(p);
7097 gr_left_x(q) = left_x(p);
7098 gr_left_y(q) = left_y(p);
7099 gr_right_x(q) = right_x(p);
7100 gr_right_y(q) = right_y(p);
7101 gr_originator(q) = originator(p);
7105 @ The |export_knot_list| routine therefore also makes a clone
7109 mp_knot *mp_export_knot_list (MP mp, pointer p) {
7110 mp_knot *q, *qq; /* for list manipulation */
7111 pointer pp; /* for list manipulation */
7114 q=mp_export_knot(mp, p);
7117 gr_next_knot(qq)=mp_export_knot(mp, pp);
7118 qq=gr_next_knot(qq);
7126 @ Similarly, there's a way to copy the {\sl reverse\/} of a path. This procedure
7127 returns a pointer to the first node of the copy, if the path is a cycle,
7128 but to the final node of a non-cyclic copy. The global
7129 variable |path_tail| will point to the final node of the original path;
7130 this trick makes it easier to implement `\&{doublepath}'.
7132 All node types are assumed to be |endpoint| or |explicit| only.
7135 pointer mp_htap_ypoc (MP mp,pointer p) {
7136 pointer q,pp,qq,rr; /* for list manipulation */
7137 q=mp_get_node(mp, knot_node_size); /* this will correspond to |p| */
7140 right_type(qq)=left_type(pp); left_type(qq)=right_type(pp);
7141 x_coord(qq)=x_coord(pp); y_coord(qq)=y_coord(pp);
7142 right_x(qq)=left_x(pp); right_y(qq)=left_y(pp);
7143 left_x(qq)=right_x(pp); left_y(qq)=right_y(pp);
7144 originator(qq)=originator(pp);
7145 if ( link(pp)==p ) {
7146 link(q)=qq; mp->path_tail=pp; return q;
7148 rr=mp_get_node(mp, knot_node_size); link(rr)=qq; qq=rr; pp=link(pp);
7153 pointer path_tail; /* the node that links to the beginning of a path */
7155 @ When a cyclic list of knot nodes is no longer needed, it can be recycled by
7156 calling the following subroutine.
7158 @<Declare the recycling subroutines@>=
7159 void mp_toss_knot_list (MP mp,pointer p) ;
7162 void mp_toss_knot_list (MP mp,pointer p) {
7163 pointer q; /* the node being freed */
7164 pointer r; /* the next node */
7168 mp_free_node(mp, q,knot_node_size); q=r;
7172 @* \[18] Choosing control points.
7173 Now we must actually delve into one of \MP's more difficult routines,
7174 the |make_choices| procedure that chooses angles and control points for
7175 the splines of a curve when the user has not specified them explicitly.
7176 The parameter to |make_choices| points to a list of knots and
7177 path information, as described above.
7179 A path decomposes into independent segments at ``breakpoint'' knots,
7180 which are knots whose left and right angles are both prespecified in
7181 some way (i.e., their |left_type| and |right_type| aren't both open).
7184 @<Declare the procedure called |solve_choices|@>
7185 void mp_make_choices (MP mp,pointer knots) {
7186 pointer h; /* the first breakpoint */
7187 pointer p,q; /* consecutive breakpoints being processed */
7188 @<Other local variables for |make_choices|@>;
7189 check_arith; /* make sure that |arith_error=false| */
7190 if ( mp->internal[mp_tracing_choices]>0 )
7191 mp_print_path(mp, knots,", before choices",true);
7192 @<If consecutive knots are equal, join them explicitly@>;
7193 @<Find the first breakpoint, |h|, on the path;
7194 insert an artificial breakpoint if the path is an unbroken cycle@>;
7197 @<Fill in the control points between |p| and the next breakpoint,
7198 then advance |p| to that breakpoint@>;
7200 if ( mp->internal[mp_tracing_choices]>0 )
7201 mp_print_path(mp, knots,", after choices",true);
7202 if ( mp->arith_error ) {
7203 @<Report an unexpected problem during the choice-making@>;
7207 @ @<Report an unexpected problem during the choice...@>=
7209 print_err("Some number got too big");
7210 @.Some number got too big@>
7211 help2("The path that I just computed is out of range.")
7212 ("So it will probably look funny. Proceed, for a laugh.");
7213 mp_put_get_error(mp); mp->arith_error=false;
7216 @ Two knots in a row with the same coordinates will always be joined
7217 by an explicit ``curve'' whose control points are identical with the
7220 @<If consecutive knots are equal, join them explicitly@>=
7224 if ( x_coord(p)==x_coord(q) && y_coord(p)==y_coord(q) && right_type(p)>mp_explicit ) {
7225 right_type(p)=mp_explicit;
7226 if ( left_type(p)==mp_open ) {
7227 left_type(p)=mp_curl; left_curl(p)=unity;
7229 left_type(q)=mp_explicit;
7230 if ( right_type(q)==mp_open ) {
7231 right_type(q)=mp_curl; right_curl(q)=unity;
7233 right_x(p)=x_coord(p); left_x(q)=x_coord(p);
7234 right_y(p)=y_coord(p); left_y(q)=y_coord(p);
7239 @ If there are no breakpoints, it is necessary to compute the direction
7240 angles around an entire cycle. In this case the |left_type| of the first
7241 node is temporarily changed to |end_cycle|.
7243 @<Find the first breakpoint, |h|, on the path...@>=
7246 if ( left_type(h)!=mp_open ) break;
7247 if ( right_type(h)!=mp_open ) break;
7250 left_type(h)=mp_end_cycle; break;
7254 @ If |right_type(p)<given| and |q=link(p)|, we must have
7255 |right_type(p)=left_type(q)=mp_explicit| or |endpoint|.
7257 @<Fill in the control points between |p| and the next breakpoint...@>=
7259 if ( right_type(p)>=mp_given ) {
7260 while ( (left_type(q)==mp_open)&&(right_type(q)==mp_open) ) q=link(q);
7261 @<Fill in the control information between
7262 consecutive breakpoints |p| and |q|@>;
7263 } else if ( right_type(p)==mp_endpoint ) {
7264 @<Give reasonable values for the unused control points between |p| and~|q|@>;
7268 @ This step makes it possible to transform an explicitly computed path without
7269 checking the |left_type| and |right_type| fields.
7271 @<Give reasonable values for the unused control points between |p| and~|q|@>=
7273 right_x(p)=x_coord(p); right_y(p)=y_coord(p);
7274 left_x(q)=x_coord(q); left_y(q)=y_coord(q);
7277 @ Before we can go further into the way choices are made, we need to
7278 consider the underlying theory. The basic ideas implemented in |make_choices|
7279 are due to John Hobby, who introduced the notion of ``mock curvature''
7280 @^Hobby, John Douglas@>
7281 at a knot. Angles are chosen so that they preserve mock curvature when
7282 a knot is passed, and this has been found to produce excellent results.
7284 It is convenient to introduce some notations that simplify the necessary
7285 formulas. Let $d_{k,k+1}=\vert z\k-z_k\vert$ be the (nonzero) distance
7286 between knots |k| and |k+1|; and let
7287 $${z\k-z_k\over z_k-z_{k-1}}={d_{k,k+1}\over d_{k-1,k}}e^{i\psi_k}$$
7288 so that a polygonal line from $z_{k-1}$ to $z_k$ to $z\k$ turns left
7289 through an angle of~$\psi_k$. We assume that $\vert\psi_k\vert\L180^\circ$.
7290 The control points for the spline from $z_k$ to $z\k$ will be denoted by
7291 $$\eqalign{z_k^+&=z_k+
7292 \textstyle{1\over3}\rho_k e^{i\theta_k}(z\k-z_k),\cr
7294 \textstyle{1\over3}\sigma\k e^{-i\phi\k}(z\k-z_k),\cr}$$
7295 where $\rho_k$ and $\sigma\k$ are nonnegative ``velocity ratios'' at the
7296 beginning and end of the curve, while $\theta_k$ and $\phi\k$ are the
7297 corresponding ``offset angles.'' These angles satisfy the condition
7298 $$\theta_k+\phi_k+\psi_k=0,\eqno(*)$$
7299 whenever the curve leaves an intermediate knot~|k| in the direction that
7302 @ Let $\alpha_k$ and $\beta\k$ be the reciprocals of the ``tension'' of
7303 the curve at its beginning and ending points. This means that
7304 $\rho_k=\alpha_k f(\theta_k,\phi\k)$ and $\sigma\k=\beta\k f(\phi\k,\theta_k)$,
7305 where $f(\theta,\phi)$ is \MP's standard velocity function defined in
7306 the |velocity| subroutine. The cubic spline $B(z_k^{\phantom+},z_k^+,
7307 z\k^-,z\k^{\phantom+};t)$
7310 $${2\sigma\k\sin(\theta_k+\phi\k)-6\sin\theta_k\over\rho_k^2d_{k,k+1}}
7311 \qquad{\rm and}\qquad
7312 {2\rho_k\sin(\theta_k+\phi\k)-6\sin\phi\k\over\sigma\k^2d_{k,k+1}}$$
7313 at |t=0| and |t=1|, respectively. The mock curvature is the linear
7315 approximation to this true curvature that arises in the limit for
7316 small $\theta_k$ and~$\phi\k$, if second-order terms are discarded.
7317 The standard velocity function satisfies
7318 $$f(\theta,\phi)=1+O(\theta^2+\theta\phi+\phi^2);$$
7319 hence the mock curvatures are respectively
7320 $${2\beta\k(\theta_k+\phi\k)-6\theta_k\over\alpha_k^2d_{k,k+1}}
7321 \qquad{\rm and}\qquad
7322 {2\alpha_k(\theta_k+\phi\k)-6\phi\k\over\beta\k^2d_{k,k+1}}.\eqno(**)$$
7324 @ The turning angles $\psi_k$ are given, and equation $(*)$ above
7325 determines $\phi_k$ when $\theta_k$ is known, so the task of
7326 angle selection is essentially to choose appropriate values for each
7327 $\theta_k$. When equation~$(*)$ is used to eliminate $\phi$~variables
7328 from $(**)$, we obtain a system of linear equations of the form
7329 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
7331 $$A_k={\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
7332 \qquad B_k={3-\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
7333 \qquad C_k={3-\beta\k\over\alpha_k^2d_{k,k+1}},
7334 \qquad D_k={\beta\k\over\alpha_k^2d_{k,k+1}}.$$
7335 The tensions are always $3\over4$ or more, hence each $\alpha$ and~$\beta$
7336 will be at most $4\over3$. It follows that $B_k\G{5\over4}A_k$ and
7337 $C_k\G{5\over4}D_k$; hence the equations are diagonally dominant;
7338 hence they have a unique solution. Moreover, in most cases the tensions
7339 are equal to~1, so that $B_k=2A_k$ and $C_k=2D_k$. This makes the
7340 solution numerically stable, and there is an exponential damping
7341 effect: The data at knot $k\pm j$ affects the angle at knot~$k$ by
7342 a factor of~$O(2^{-j})$.
7344 @ However, we still must consider the angles at the starting and ending
7345 knots of a non-cyclic path. These angles might be given explicitly, or
7346 they might be specified implicitly in terms of an amount of ``curl.''
7348 Let's assume that angles need to be determined for a non-cyclic path
7349 starting at $z_0$ and ending at~$z_n$. Then equations of the form
7350 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta_{k+1}=R_k$$
7351 have been given for $0<k<n$, and it will be convenient to introduce
7352 equations of the same form for $k=0$ and $k=n$, where
7353 $$A_0=B_0=C_n=D_n=0.$$
7354 If $\theta_0$ is supposed to have a given value $E_0$, we simply
7355 define $C_0=1$, $D_0=0$, and $R_0=E_0$. Otherwise a curl
7356 parameter, $\gamma_0$, has been specified at~$z_0$; this means
7357 that the mock curvature at $z_0$ should be $\gamma_0$ times the
7358 mock curvature at $z_1$; i.e.,
7359 $${2\beta_1(\theta_0+\phi_1)-6\theta_0\over\alpha_0^2d_{01}}
7360 =\gamma_0{2\alpha_0(\theta_0+\phi_1)-6\phi_1\over\beta_1^2d_{01}}.$$
7361 This equation simplifies to
7362 $$(\alpha_0\chi_0+3-\beta_1)\theta_0+
7363 \bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\theta_1=
7364 -\bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\psi_1,$$
7365 where $\chi_0=\alpha_0^2\gamma_0/\beta_1^2$; so we can set $C_0=
7366 \chi_0\alpha_0+3-\beta_1$, $D_0=(3-\alpha_0)\chi_0+\beta_1$, $R_0=-D_0\psi_1$.
7367 It can be shown that $C_0>0$ and $C_0B_1-A_1D_0>0$ when $\gamma_0\G0$,
7368 hence the linear equations remain nonsingular.
7370 Similar considerations apply at the right end, when the final angle $\phi_n$
7371 may or may not need to be determined. It is convenient to let $\psi_n=0$,
7372 hence $\theta_n=-\phi_n$. We either have an explicit equation $\theta_n=E_n$,
7374 $$\bigl((3-\beta_n)\chi_n+\alpha_{n-1}\bigr)\theta_{n-1}+
7375 (\beta_n\chi_n+3-\alpha_{n-1})\theta_n=0,\qquad
7376 \chi_n={\beta_n^2\gamma_n\over\alpha_{n-1}^2}.$$
7378 When |make_choices| chooses angles, it must compute the coefficients of
7379 these linear equations, then solve the equations. To compute the coefficients,
7380 it is necessary to compute arctangents of the given turning angles~$\psi_k$.
7381 When the equations are solved, the chosen directions $\theta_k$ are put
7382 back into the form of control points by essentially computing sines and
7385 @ OK, we are ready to make the hard choices of |make_choices|.
7386 Most of the work is relegated to an auxiliary procedure
7387 called |solve_choices|, which has been introduced to keep
7388 |make_choices| from being extremely long.
7390 @<Fill in the control information between...@>=
7391 @<Calculate the turning angles $\psi_k$ and the distances $d_{k,k+1}$;
7392 set $n$ to the length of the path@>;
7393 @<Remove |open| types at the breakpoints@>;
7394 mp_solve_choices(mp, p,q,n)
7396 @ It's convenient to precompute quantities that will be needed several
7397 times later. The values of |delta_x[k]| and |delta_y[k]| will be the
7398 coordinates of $z\k-z_k$, and the magnitude of this vector will be
7399 |delta[k]=@t$d_{k,k+1}$@>|. The path angle $\psi_k$ between $z_k-z_{k-1}$
7400 and $z\k-z_k$ will be stored in |psi[k]|.
7403 int path_size; /* maximum number of knots between breakpoints of a path */
7406 scaled *delta; /* knot differences */
7407 angle *psi; /* turning angles */
7409 @ @<Dealloc variables@>=
7415 @ @<Other local variables for |make_choices|@>=
7416 int k,n; /* current and final knot numbers */
7417 pointer s,t; /* registers for list traversal */
7418 scaled delx,dely; /* directions where |open| meets |explicit| */
7419 fraction sine,cosine; /* trig functions of various angles */
7421 @ @<Calculate the turning angles...@>=
7424 k=0; s=p; n=mp->path_size;
7427 mp->delta_x[k]=x_coord(t)-x_coord(s);
7428 mp->delta_y[k]=y_coord(t)-y_coord(s);
7429 mp->delta[k]=mp_pyth_add(mp, mp->delta_x[k],mp->delta_y[k]);
7431 sine=mp_make_fraction(mp, mp->delta_y[k-1],mp->delta[k-1]);
7432 cosine=mp_make_fraction(mp, mp->delta_x[k-1],mp->delta[k-1]);
7433 mp->psi[k]=mp_n_arg(mp, mp_take_fraction(mp, mp->delta_x[k],cosine)+
7434 mp_take_fraction(mp, mp->delta_y[k],sine),
7435 mp_take_fraction(mp, mp->delta_y[k],cosine)-
7436 mp_take_fraction(mp, mp->delta_x[k],sine));
7439 if ( k==mp->path_size ) {
7440 mp_reallocate_paths(mp, mp->path_size+(mp->path_size>>2));
7441 goto RESTART; /* retry, loop size has changed */
7444 } while (!((k>=n)&&(left_type(s)!=mp_end_cycle)));
7445 if ( k==n ) mp->psi[n]=0; else mp->psi[k]=mp->psi[1];
7448 @ When we get to this point of the code, |right_type(p)| is either
7449 |given| or |curl| or |open|. If it is |open|, we must have
7450 |left_type(p)=mp_end_cycle| or |left_type(p)=mp_explicit|. In the latter
7451 case, the |open| type is converted to |given|; however, if the
7452 velocity coming into this knot is zero, the |open| type is
7453 converted to a |curl|, since we don't know the incoming direction.
7455 Similarly, |left_type(q)| is either |given| or |curl| or |open| or
7456 |mp_end_cycle|. The |open| possibility is reduced either to |given| or to |curl|.
7458 @<Remove |open| types at the breakpoints@>=
7459 if ( left_type(q)==mp_open ) {
7460 delx=right_x(q)-x_coord(q); dely=right_y(q)-y_coord(q);
7461 if ( (delx==0)&&(dely==0) ) {
7462 left_type(q)=mp_curl; left_curl(q)=unity;
7464 left_type(q)=mp_given; left_given(q)=mp_n_arg(mp, delx,dely);
7467 if ( (right_type(p)==mp_open)&&(left_type(p)==mp_explicit) ) {
7468 delx=x_coord(p)-left_x(p); dely=y_coord(p)-left_y(p);
7469 if ( (delx==0)&&(dely==0) ) {
7470 right_type(p)=mp_curl; right_curl(p)=unity;
7472 right_type(p)=mp_given; right_given(p)=mp_n_arg(mp, delx,dely);
7476 @ Linear equations need to be solved whenever |n>1|; and also when |n=1|
7477 and exactly one of the breakpoints involves a curl. The simplest case occurs
7478 when |n=1| and there is a curl at both breakpoints; then we simply draw
7481 But before coding up the simple cases, we might as well face the general case,
7482 since we must deal with it sooner or later, and since the general case
7483 is likely to give some insight into the way simple cases can be handled best.
7485 When there is no cycle, the linear equations to be solved form a tridiagonal
7486 system, and we can apply the standard technique of Gaussian elimination
7487 to convert that system to a sequence of equations of the form
7488 $$\theta_0+u_0\theta_1=v_0,\quad
7489 \theta_1+u_1\theta_2=v_1,\quad\ldots,\quad
7490 \theta_{n-1}+u_{n-1}\theta_n=v_{n-1},\quad
7492 It is possible to do this diagonalization while generating the equations.
7493 Once $\theta_n$ is known, it is easy to determine $\theta_{n-1}$, \dots,
7494 $\theta_1$, $\theta_0$; thus, the equations will be solved.
7496 The procedure is slightly more complex when there is a cycle, but the
7497 basic idea will be nearly the same. In the cyclic case the right-hand
7498 sides will be $v_k+w_k\theta_0$ instead of simply $v_k$, and we will start
7499 the process off with $u_0=v_0=0$, $w_0=1$. The final equation will be not
7500 $\theta_n=v_n$ but $\theta_n+u_n\theta_1=v_n+w_n\theta_0$; an appropriate
7501 ending routine will take account of the fact that $\theta_n=\theta_0$ and
7502 eliminate the $w$'s from the system, after which the solution can be
7505 When $u_k$, $v_k$, and $w_k$ are being computed, the three pointer
7506 variables |r|, |s|,~|t| will point respectively to knots |k-1|, |k|,
7507 and~|k+1|. The $u$'s and $w$'s are scaled by $2^{28}$, i.e., they are
7508 of type |fraction|; the $\theta$'s and $v$'s are of type |angle|.
7511 angle *theta; /* values of $\theta_k$ */
7512 fraction *uu; /* values of $u_k$ */
7513 angle *vv; /* values of $v_k$ */
7514 fraction *ww; /* values of $w_k$ */
7516 @ @<Dealloc variables@>=
7522 @ @<Declare |mp_reallocate| functions@>=
7523 void mp_reallocate_paths (MP mp, int l);
7526 void mp_reallocate_paths (MP mp, int l) {
7527 XREALLOC (mp->delta_x, l, scaled);
7528 XREALLOC (mp->delta_y, l, scaled);
7529 XREALLOC (mp->delta, l, scaled);
7530 XREALLOC (mp->psi, l, angle);
7531 XREALLOC (mp->theta, l, angle);
7532 XREALLOC (mp->uu, l, fraction);
7533 XREALLOC (mp->vv, l, angle);
7534 XREALLOC (mp->ww, l, fraction);
7538 @ Our immediate problem is to get the ball rolling by setting up the
7539 first equation or by realizing that no equations are needed, and to fit
7540 this initialization into a framework suitable for the overall computation.
7542 @<Declare the procedure called |solve_choices|@>=
7543 @<Declare subroutines needed by |solve_choices|@>
7544 void mp_solve_choices (MP mp,pointer p, pointer q, halfword n) {
7545 int k; /* current knot number */
7546 pointer r,s,t; /* registers for list traversal */
7547 @<Other local variables for |solve_choices|@>;
7552 @<Get the linear equations started; or |return|
7553 with the control points in place, if linear equations
7556 switch (left_type(s)) {
7557 case mp_end_cycle: case mp_open:
7558 @<Set up equation to match mock curvatures
7559 at $z_k$; then |goto found| with $\theta_n$
7560 adjusted to equal $\theta_0$, if a cycle has ended@>;
7563 @<Set up equation for a curl at $\theta_n$
7567 @<Calculate the given value of $\theta_n$
7570 } /* there are no other cases */
7575 @<Finish choosing angles and assigning control points@>;
7578 @ On the first time through the loop, we have |k=0| and |r| is not yet
7579 defined. The first linear equation, if any, will have $A_0=B_0=0$.
7581 @<Get the linear equations started...@>=
7582 switch (right_type(s)) {
7584 if ( left_type(t)==mp_given ) {
7585 @<Reduce to simple case of two givens and |return|@>
7587 @<Set up the equation for a given value of $\theta_0$@>;
7591 if ( left_type(t)==mp_curl ) {
7592 @<Reduce to simple case of straight line and |return|@>
7594 @<Set up the equation for a curl at $\theta_0$@>;
7598 mp->uu[0]=0; mp->vv[0]=0; mp->ww[0]=fraction_one;
7599 /* this begins a cycle */
7601 } /* there are no other cases */
7603 @ The general equation that specifies equality of mock curvature at $z_k$ is
7604 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
7605 as derived above. We want to combine this with the already-derived equation
7606 $\theta_{k-1}+u_{k-1}\theta_k=v_{k-1}+w_{k-1}\theta_0$ in order to obtain
7608 $\theta_k+u_k\theta\k=v_k+w_k\theta_0$. This can be done by dividing the
7610 $$(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}
7611 -A_kw_{k-1}\theta_0$$
7612 by $B_k-u_{k-1}A_k+C_k$. The trick is to do this carefully with
7613 fixed-point arithmetic, avoiding the chance of overflow while retaining
7616 The calculations will be performed in several registers that
7617 provide temporary storage for intermediate quantities.
7619 @<Other local variables for |solve_choices|@>=
7620 fraction aa,bb,cc,ff,acc; /* temporary registers */
7621 scaled dd,ee; /* likewise, but |scaled| */
7622 scaled lt,rt; /* tension values */
7624 @ @<Set up equation to match mock curvatures...@>=
7625 { @<Calculate the values $\\{aa}=A_k/B_k$, $\\{bb}=D_k/C_k$,
7626 $\\{dd}=(3-\alpha_{k-1})d_{k,k+1}$, $\\{ee}=(3-\beta\k)d_{k-1,k}$,
7627 and $\\{cc}=(B_k-u_{k-1}A_k)/B_k$@>;
7628 @<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>;
7629 mp->uu[k]=mp_take_fraction(mp, ff,bb);
7630 @<Calculate the values of $v_k$ and $w_k$@>;
7631 if ( left_type(s)==mp_end_cycle ) {
7632 @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>;
7636 @ Since tension values are never less than 3/4, the values |aa| and
7637 |bb| computed here are never more than 4/5.
7639 @<Calculate the values $\\{aa}=...@>=
7640 if ( abs(right_tension(r))==unity) {
7641 aa=fraction_half; dd=2*mp->delta[k];
7643 aa=mp_make_fraction(mp, unity,3*abs(right_tension(r))-unity);
7644 dd=mp_take_fraction(mp, mp->delta[k],
7645 fraction_three-mp_make_fraction(mp, unity,abs(right_tension(r))));
7647 if ( abs(left_tension(t))==unity ){
7648 bb=fraction_half; ee=2*mp->delta[k-1];
7650 bb=mp_make_fraction(mp, unity,3*abs(left_tension(t))-unity);
7651 ee=mp_take_fraction(mp, mp->delta[k-1],
7652 fraction_three-mp_make_fraction(mp, unity,abs(left_tension(t))));
7654 cc=fraction_one-mp_take_fraction(mp, mp->uu[k-1],aa)
7656 @ The ratio to be calculated in this step can be written in the form
7657 $$\beta_k^2\cdot\\{ee}\over\beta_k^2\cdot\\{ee}+\alpha_k^2\cdot
7658 \\{cc}\cdot\\{dd},$$
7659 because of the quantities just calculated. The values of |dd| and |ee|
7660 will not be needed after this step has been performed.
7662 @<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>=
7663 dd=mp_take_fraction(mp, dd,cc); lt=abs(left_tension(s)); rt=abs(right_tension(s));
7664 if ( lt!=rt ) { /* $\beta_k^{-1}\ne\alpha_k^{-1}$ */
7666 ff=mp_make_fraction(mp, lt,rt);
7667 ff=mp_take_fraction(mp, ff,ff); /* $\alpha_k^2/\beta_k^2$ */
7668 dd=mp_take_fraction(mp, dd,ff);
7670 ff=mp_make_fraction(mp, rt,lt);
7671 ff=mp_take_fraction(mp, ff,ff); /* $\beta_k^2/\alpha_k^2$ */
7672 ee=mp_take_fraction(mp, ee,ff);
7675 ff=mp_make_fraction(mp, ee,ee+dd)
7677 @ The value of $u_{k-1}$ will be |<=1| except when $k=1$ and the previous
7678 equation was specified by a curl. In that case we must use a special
7679 method of computation to prevent overflow.
7681 Fortunately, the calculations turn out to be even simpler in this ``hard''
7682 case. The curl equation makes $w_0=0$ and $v_0=-u_0\psi_1$, hence
7683 $-B_1\psi_1-A_1v_0=-(B_1-u_0A_1)\psi_1=-\\{cc}\cdot B_1\psi_1$.
7685 @<Calculate the values of $v_k$ and $w_k$@>=
7686 acc=-mp_take_fraction(mp, mp->psi[k+1],mp->uu[k]);
7687 if ( right_type(r)==mp_curl ) {
7689 mp->vv[k]=acc-mp_take_fraction(mp, mp->psi[1],fraction_one-ff);
7691 ff=mp_make_fraction(mp, fraction_one-ff,cc); /* this is
7692 $B_k/(C_k+B_k-u_{k-1}A_k)<5$ */
7693 acc=acc-mp_take_fraction(mp, mp->psi[k],ff);
7694 ff=mp_take_fraction(mp, ff,aa); /* this is $A_k/(C_k+B_k-u_{k-1}A_k)$ */
7695 mp->vv[k]=acc-mp_take_fraction(mp, mp->vv[k-1],ff);
7696 if ( mp->ww[k-1]==0 ) mp->ww[k]=0;
7697 else mp->ww[k]=-mp_take_fraction(mp, mp->ww[k-1],ff);
7700 @ When a complete cycle has been traversed, we have $\theta_k+u_k\theta\k=
7701 v_k+w_k\theta_0$, for |1<=k<=n|. We would like to determine the value of
7702 $\theta_n$ and reduce the system to the form $\theta_k+u_k\theta\k=v_k$
7703 for |0<=k<n|, so that the cyclic case can be finished up just as if there
7706 The idea in the following code is to observe that
7707 $$\eqalign{\theta_n&=v_n+w_n\theta_0-u_n\theta_1=\cdots\cr
7708 &=v_n+w_n\theta_0-u_n\bigl(v_1+w_1\theta_0-u_1(v_2+\cdots
7709 -u_{n-2}(v_{n-1}+w_{n-1}\theta_0-u_{n-1}\theta_0))\bigr),\cr}$$
7710 so we can solve for $\theta_n=\theta_0$.
7712 @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>=
7714 aa=0; bb=fraction_one; /* we have |k=n| */
7717 aa=mp->vv[k]-mp_take_fraction(mp, aa,mp->uu[k]);
7718 bb=mp->ww[k]-mp_take_fraction(mp, bb,mp->uu[k]);
7719 } while (k!=n); /* now $\theta_n=\\{aa}+\\{bb}\cdot\theta_n$ */
7720 aa=mp_make_fraction(mp, aa,fraction_one-bb);
7721 mp->theta[n]=aa; mp->vv[0]=aa;
7722 for (k=1;k<=n-1;k++) {
7723 mp->vv[k]=mp->vv[k]+mp_take_fraction(mp, aa,mp->ww[k]);
7728 @ @d reduce_angle(A) if ( abs((A))>one_eighty_deg ) {
7729 if ( (A)>0 ) (A)=(A)-three_sixty_deg; else (A)=(A)+three_sixty_deg; }
7731 @<Calculate the given value of $\theta_n$...@>=
7733 mp->theta[n]=left_given(s)-mp_n_arg(mp, mp->delta_x[n-1],mp->delta_y[n-1]);
7734 reduce_angle(mp->theta[n]);
7738 @ @<Set up the equation for a given value of $\theta_0$@>=
7740 mp->vv[0]=right_given(s)-mp_n_arg(mp, mp->delta_x[0],mp->delta_y[0]);
7741 reduce_angle(mp->vv[0]);
7742 mp->uu[0]=0; mp->ww[0]=0;
7745 @ @<Set up the equation for a curl at $\theta_0$@>=
7746 { cc=right_curl(s); lt=abs(left_tension(t)); rt=abs(right_tension(s));
7747 if ( (rt==unity)&&(lt==unity) )
7748 mp->uu[0]=mp_make_fraction(mp, cc+cc+unity,cc+two);
7750 mp->uu[0]=mp_curl_ratio(mp, cc,rt,lt);
7751 mp->vv[0]=-mp_take_fraction(mp, mp->psi[1],mp->uu[0]); mp->ww[0]=0;
7754 @ @<Set up equation for a curl at $\theta_n$...@>=
7755 { cc=left_curl(s); lt=abs(left_tension(s)); rt=abs(right_tension(r));
7756 if ( (rt==unity)&&(lt==unity) )
7757 ff=mp_make_fraction(mp, cc+cc+unity,cc+two);
7759 ff=mp_curl_ratio(mp, cc,lt,rt);
7760 mp->theta[n]=-mp_make_fraction(mp, mp_take_fraction(mp, mp->vv[n-1],ff),
7761 fraction_one-mp_take_fraction(mp, ff,mp->uu[n-1]));
7765 @ The |curl_ratio| subroutine has three arguments, which our previous notation
7766 encourages us to call $\gamma$, $\alpha^{-1}$, and $\beta^{-1}$. It is
7767 a somewhat tedious program to calculate
7768 $${(3-\alpha)\alpha^2\gamma+\beta^3\over
7769 \alpha^3\gamma+(3-\beta)\beta^2},$$
7770 with the result reduced to 4 if it exceeds 4. (This reduction of curl
7771 is necessary only if the curl and tension are both large.)
7772 The values of $\alpha$ and $\beta$ will be at most~4/3.
7774 @<Declare subroutines needed by |solve_choices|@>=
7775 fraction mp_curl_ratio (MP mp,scaled gamma, scaled a_tension,
7777 fraction alpha,beta,num,denom,ff; /* registers */
7778 alpha=mp_make_fraction(mp, unity,a_tension);
7779 beta=mp_make_fraction(mp, unity,b_tension);
7780 if ( alpha<=beta ) {
7781 ff=mp_make_fraction(mp, alpha,beta); ff=mp_take_fraction(mp, ff,ff);
7782 gamma=mp_take_fraction(mp, gamma,ff);
7783 beta=beta / 010000; /* convert |fraction| to |scaled| */
7784 denom=mp_take_fraction(mp, gamma,alpha)+three-beta;
7785 num=mp_take_fraction(mp, gamma,fraction_three-alpha)+beta;
7787 ff=mp_make_fraction(mp, beta,alpha); ff=mp_take_fraction(mp, ff,ff);
7788 beta=mp_take_fraction(mp, beta,ff) / 010000; /* convert |fraction| to |scaled| */
7789 denom=mp_take_fraction(mp, gamma,alpha)+(ff / 1365)-beta;
7790 /* $1365\approx 2^{12}/3$ */
7791 num=mp_take_fraction(mp, gamma,fraction_three-alpha)+beta;
7793 if ( num>=denom+denom+denom+denom ) return fraction_four;
7794 else return mp_make_fraction(mp, num,denom);
7797 @ We're in the home stretch now.
7799 @<Finish choosing angles and assigning control points@>=
7800 for (k=n-1;k>=0;k--) {
7801 mp->theta[k]=mp->vv[k]-mp_take_fraction(mp,mp->theta[k+1],mp->uu[k]);
7806 mp_n_sin_cos(mp, mp->theta[k]); mp->st=mp->n_sin; mp->ct=mp->n_cos;
7807 mp_n_sin_cos(mp, -mp->psi[k+1]-mp->theta[k+1]); mp->sf=mp->n_sin; mp->cf=mp->n_cos;
7808 mp_set_controls(mp, s,t,k);
7812 @ The |set_controls| routine actually puts the control points into
7813 a pair of consecutive nodes |p| and~|q|. Global variables are used to
7814 record the values of $\sin\theta$, $\cos\theta$, $\sin\phi$, and
7815 $\cos\phi$ needed in this calculation.
7821 fraction cf; /* sines and cosines */
7823 @ @<Declare subroutines needed by |solve_choices|@>=
7824 void mp_set_controls (MP mp,pointer p, pointer q, integer k) {
7825 fraction rr,ss; /* velocities, divided by thrice the tension */
7826 scaled lt,rt; /* tensions */
7827 fraction sine; /* $\sin(\theta+\phi)$ */
7828 lt=abs(left_tension(q)); rt=abs(right_tension(p));
7829 rr=mp_velocity(mp, mp->st,mp->ct,mp->sf,mp->cf,rt);
7830 ss=mp_velocity(mp, mp->sf,mp->cf,mp->st,mp->ct,lt);
7831 if ( (right_tension(p)<0)||(left_tension(q)<0) ) {
7832 @<Decrease the velocities,
7833 if necessary, to stay inside the bounding triangle@>;
7835 right_x(p)=x_coord(p)+mp_take_fraction(mp,
7836 mp_take_fraction(mp, mp->delta_x[k],mp->ct)-
7837 mp_take_fraction(mp, mp->delta_y[k],mp->st),rr);
7838 right_y(p)=y_coord(p)+mp_take_fraction(mp,
7839 mp_take_fraction(mp, mp->delta_y[k],mp->ct)+
7840 mp_take_fraction(mp, mp->delta_x[k],mp->st),rr);
7841 left_x(q)=x_coord(q)-mp_take_fraction(mp,
7842 mp_take_fraction(mp, mp->delta_x[k],mp->cf)+
7843 mp_take_fraction(mp, mp->delta_y[k],mp->sf),ss);
7844 left_y(q)=y_coord(q)-mp_take_fraction(mp,
7845 mp_take_fraction(mp, mp->delta_y[k],mp->cf)-
7846 mp_take_fraction(mp, mp->delta_x[k],mp->sf),ss);
7847 right_type(p)=mp_explicit; left_type(q)=mp_explicit;
7850 @ The boundedness conditions $\\{rr}\L\sin\phi\,/\sin(\theta+\phi)$ and
7851 $\\{ss}\L\sin\theta\,/\sin(\theta+\phi)$ are to be enforced if $\sin\theta$,
7852 $\sin\phi$, and $\sin(\theta+\phi)$ all have the same sign. Otherwise
7853 there is no ``bounding triangle.''
7855 @<Decrease the velocities, if necessary...@>=
7856 if (((mp->st>=0)&&(mp->sf>=0))||((mp->st<=0)&&(mp->sf<=0)) ) {
7857 sine=mp_take_fraction(mp, abs(mp->st),mp->cf)+
7858 mp_take_fraction(mp, abs(mp->sf),mp->ct);
7860 sine=mp_take_fraction(mp, sine,fraction_one+unity); /* safety factor */
7861 if ( right_tension(p)<0 )
7862 if ( mp_ab_vs_cd(mp, abs(mp->sf),fraction_one,rr,sine)<0 )
7863 rr=mp_make_fraction(mp, abs(mp->sf),sine);
7864 if ( left_tension(q)<0 )
7865 if ( mp_ab_vs_cd(mp, abs(mp->st),fraction_one,ss,sine)<0 )
7866 ss=mp_make_fraction(mp, abs(mp->st),sine);
7870 @ Only the simple cases remain to be handled.
7872 @<Reduce to simple case of two givens and |return|@>=
7874 aa=mp_n_arg(mp, mp->delta_x[0],mp->delta_y[0]);
7875 mp_n_sin_cos(mp, right_given(p)-aa); mp->ct=mp->n_cos; mp->st=mp->n_sin;
7876 mp_n_sin_cos(mp, left_given(q)-aa); mp->cf=mp->n_cos; mp->sf=-mp->n_sin;
7877 mp_set_controls(mp, p,q,0); return;
7880 @ @<Reduce to simple case of straight line and |return|@>=
7882 right_type(p)=mp_explicit; left_type(q)=mp_explicit;
7883 lt=abs(left_tension(q)); rt=abs(right_tension(p));
7885 if ( mp->delta_x[0]>=0 ) right_x(p)=x_coord(p)+((mp->delta_x[0]+1) / 3);
7886 else right_x(p)=x_coord(p)+((mp->delta_x[0]-1) / 3);
7887 if ( mp->delta_y[0]>=0 ) right_y(p)=y_coord(p)+((mp->delta_y[0]+1) / 3);
7888 else right_y(p)=y_coord(p)+((mp->delta_y[0]-1) / 3);
7890 ff=mp_make_fraction(mp, unity,3*rt); /* $\alpha/3$ */
7891 right_x(p)=x_coord(p)+mp_take_fraction(mp, mp->delta_x[0],ff);
7892 right_y(p)=y_coord(p)+mp_take_fraction(mp, mp->delta_y[0],ff);
7895 if ( mp->delta_x[0]>=0 ) left_x(q)=x_coord(q)-((mp->delta_x[0]+1) / 3);
7896 else left_x(q)=x_coord(q)-((mp->delta_x[0]-1) / 3);
7897 if ( mp->delta_y[0]>=0 ) left_y(q)=y_coord(q)-((mp->delta_y[0]+1) / 3);
7898 else left_y(q)=y_coord(q)-((mp->delta_y[0]-1) / 3);
7900 ff=mp_make_fraction(mp, unity,3*lt); /* $\beta/3$ */
7901 left_x(q)=x_coord(q)-mp_take_fraction(mp, mp->delta_x[0],ff);
7902 left_y(q)=y_coord(q)-mp_take_fraction(mp, mp->delta_y[0],ff);
7907 @* \[19] Measuring paths.
7908 \MP's \&{llcorner}, \&{lrcorner}, \&{ulcorner}, and \&{urcorner} operators
7909 allow the user to measure the bounding box of anything that can go into a
7910 picture. It's easy to get rough bounds on the $x$ and $y$ extent of a path
7911 by just finding the bounding box of the knots and the control points. We
7912 need a more accurate version of the bounding box, but we can still use the
7913 easy estimate to save time by focusing on the interesting parts of the path.
7915 @ Computing an accurate bounding box involves a theme that will come up again
7916 and again. Given a Bernshte{\u\i}n polynomial
7917 @^Bernshte{\u\i}n, Serge{\u\i} Natanovich@>
7918 $$B(z_0,z_1,\ldots,z_n;t)=\sum_k{n\choose k}t^k(1-t)^{n-k}z_k,$$
7919 we can conveniently bisect its range as follows:
7922 \textindent{1)} Let $z_k^{(0)}=z_k$, for |0<=k<=n|.
7925 \textindent{2)} Let $z_k^{(j+1)}={1\over2}(z_k^{(j)}+z\k^{(j)})$, for
7926 |0<=k<n-j|, for |0<=j<n|.
7930 $$B(z_0,z_1,\ldots,z_n;t)=B(z_0^{(0)},z_0^{(1)},\ldots,z_0^{(n)};2t)
7931 =B(z_0^{(n)},z_1^{(n-1)},\ldots,z_n^{(0)};2t-1).$$
7932 This formula gives us the coefficients of polynomials to use over the ranges
7933 $0\L t\L{1\over2}$ and ${1\over2}\L t\L1$.
7935 @ Now here's a subroutine that's handy for all sorts of path computations:
7936 Given a quadratic polynomial $B(a,b,c;t)$, the |crossing_point| function
7937 returns the unique |fraction| value |t| between 0 and~1 at which
7938 $B(a,b,c;t)$ changes from positive to negative, or returns
7939 |t=fraction_one+1| if no such value exists. If |a<0| (so that $B(a,b,c;t)$
7940 is already negative at |t=0|), |crossing_point| returns the value zero.
7942 @d no_crossing { return (fraction_one+1); }
7943 @d one_crossing { return fraction_one; }
7944 @d zero_crossing { return 0; }
7945 @d mp_crossing_point(M,A,B,C) mp_do_crossing_point(A,B,C)
7947 @c fraction mp_do_crossing_point (integer a, integer b, integer c) {
7948 integer d; /* recursive counter */
7949 integer x,xx,x0,x1,x2; /* temporary registers for bisection */
7950 if ( a<0 ) zero_crossing;
7953 if ( c>0 ) { no_crossing; }
7954 else if ( (a==0)&&(b==0) ) { no_crossing;}
7955 else { one_crossing; }
7957 if ( a==0 ) zero_crossing;
7958 } else if ( a==0 ) {
7959 if ( b<=0 ) zero_crossing;
7961 @<Use bisection to find the crossing point, if one exists@>;
7964 @ The general bisection method is quite simple when $n=2$, hence
7965 |crossing_point| does not take much time. At each stage in the
7966 recursion we have a subinterval defined by |l| and~|j| such that
7967 $B(a,b,c;2^{-l}(j+t))=B(x_0,x_1,x_2;t)$, and we want to ``zero in'' on
7968 the subinterval where $x_0\G0$ and $\min(x_1,x_2)<0$.
7970 It is convenient for purposes of calculation to combine the values
7971 of |l| and~|j| in a single variable $d=2^l+j$, because the operation
7972 of bisection then corresponds simply to doubling $d$ and possibly
7973 adding~1. Furthermore it proves to be convenient to modify
7974 our previous conventions for bisection slightly, maintaining the
7975 variables $X_0=2^lx_0$, $X_1=2^l(x_0-x_1)$, and $X_2=2^l(x_1-x_2)$.
7976 With these variables the conditions $x_0\ge0$ and $\min(x_1,x_2)<0$ are
7977 equivalent to $\max(X_1,X_1+X_2)>X_0\ge0$.
7979 The following code maintains the invariant relations
7980 $0\L|x0|<\max(|x1|,|x1|+|x2|)$,
7981 $\vert|x1|\vert<2^{30}$, $\vert|x2|\vert<2^{30}$;
7982 it has been constructed in such a way that no arithmetic overflow
7983 will occur if the inputs satisfy
7984 $a<2^{30}$, $\vert a-b\vert<2^{30}$, and $\vert b-c\vert<2^{30}$.
7986 @<Use bisection to find the crossing point...@>=
7987 d=1; x0=a; x1=a-b; x2=b-c;
7998 if ( x<=x0 ) { if ( x+x2<=x0 ) no_crossing; }
8002 } while (d<fraction_one);
8003 return (d-fraction_one)
8005 @ Here is a routine that computes the $x$ or $y$ coordinate of the point on
8006 a cubic corresponding to the |fraction| value~|t|.
8008 It is convenient to define a \.{WEB} macro |t_of_the_way| such that
8009 |t_of_the_way(a,b)| expands to |a-(a-b)*t|, i.e., to |t[a,b]|.
8011 @d t_of_the_way(A,B) ((A)-mp_take_fraction(mp,((A)-(B)),t))
8013 @c scaled mp_eval_cubic (MP mp,pointer p, pointer q, fraction t) {
8014 scaled x1,x2,x3; /* intermediate values */
8015 x1=t_of_the_way(knot_coord(p),right_coord(p));
8016 x2=t_of_the_way(right_coord(p),left_coord(q));
8017 x3=t_of_the_way(left_coord(q),knot_coord(q));
8018 x1=t_of_the_way(x1,x2);
8019 x2=t_of_the_way(x2,x3);
8020 return t_of_the_way(x1,x2);
8023 @ The actual bounding box information is stored in global variables.
8024 Since it is convenient to address the $x$ and $y$ information
8025 separately, we define arrays indexed by |x_code..y_code| and use
8026 macros to give them more convenient names.
8030 mp_x_code=0, /* index for |minx| and |maxx| */
8031 mp_y_code /* index for |miny| and |maxy| */
8035 @d minx mp->bbmin[mp_x_code]
8036 @d maxx mp->bbmax[mp_x_code]
8037 @d miny mp->bbmin[mp_y_code]
8038 @d maxy mp->bbmax[mp_y_code]
8041 scaled bbmin[mp_y_code+1];
8042 scaled bbmax[mp_y_code+1];
8043 /* the result of procedures that compute bounding box information */
8045 @ Now we're ready for the key part of the bounding box computation.
8046 The |bound_cubic| procedure updates |bbmin[c]| and |bbmax[c]| based on
8047 $$B(\hbox{|knot_coord(p)|}, \hbox{|right_coord(p)|},
8048 \hbox{|left_coord(q)|}, \hbox{|knot_coord(q)|};t)
8050 for $0<t\le1$. In other words, the procedure adjusts the bounds to
8051 accommodate |knot_coord(q)| and any extremes over the range $0<t<1$.
8052 The |c| parameter is |x_code| or |y_code|.
8054 @c void mp_bound_cubic (MP mp,pointer p, pointer q, small_number c) {
8055 boolean wavy; /* whether we need to look for extremes */
8056 scaled del1,del2,del3,del,dmax; /* proportional to the control
8057 points of a quadratic derived from a cubic */
8058 fraction t,tt; /* where a quadratic crosses zero */
8059 scaled x; /* a value that |bbmin[c]| and |bbmax[c]| must accommodate */
8061 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8062 @<Check the control points against the bounding box and set |wavy:=true|
8063 if any of them lie outside@>;
8065 del1=right_coord(p)-knot_coord(p);
8066 del2=left_coord(q)-right_coord(p);
8067 del3=knot_coord(q)-left_coord(q);
8068 @<Scale up |del1|, |del2|, and |del3| for greater accuracy;
8069 also set |del| to the first nonzero element of |(del1,del2,del3)|@>;
8071 negate(del1); negate(del2); negate(del3);
8073 t=mp_crossing_point(mp, del1,del2,del3);
8074 if ( t<fraction_one ) {
8075 @<Test the extremes of the cubic against the bounding box@>;
8080 @ @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>=
8081 if ( x<mp->bbmin[c] ) mp->bbmin[c]=x;
8082 if ( x>mp->bbmax[c] ) mp->bbmax[c]=x
8084 @ @<Check the control points against the bounding box and set...@>=
8086 if ( mp->bbmin[c]<=right_coord(p) )
8087 if ( right_coord(p)<=mp->bbmax[c] )
8088 if ( mp->bbmin[c]<=left_coord(q) )
8089 if ( left_coord(q)<=mp->bbmax[c] )
8092 @ If |del1=del2=del3=0|, it's impossible to obey the title of this
8093 section. We just set |del=0| in that case.
8095 @<Scale up |del1|, |del2|, and |del3| for greater accuracy...@>=
8096 if ( del1!=0 ) del=del1;
8097 else if ( del2!=0 ) del=del2;
8101 if ( abs(del2)>dmax ) dmax=abs(del2);
8102 if ( abs(del3)>dmax ) dmax=abs(del3);
8103 while ( dmax<fraction_half ) {
8104 dmax+=dmax; del1+=del1; del2+=del2; del3+=del3;
8108 @ Since |crossing_point| has tried to choose |t| so that
8109 $B(|del1|,|del2|,|del3|;\tau)$ crosses zero at $\tau=|t|$ with negative
8110 slope, the value of |del2| computed below should not be positive.
8111 But rounding error could make it slightly positive in which case we
8112 must cut it to zero to avoid confusion.
8114 @<Test the extremes of the cubic against the bounding box@>=
8116 x=mp_eval_cubic(mp, p,q,t);
8117 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8118 del2=t_of_the_way(del2,del3);
8119 /* now |0,del2,del3| represent the derivative on the remaining interval */
8120 if ( del2>0 ) del2=0;
8121 tt=mp_crossing_point(mp, 0,-del2,-del3);
8122 if ( tt<fraction_one ) {
8123 @<Test the second extreme against the bounding box@>;
8127 @ @<Test the second extreme against the bounding box@>=
8129 x=mp_eval_cubic(mp, p,q,t_of_the_way(tt,fraction_one));
8130 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8133 @ Finding the bounding box of a path is basically a matter of applying
8134 |bound_cubic| twice for each pair of adjacent knots.
8136 @c void mp_path_bbox (MP mp,pointer h) {
8137 pointer p,q; /* a pair of adjacent knots */
8138 minx=x_coord(h); miny=y_coord(h);
8139 maxx=minx; maxy=miny;
8142 if ( right_type(p)==mp_endpoint ) return;
8144 mp_bound_cubic(mp, x_loc(p),x_loc(q),mp_x_code);
8145 mp_bound_cubic(mp, y_loc(p),y_loc(q),mp_y_code);
8150 @ Another important way to measure a path is to find its arc length. This
8151 is best done by using the general bisection algorithm to subdivide the path
8152 until obtaining ``well behaved'' subpaths whose arc lengths can be approximated
8155 Since the arc length is the integral with respect to time of the magnitude of
8156 the velocity, it is natural to use Simpson's rule for the approximation.
8158 If $\dot B(t)$ is the spline velocity, Simpson's rule gives
8159 $$ \vb\dot B(0)\vb + 4\vb\dot B({1\over2})\vb + \vb\dot B(1)\vb \over 6 $$
8160 for the arc length of a path of length~1. For a cubic spline
8161 $B(z_0,z_1,z_2,z_3;t)$, the time derivative $\dot B(t)$ is
8162 $3B(dz_0,dz_1,dz_2;t)$, where $dz_i=z_{i+1}-z_i$. Hence the arc length
8164 $$ {\vb dz_0\vb \over 2} + 2\vb dz_{02}\vb + {\vb dz_2\vb \over 2}, $$
8166 $$ dz_{02}={1\over2}\left({dz_0+dz_1\over 2}+{dz_1+dz_2\over 2}\right)$$
8167 is the result of the bisection algorithm.
8169 @ The remaining problem is how to decide when a subpath is ``well behaved.''
8170 This could be done via the theoretical error bound for Simpson's rule,
8172 but this is impractical because it requires an estimate of the fourth
8173 derivative of the quantity being integrated. It is much easier to just perform
8174 a bisection step and see how much the arc length estimate changes. Since the
8175 error for Simpson's rule is proportional to the fourth power of the sample
8176 spacing, the remaining error is typically about $1\over16$ of the amount of
8177 the change. We say ``typically'' because the error has a pseudo-random behavior
8178 that could cause the two estimates to agree when each contain large errors.
8180 To protect against disasters such as undetected cusps, the bisection process
8181 should always continue until all the $dz_i$ vectors belong to a single
8182 $90^\circ$ sector. This ensures that no point on the spline can have velocity
8183 less than 70\% of the minimum of $\vb dz_0\vb$, $\vb dz_1\vb$ and $\vb dz_2\vb$.
8184 If such a spline happens to produce an erroneous arc length estimate that
8185 is little changed by bisection, the amount of the error is likely to be fairly
8186 small. We will try to arrange things so that freak accidents of this type do
8187 not destroy the inverse relationship between the \&{arclength} and
8188 \&{arctime} operations.
8189 @:arclength_}{\&{arclength} primitive@>
8190 @:arctime_}{\&{arctime} primitive@>
8192 @ The \&{arclength} and \&{arctime} operations are both based on a recursive
8194 function that finds the arc length of a cubic spline given $dz_0$, $dz_1$,
8195 $dz_2$. This |arc_test| routine also takes an arc length goal |a_goal| and
8196 returns the time when the arc length reaches |a_goal| if there is such a time.
8197 Thus the return value is either an arc length less than |a_goal| or, if the
8198 arc length would be at least |a_goal|, it returns a time value decreased by
8199 |two|. This allows the caller to use the sign of the result to distinguish
8200 between arc lengths and time values. On certain types of overflow, it is
8201 possible for |a_goal| and the result of |arc_test| both to be |el_gordo|.
8202 Otherwise, the result is always less than |a_goal|.
8204 Rather than halving the control point coordinates on each recursive call to
8205 |arc_test|, it is better to keep them proportional to velocity on the original
8206 curve and halve the results instead. This means that recursive calls can
8207 potentially use larger error tolerances in their arc length estimates. How
8208 much larger depends on to what extent the errors behave as though they are
8209 independent of each other. To save computing time, we use optimistic assumptions
8210 and increase the tolerance by a factor of about $\sqrt2$ for each recursive
8213 In addition to the tolerance parameter, |arc_test| should also have parameters
8214 for ${1\over3}\vb\dot B(0)\vb$, ${2\over3}\vb\dot B({1\over2})\vb$, and
8215 ${1\over3}\vb\dot B(1)\vb$. These quantities are relatively expensive to compute
8216 and they are needed in different instances of |arc_test|.
8218 @c @<Declare subroutines needed by |arc_test|@>
8219 scaled mp_arc_test (MP mp, scaled dx0, scaled dy0, scaled dx1, scaled dy1,
8220 scaled dx2, scaled dy2, scaled v0, scaled v02,
8221 scaled v2, scaled a_goal, scaled tol) {
8222 boolean simple; /* are the control points confined to a $90^\circ$ sector? */
8223 scaled dx01, dy01, dx12, dy12, dx02, dy02; /* bisection results */
8225 /* twice the velocity magnitudes at $t={1\over4}$ and $t={3\over4}$ */
8226 scaled arc; /* best arc length estimate before recursion */
8227 @<Other local variables in |arc_test|@>;
8228 @<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,
8230 @<Initialize |v002|, |v022|, and the arc length estimate |arc|; if it overflows
8231 set |arc_test| and |return|@>;
8232 @<Test if the control points are confined to one quadrant or rotating them
8233 $45^\circ$ would put them in one quadrant. Then set |simple| appropriately@>;
8234 if ( simple && (abs(arc-v02-halfp(v0+v2)) <= tol) ) {
8235 if ( arc < a_goal ) {
8238 @<Estimate when the arc length reaches |a_goal| and set |arc_test| to
8239 that time minus |two|@>;
8242 @<Use one or two recursive calls to compute the |arc_test| function@>;
8246 @ The |tol| value should by multiplied by $\sqrt 2$ before making recursive
8247 calls, but $1.5$ is an adequate approximation. It is best to avoid using
8248 |make_fraction| in this inner loop.
8251 @<Use one or two recursive calls to compute the |arc_test| function@>=
8253 @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is as
8254 large as possible@>;
8255 tol = tol + halfp(tol);
8256 a = mp_arc_test(mp, dx0,dy0, dx01,dy01, dx02,dy02, v0, v002,
8257 halfp(v02), a_new, tol);
8259 return (-halfp(two-a));
8261 @<Update |a_new| to reduce |a_new+a_aux| by |a|@>;
8262 b = mp_arc_test(mp, dx02,dy02, dx12,dy12, dx2,dy2,
8263 halfp(v02), v022, v2, a_new, tol);
8265 return (-halfp(-b) - half_unit);
8267 return (a + half(b-a));
8271 @ @<Other local variables in |arc_test|@>=
8272 scaled a,b; /* results of recursive calls */
8273 scaled a_new,a_aux; /* the sum of these gives the |a_goal| */
8275 @ @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is...@>=
8276 a_aux = el_gordo - a_goal;
8277 if ( a_goal > a_aux ) {
8278 a_aux = a_goal - a_aux;
8281 a_new = a_goal + a_goal;
8285 @ There is no need to maintain |a_aux| at this point so we use it as a temporary
8286 to force the additions and subtractions to be done in an order that avoids
8289 @<Update |a_new| to reduce |a_new+a_aux| by |a|@>=
8292 a_new = a_new + a_aux;
8295 @ This code assumes all {\it dx} and {\it dy} variables have magnitude less than
8296 |fraction_four|. To simplify the rest of the |arc_test| routine, we strengthen
8297 this assumption by requiring the norm of each $({\it dx},{\it dy})$ pair to obey
8298 this bound. Note that recursive calls will maintain this invariant.
8300 @<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,...@>=
8301 dx01 = half(dx0 + dx1);
8302 dx12 = half(dx1 + dx2);
8303 dx02 = half(dx01 + dx12);
8304 dy01 = half(dy0 + dy1);
8305 dy12 = half(dy1 + dy2);
8306 dy02 = half(dy01 + dy12)
8308 @ We should be careful to keep |arc<el_gordo| so that calling |arc_test| with
8309 |a_goal=el_gordo| is guaranteed to yield the arc length.
8311 @<Initialize |v002|, |v022|, and the arc length estimate |arc|;...@>=
8312 v002 = mp_pyth_add(mp, dx01+half(dx0+dx02), dy01+half(dy0+dy02));
8313 v022 = mp_pyth_add(mp, dx12+half(dx02+dx2), dy12+half(dy02+dy2));
8315 arc1 = v002 + half(halfp(v0+tmp) - v002);
8316 arc = v022 + half(halfp(v2+tmp) - v022);
8317 if ( (arc < el_gordo-arc1) ) {
8320 mp->arith_error = true;
8321 if ( a_goal==el_gordo ) return (el_gordo);
8325 @ @<Other local variables in |arc_test|@>=
8326 scaled tmp, tmp2; /* all purpose temporary registers */
8327 scaled arc1; /* arc length estimate for the first half */
8329 @ @<Test if the control points are confined to one quadrant or rotating...@>=
8330 simple = ((dx0>=0) && (dx1>=0) && (dx2>=0)) ||
8331 ((dx0<=0) && (dx1<=0) && (dx2<=0));
8333 simple = ((dy0>=0) && (dy1>=0) && (dy2>=0)) ||
8334 ((dy0<=0) && (dy1<=0) && (dy2<=0));
8336 simple = ((dx0>=dy0) && (dx1>=dy1) && (dx2>=dy2)) ||
8337 ((dx0<=dy0) && (dx1<=dy1) && (dx2<=dy2));
8339 simple = ((-dx0>=dy0) && (-dx1>=dy1) && (-dx2>=dy2)) ||
8340 ((-dx0<=dy0) && (-dx1<=dy1) && (-dx2<=dy2));
8343 @ Since Simpson's rule is based on approximating the integrand by a parabola,
8345 it is appropriate to use the same approximation to decide when the integral
8346 reaches the intermediate value |a_goal|. At this point
8348 {\vb\dot B(0)\vb\over 3} &= \hbox{|v0|}, \qquad
8349 {\vb\dot B({1\over4})\vb\over 3} = {\hbox{|v002|}\over 2}, \qquad
8350 {\vb\dot B({1\over2})\vb\over 3} = {\hbox{|v02|}\over 2}, \cr
8351 {\vb\dot B({3\over4})\vb\over 3} &= {\hbox{|v022|}\over 2}, \qquad
8352 {\vb\dot B(1)\vb\over 3} = \hbox{|v2|} \cr
8356 $$ {\vb\dot B(t)\vb\over 3} \approx
8357 \cases{B\left(\hbox{|v0|},
8358 \hbox{|v002|}-{1\over 2}\hbox{|v0|}-{1\over 4}\hbox{|v02|},
8359 {1\over 2}\hbox{|v02|}; 2t \right)&
8360 if $t\le{1\over 2}$\cr
8361 B\left({1\over 2}\hbox{|v02|},
8362 \hbox{|v022|}-{1\over 4}\hbox{|v02|}-{1\over 2}\hbox{|v2|},
8363 \hbox{|v2|}; 2t-1 \right)&
8364 if $t\ge{1\over 2}$.\cr}
8367 We can integrate $\vb\dot B(t)\vb$ by using
8368 $$\int 3B(a,b,c;\tau)\,dt =
8369 {B(0,a,a+b,a+b+c;\tau) + {\rm constant} \over {d\tau\over dt}}.
8372 This construction allows us to find the time when the arc length reaches
8373 |a_goal| by solving a cubic equation of the form
8374 $$ B(0,a,a+b,a+b+c;\tau) = x, $$
8375 where $\tau$ is $2t$ or $2t+1$, $x$ is |a_goal| or |a_goal-arc1|, and $a$, $b$,
8376 and $c$ are the Bernshte{\u\i}n coefficients from $(*)$ divided by
8377 @^Bernshte{\u\i}n, Serge{\u\i} Natanovich@>
8378 $d\tau\over dt$. We shall define a function |solve_rising_cubic| that finds
8379 $\tau$ given $a$, $b$, $c$, and $x$.
8381 @<Estimate when the arc length reaches |a_goal| and set |arc_test| to...@>=
8383 tmp = (v02 + 2) / 4;
8384 if ( a_goal<=arc1 ) {
8387 (halfp(mp_solve_rising_cubic(mp, tmp2, arc1-tmp2-tmp, tmp, a_goal))- two);
8390 return ((half_unit - two) +
8391 halfp(mp_solve_rising_cubic(mp, tmp, arc-arc1-tmp-tmp2, tmp2, a_goal-arc1)));
8395 @ Here is the |solve_rising_cubic| routine that finds the time~$t$ when
8396 $$ B(0, a, a+b, a+b+c; t) = x. $$
8397 This routine is based on |crossing_point| but is simplified by the
8398 assumptions that $B(a,b,c;t)\ge0$ for $0\le t\le1$ and that |0<=x<=a+b+c|.
8399 If rounding error causes this condition to be violated slightly, we just ignore
8400 it and proceed with binary search. This finds a time when the function value
8401 reaches |x| and the slope is positive.
8403 @<Declare subroutines needed by |arc_test|@>=
8404 scaled mp_solve_rising_cubic (MP mp,scaled a, scaled b, scaled c, scaled x) {
8405 scaled ab, bc, ac; /* bisection results */
8406 integer t; /* $2^k+q$ where unscaled answer is in $[q2^{-k},(q+1)2^{-k})$ */
8407 integer xx; /* temporary for updating |x| */
8408 if ( (a<0) || (c<0) ) mp_confusion(mp, "rising?");
8409 @:this can't happen rising?}{\quad rising?@>
8412 } else if ( x >= a+b+c ) {
8416 @<Rescale if necessary to make sure |a|, |b|, and |c| are all less than
8420 @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>;
8421 xx = x - a - ab - ac;
8422 if ( xx < -x ) { x+=x; b=ab; c=ac; }
8423 else { x = x + xx; a=ac; b=bc; t = t+1; };
8424 } while (t < unity);
8429 @ @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>=
8434 @ @d one_third_el_gordo 05252525252 /* upper bound on |a|, |b|, and |c| */
8436 @<Rescale if necessary to make sure |a|, |b|, and |c| are all less than...@>=
8437 while ((a>one_third_el_gordo)||(b>one_third_el_gordo)||(c>one_third_el_gordo)) {
8444 @ It is convenient to have a simpler interface to |arc_test| that requires no
8445 unnecessary arguments and ensures that each $({\it dx},{\it dy})$ pair has
8446 length less than |fraction_four|.
8448 @d arc_tol 16 /* quit when change in arc length estimate reaches this */
8450 @c scaled mp_do_arc_test (MP mp,scaled dx0, scaled dy0, scaled dx1,
8451 scaled dy1, scaled dx2, scaled dy2, scaled a_goal) {
8452 scaled v0,v1,v2; /* length of each $({\it dx},{\it dy})$ pair */
8453 scaled v02; /* twice the norm of the quadratic at $t={1\over2}$ */
8454 v0 = mp_pyth_add(mp, dx0,dy0);
8455 v1 = mp_pyth_add(mp, dx1,dy1);
8456 v2 = mp_pyth_add(mp, dx2,dy2);
8457 if ( (v0>=fraction_four) || (v1>=fraction_four) || (v2>=fraction_four) ) {
8458 mp->arith_error = true;
8459 if ( a_goal==el_gordo ) return el_gordo;
8462 v02 = mp_pyth_add(mp, dx1+half(dx0+dx2), dy1+half(dy0+dy2));
8463 return (mp_arc_test(mp, dx0,dy0, dx1,dy1, dx2,dy2,
8464 v0, v02, v2, a_goal, arc_tol));
8468 @ Now it is easy to find the arc length of an entire path.
8470 @c scaled mp_get_arc_length (MP mp,pointer h) {
8471 pointer p,q; /* for traversing the path */
8472 scaled a,a_tot; /* current and total arc lengths */
8475 while ( right_type(p)!=mp_endpoint ){
8477 a = mp_do_arc_test(mp, right_x(p)-x_coord(p), right_y(p)-y_coord(p),
8478 left_x(q)-right_x(p), left_y(q)-right_y(p),
8479 x_coord(q)-left_x(q), y_coord(q)-left_y(q), el_gordo);
8480 a_tot = mp_slow_add(mp, a, a_tot);
8481 if ( q==h ) break; else p=q;
8487 @ The inverse operation of finding the time on a path~|h| when the arc length
8488 reaches some value |arc0| can also be accomplished via |do_arc_test|. Some care
8489 is required to handle very large times or negative times on cyclic paths. For
8490 non-cyclic paths, |arc0| values that are negative or too large cause
8491 |get_arc_time| to return 0 or the length of path~|h|.
8493 If |arc0| is greater than the arc length of a cyclic path~|h|, the result is a
8494 time value greater than the length of the path. Since it could be much greater,
8495 we must be prepared to compute the arc length of path~|h| and divide this into
8496 |arc0| to find how many multiples of the length of path~|h| to add.
8498 @c scaled mp_get_arc_time (MP mp,pointer h, scaled arc0) {
8499 pointer p,q; /* for traversing the path */
8500 scaled t_tot; /* accumulator for the result */
8501 scaled t; /* the result of |do_arc_test| */
8502 scaled arc; /* portion of |arc0| not used up so far */
8503 integer n; /* number of extra times to go around the cycle */
8505 @<Deal with a negative |arc0| value and |return|@>;
8507 if ( arc0==el_gordo ) decr(arc0);
8511 while ( (right_type(p)!=mp_endpoint) && (arc>0) ) {
8513 t = mp_do_arc_test(mp, right_x(p)-x_coord(p), right_y(p)-y_coord(p),
8514 left_x(q)-right_x(p), left_y(q)-right_y(p),
8515 x_coord(q)-left_x(q), y_coord(q)-left_y(q), arc);
8516 @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>;
8518 @<Update |t_tot| and |arc| to avoid going around the cyclic
8519 path too many times but set |arith_error:=true| and |goto done| on
8528 @ @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>=
8529 if ( t<0 ) { t_tot = t_tot + t + two; arc = 0; }
8530 else { t_tot = t_tot + unity; arc = arc - t; }
8532 @ @<Deal with a negative |arc0| value and |return|@>=
8534 if ( left_type(h)==mp_endpoint ) {
8537 p = mp_htap_ypoc(mp, h);
8538 t_tot = -mp_get_arc_time(mp, p, -arc0);
8539 mp_toss_knot_list(mp, p);
8545 @ @<Update |t_tot| and |arc| to avoid going around the cyclic...@>=
8547 n = arc / (arc0 - arc);
8548 arc = arc - n*(arc0 - arc);
8549 if ( t_tot > (el_gordo / (n+1)) ) {
8552 t_tot = (n + 1)*t_tot;
8555 @* \[20] Data structures for pens.
8556 A Pen in \MP\ can be either elliptical or polygonal. Elliptical pens result
8557 in \ps\ \&{stroke} commands, while anything drawn with a polygonal pen is
8558 @:stroke}{\&{stroke} command@>
8559 converted into an area fill as described in the next part of this program.
8560 The mathematics behind this process is based on simple aspects of the theory
8561 of tracings developed by Leo Guibas, Lyle Ramshaw, and Jorge Stolfi
8562 [``A kinematic framework for computational geometry,'' Proc.\ IEEE Symp.\
8563 Foundations of Computer Science {\bf 24} (1983), 100--111].
8565 Polygonal pens are created from paths via \MP's \&{makepen} primitive.
8566 @:makepen_}{\&{makepen} primitive@>
8567 This path representation is almost sufficient for our purposes except that
8568 a pen path should always be a convex polygon with the vertices in
8569 counter-clockwise order.
8570 Since we will need to scan pen polygons both forward and backward, a pen
8571 should be represented as a doubly linked ring of knot nodes. There is
8572 room for the extra back pointer because we do not need the
8573 |left_type| or |right_type| fields. In fact, we don't need the |left_x|,
8574 |left_y|, |right_x|, or |right_y| fields either but we leave these alone
8575 so that certain procedures can operate on both pens and paths. In particular,
8576 pens can be copied using |copy_path| and recycled using |toss_knot_list|.
8579 /* this replaces the |left_type| and |right_type| fields in a pen knot */
8581 @ The |make_pen| procedure turns a path into a pen by initializing
8582 the |knil| pointers and making sure the knots form a convex polygon.
8583 Thus each cubic in the given path becomes a straight line and the control
8584 points are ignored. If the path is not cyclic, the ends are connected by a
8587 @d copy_pen(A) mp_make_pen(mp, mp_copy_path(mp, (A)),false)
8589 @c @<Declare a function called |convex_hull|@>
8590 pointer mp_make_pen (MP mp,pointer h, boolean need_hull) {
8591 pointer p,q; /* two consecutive knots */
8598 h=mp_convex_hull(mp, h);
8599 @<Make sure |h| isn't confused with an elliptical pen@>;
8604 @ The only information required about an elliptical pen is the overall
8605 transformation that has been applied to the original \&{pencircle}.
8606 @:pencircle_}{\&{pencircle} primitive@>
8607 Since it suffices to keep track of how the three points $(0,0)$, $(1,0)$,
8608 and $(0,1)$ are transformed, an elliptical pen can be stored in a single
8609 knot node and transformed as if it were a path.
8611 @d pen_is_elliptical(A) ((A)==link((A)))
8613 @c pointer mp_get_pen_circle (MP mp,scaled diam) {
8614 pointer h; /* the knot node to return */
8615 h=mp_get_node(mp, knot_node_size);
8616 link(h)=h; knil(h)=h;
8617 originator(h)=mp_program_code;
8618 x_coord(h)=0; y_coord(h)=0;
8619 left_x(h)=diam; left_y(h)=0;
8620 right_x(h)=0; right_y(h)=diam;
8624 @ If the polygon being returned by |make_pen| has only one vertex, it will
8625 be interpreted as an elliptical pen. This is no problem since a degenerate
8626 polygon can equally well be thought of as a degenerate ellipse. We need only
8627 initialize the |left_x|, |left_y|, |right_x|, and |right_y| fields.
8629 @<Make sure |h| isn't confused with an elliptical pen@>=
8630 if ( pen_is_elliptical( h) ){
8631 left_x(h)=x_coord(h); left_y(h)=y_coord(h);
8632 right_x(h)=x_coord(h); right_y(h)=y_coord(h);
8635 @ We have to cheat a little here but most operations on pens only use
8636 the first three words in each knot node.
8637 @^data structure assumptions@>
8639 @<Initialize a pen at |test_pen| so that it fits in nine words@>=
8640 x_coord(test_pen)=-half_unit;
8641 y_coord(test_pen)=0;
8642 x_coord(test_pen+3)=half_unit;
8643 y_coord(test_pen+3)=0;
8644 x_coord(test_pen+6)=0;
8645 y_coord(test_pen+6)=unity;
8646 link(test_pen)=test_pen+3;
8647 link(test_pen+3)=test_pen+6;
8648 link(test_pen+6)=test_pen;
8649 knil(test_pen)=test_pen+6;
8650 knil(test_pen+3)=test_pen;
8651 knil(test_pen+6)=test_pen+3
8653 @ Printing a polygonal pen is very much like printing a path
8655 @<Declare subroutines for printing expressions@>=
8656 void mp_pr_pen (MP mp,pointer h) {
8657 pointer p,q; /* for list traversal */
8658 if ( pen_is_elliptical(h) ) {
8659 @<Print the elliptical pen |h|@>;
8663 mp_print_two(mp, x_coord(p),y_coord(p));
8664 mp_print_nl(mp, " .. ");
8665 @<Advance |p| making sure the links are OK and |return| if there is
8668 mp_print(mp, "cycle");
8672 @ @<Advance |p| making sure the links are OK and |return| if there is...@>=
8674 if ( (q==null) || (knil(q)!=p) ) {
8675 mp_print_nl(mp, "???"); return; /* this won't happen */
8680 @ @<Print the elliptical pen |h|@>=
8682 mp_print(mp, "pencircle transformed (");
8683 mp_print_scaled(mp, x_coord(h));
8684 mp_print_char(mp, ',');
8685 mp_print_scaled(mp, y_coord(h));
8686 mp_print_char(mp, ',');
8687 mp_print_scaled(mp, left_x(h)-x_coord(h));
8688 mp_print_char(mp, ',');
8689 mp_print_scaled(mp, right_x(h)-x_coord(h));
8690 mp_print_char(mp, ',');
8691 mp_print_scaled(mp, left_y(h)-y_coord(h));
8692 mp_print_char(mp, ',');
8693 mp_print_scaled(mp, right_y(h)-y_coord(h));
8694 mp_print_char(mp, ')');
8697 @ Here us another version of |pr_pen| that prints the pen as a diagnostic
8700 @<Declare subroutines for printing expressions@>=
8701 void mp_print_pen (MP mp,pointer h, const char *s, boolean nuline) {
8702 mp_print_diagnostic(mp, "Pen",s,nuline); mp_print_ln(mp);
8705 mp_end_diagnostic(mp, true);
8708 @ Making a polygonal pen into a path involves restoring the |left_type| and
8709 |right_type| fields and setting the control points so as to make a polygonal
8713 void mp_make_path (MP mp,pointer h) {
8714 pointer p; /* for traversing the knot list */
8715 small_number k; /* a loop counter */
8716 @<Other local variables in |make_path|@>;
8717 if ( pen_is_elliptical(h) ) {
8718 @<Make the elliptical pen |h| into a path@>;
8722 left_type(p)=mp_explicit;
8723 right_type(p)=mp_explicit;
8724 @<copy the coordinates of knot |p| into its control points@>;
8730 @ @<copy the coordinates of knot |p| into its control points@>=
8731 left_x(p)=x_coord(p);
8732 left_y(p)=y_coord(p);
8733 right_x(p)=x_coord(p);
8734 right_y(p)=y_coord(p)
8736 @ We need an eight knot path to get a good approximation to an ellipse.
8738 @<Make the elliptical pen |h| into a path@>=
8740 @<Extract the transformation parameters from the elliptical pen~|h|@>;
8742 for (k=0;k<=7;k++ ) {
8743 @<Initialize |p| as the |k|th knot of a circle of unit diameter,
8744 transforming it appropriately@>;
8745 if ( k==7 ) link(p)=h; else link(p)=mp_get_node(mp, knot_node_size);
8750 @ @<Extract the transformation parameters from the elliptical pen~|h|@>=
8751 center_x=x_coord(h);
8752 center_y=y_coord(h);
8753 width_x=left_x(h)-center_x;
8754 width_y=left_y(h)-center_y;
8755 height_x=right_x(h)-center_x;
8756 height_y=right_y(h)-center_y
8758 @ @<Other local variables in |make_path|@>=
8759 scaled center_x,center_y; /* translation parameters for an elliptical pen */
8760 scaled width_x,width_y; /* the effect of a unit change in $x$ */
8761 scaled height_x,height_y; /* the effect of a unit change in $y$ */
8762 scaled dx,dy; /* the vector from knot |p| to its right control point */
8764 /* |k| advanced $270^\circ$ around the ring (cf. $\sin\theta=\cos(\theta+270)$) */
8766 @ The only tricky thing here are the tables |half_cos| and |d_cos| used to
8767 find the point $k/8$ of the way around the circle and the direction vector
8770 @<Initialize |p| as the |k|th knot of a circle of unit diameter,...@>=
8772 x_coord(p)=center_x+mp_take_fraction(mp, mp->half_cos[k],width_x)
8773 +mp_take_fraction(mp, mp->half_cos[kk],height_x);
8774 y_coord(p)=center_y+mp_take_fraction(mp, mp->half_cos[k],width_y)
8775 +mp_take_fraction(mp, mp->half_cos[kk],height_y);
8776 dx=-mp_take_fraction(mp, mp->d_cos[kk],width_x)
8777 +mp_take_fraction(mp, mp->d_cos[k],height_x);
8778 dy=-mp_take_fraction(mp, mp->d_cos[kk],width_y)
8779 +mp_take_fraction(mp, mp->d_cos[k],height_y);
8780 right_x(p)=x_coord(p)+dx;
8781 right_y(p)=y_coord(p)+dy;
8782 left_x(p)=x_coord(p)-dx;
8783 left_y(p)=y_coord(p)-dy;
8784 left_type(p)=mp_explicit;
8785 right_type(p)=mp_explicit;
8786 originator(p)=mp_program_code
8789 fraction half_cos[8]; /* ${1\over2}\cos(45k)$ */
8790 fraction d_cos[8]; /* a magic constant times $\cos(45k)$ */
8792 @ The magic constant for |d_cos| is the distance between $({1\over2},0)$ and
8793 $({1\over4}\sqrt2,{1\over4}\sqrt2)$ times the result of the |velocity|
8794 function for $\theta=\phi=22.5^\circ$. This comes out to be
8795 $$ d = {\sqrt{2-\sqrt2}\over 3+3\cos22.5^\circ}
8796 \approx 0.132608244919772.
8800 mp->half_cos[0]=fraction_half;
8801 mp->half_cos[1]=94906266; /* $2^{26}\sqrt2\approx94906265.62$ */
8803 mp->d_cos[0]=35596755; /* $2^{28}d\approx35596754.69$ */
8804 mp->d_cos[1]=25170707; /* $2^{27}\sqrt2\,d\approx25170706.63$ */
8806 for (k=3;k<= 4;k++ ) {
8807 mp->half_cos[k]=-mp->half_cos[4-k];
8808 mp->d_cos[k]=-mp->d_cos[4-k];
8810 for (k=5;k<= 7;k++ ) {
8811 mp->half_cos[k]=mp->half_cos[8-k];
8812 mp->d_cos[k]=mp->d_cos[8-k];
8815 @ The |convex_hull| function forces a pen polygon to be convex when it is
8816 returned by |make_pen| and after any subsequent transformation where rounding
8817 error might allow the convexity to be lost.
8818 The convex hull algorithm used here is described by F.~P. Preparata and
8819 M.~I. Shamos [{\sl Computational Geometry}, Springer-Verlag, 1985].
8821 @<Declare a function called |convex_hull|@>=
8822 @<Declare a procedure called |move_knot|@>
8823 pointer mp_convex_hull (MP mp,pointer h) { /* Make a polygonal pen convex */
8824 pointer l,r; /* the leftmost and rightmost knots */
8825 pointer p,q; /* knots being scanned */
8826 pointer s; /* the starting point for an upcoming scan */
8827 scaled dx,dy; /* a temporary pointer */
8828 if ( pen_is_elliptical(h) ) {
8831 @<Set |l| to the leftmost knot in polygon~|h|@>;
8832 @<Set |r| to the rightmost knot in polygon~|h|@>;
8835 @<Find any knots on the path from |l| to |r| above the |l|-|r| line and
8836 move them past~|r|@>;
8837 @<Find any knots on the path from |s| to |l| below the |l|-|r| line and
8838 move them past~|l|@>;
8839 @<Sort the path from |l| to |r| by increasing $x$@>;
8840 @<Sort the path from |r| to |l| by decreasing $x$@>;
8843 @<Do a Gramm scan and remove vertices where there is no left turn@>;
8849 @ All comparisons are done primarily on $x$ and secondarily on $y$.
8851 @<Set |l| to the leftmost knot in polygon~|h|@>=
8855 if ( x_coord(p)<=x_coord(l) )
8856 if ( (x_coord(p)<x_coord(l)) || (y_coord(p)<y_coord(l)) )
8861 @ @<Set |r| to the rightmost knot in polygon~|h|@>=
8865 if ( x_coord(p)>=x_coord(r) )
8866 if ( (x_coord(p)>x_coord(r)) || (y_coord(p)>y_coord(r)) )
8871 @ @<Find any knots on the path from |l| to |r| above the |l|-|r| line...@>=
8872 dx=x_coord(r)-x_coord(l);
8873 dy=y_coord(r)-y_coord(l);
8877 if ( mp_ab_vs_cd(mp, dx,y_coord(p)-y_coord(l),dy,x_coord(p)-x_coord(l))>0 )
8878 mp_move_knot(mp, p, r);
8882 @ The |move_knot| procedure removes |p| from a doubly linked list and inserts
8885 @ @<Declare a procedure called |move_knot|@>=
8886 void mp_move_knot (MP mp,pointer p, pointer q) {
8887 link(knil(p))=link(p);
8888 knil(link(p))=knil(p);
8895 @ @<Find any knots on the path from |s| to |l| below the |l|-|r| line...@>=
8899 if ( mp_ab_vs_cd(mp, dx,y_coord(p)-y_coord(l),dy,x_coord(p)-x_coord(l))<0 )
8900 mp_move_knot(mp, p,l);
8904 @ The list is likely to be in order already so we just do linear insertions.
8905 Secondary comparisons on $y$ ensure that the sort is consistent with the
8906 choice of |l| and |r|.
8908 @<Sort the path from |l| to |r| by increasing $x$@>=
8912 while ( x_coord(q)>x_coord(p) ) q=knil(q);
8913 while ( x_coord(q)==x_coord(p) ) {
8914 if ( y_coord(q)>y_coord(p) ) q=knil(q); else break;
8916 if ( q==knil(p) ) p=link(p);
8917 else { p=link(p); mp_move_knot(mp, knil(p),q); };
8920 @ @<Sort the path from |r| to |l| by decreasing $x$@>=
8924 while ( x_coord(q)<x_coord(p) ) q=knil(q);
8925 while ( x_coord(q)==x_coord(p) ) {
8926 if ( y_coord(q)<y_coord(p) ) q=knil(q); else break;
8928 if ( q==knil(p) ) p=link(p);
8929 else { p=link(p); mp_move_knot(mp, knil(p),q); };
8932 @ The condition involving |ab_vs_cd| tests if there is not a left turn
8933 at knot |q|. There usually will be a left turn so we streamline the case
8934 where the |then| clause is not executed.
8936 @<Do a Gramm scan and remove vertices where there...@>=
8940 dx=x_coord(q)-x_coord(p);
8941 dy=y_coord(q)-y_coord(p);
8945 if ( mp_ab_vs_cd(mp, dx,y_coord(q)-y_coord(p),dy,x_coord(q)-x_coord(p))<=0 ) {
8946 @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>;
8951 @ @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>=
8954 mp_free_node(mp, p,knot_node_size);
8955 link(s)=q; knil(q)=s;
8957 else { p=knil(s); q=s; };
8960 @ The |find_offset| procedure sets global variables |(cur_x,cur_y)| to the
8961 offset associated with the given direction |(x,y)|. If two different offsets
8962 apply, it chooses one of them.
8965 void mp_find_offset (MP mp,scaled x, scaled y, pointer h) {
8966 pointer p,q; /* consecutive knots */
8968 /* the transformation matrix for an elliptical pen */
8969 fraction xx,yy; /* untransformed offset for an elliptical pen */
8970 fraction d; /* a temporary register */
8971 if ( pen_is_elliptical(h) ) {
8972 @<Find the offset for |(x,y)| on the elliptical pen~|h|@>
8977 } while (!(mp_ab_vs_cd(mp, x_coord(q)-x_coord(p),y, y_coord(q)-y_coord(p),x)>=0));
8980 } while (!(mp_ab_vs_cd(mp, x_coord(q)-x_coord(p),y, y_coord(q)-y_coord(p),x)<=0));
8981 mp->cur_x=x_coord(p);
8982 mp->cur_y=y_coord(p);
8988 scaled cur_y; /* all-purpose return value registers */
8990 @ @<Find the offset for |(x,y)| on the elliptical pen~|h|@>=
8991 if ( (x==0) && (y==0) ) {
8992 mp->cur_x=x_coord(h); mp->cur_y=y_coord(h);
8994 @<Find the non-constant part of the transformation for |h|@>;
8995 while ( (abs(x)<fraction_half) && (abs(y)<fraction_half) ){
8998 @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the
8999 untransformed version of |(x,y)|@>;
9000 mp->cur_x=x_coord(h)+mp_take_fraction(mp, xx,wx)+mp_take_fraction(mp, yy,hx);
9001 mp->cur_y=y_coord(h)+mp_take_fraction(mp, xx,wy)+mp_take_fraction(mp, yy,hy);
9004 @ @<Find the non-constant part of the transformation for |h|@>=
9005 wx=left_x(h)-x_coord(h);
9006 wy=left_y(h)-y_coord(h);
9007 hx=right_x(h)-x_coord(h);
9008 hy=right_y(h)-y_coord(h)
9010 @ @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the...@>=
9011 yy=-(mp_take_fraction(mp, x,hy)+mp_take_fraction(mp, y,-hx));
9012 xx=mp_take_fraction(mp, x,-wy)+mp_take_fraction(mp, y,wx);
9013 d=mp_pyth_add(mp, xx,yy);
9015 xx=half(mp_make_fraction(mp, xx,d));
9016 yy=half(mp_make_fraction(mp, yy,d));
9019 @ Finding the bounding box of a pen is easy except if the pen is elliptical.
9020 But we can handle that case by just calling |find_offset| twice. The answer
9021 is stored in the global variables |minx|, |maxx|, |miny|, and |maxy|.
9024 void mp_pen_bbox (MP mp,pointer h) {
9025 pointer p; /* for scanning the knot list */
9026 if ( pen_is_elliptical(h) ) {
9027 @<Find the bounding box of an elliptical pen@>;
9029 minx=x_coord(h); maxx=minx;
9030 miny=y_coord(h); maxy=miny;
9033 if ( x_coord(p)<minx ) minx=x_coord(p);
9034 if ( y_coord(p)<miny ) miny=y_coord(p);
9035 if ( x_coord(p)>maxx ) maxx=x_coord(p);
9036 if ( y_coord(p)>maxy ) maxy=y_coord(p);
9042 @ @<Find the bounding box of an elliptical pen@>=
9044 mp_find_offset(mp, 0,fraction_one,h);
9046 minx=2*x_coord(h)-mp->cur_x;
9047 mp_find_offset(mp, -fraction_one,0,h);
9049 miny=2*y_coord(h)-mp->cur_y;
9052 @* \[21] Edge structures.
9053 Now we come to \MP's internal scheme for representing pictures.
9054 The representation is very different from \MF's edge structures
9055 because \MP\ pictures contain \ps\ graphics objects instead of pixel
9056 images. However, the basic idea is somewhat similar in that shapes
9057 are represented via their boundaries.
9059 The main purpose of edge structures is to keep track of graphical objects
9060 until it is time to translate them into \ps. Since \MP\ does not need to
9061 know anything about an edge structure other than how to translate it into
9062 \ps\ and how to find its bounding box, edge structures can be just linked
9063 lists of graphical objects. \MP\ has no easy way to determine whether
9064 two such objects overlap, but it suffices to draw the first one first and
9065 let the second one overwrite it if necessary.
9068 enum mp_graphical_object_code {
9069 @<Graphical object codes@>
9073 @ Let's consider the types of graphical objects one at a time.
9074 First of all, a filled contour is represented by a eight-word node. The first
9075 word contains |type| and |link| fields, and the next six words contain a
9076 pointer to a cyclic path and the value to use for \ps' \&{currentrgbcolor}
9077 parameter. If a pen is used for filling |pen_p|, |ljoin_val| and |miterlim_val|
9078 give the relevant information.
9080 @d path_p(A) link((A)+1)
9081 /* a pointer to the path that needs filling */
9082 @d pen_p(A) info((A)+1)
9083 /* a pointer to the pen to fill or stroke with */
9084 @d color_model(A) type((A)+2) /* the color model */
9085 @d obj_red_loc(A) ((A)+3) /* the first of three locations for the color */
9086 @d obj_cyan_loc obj_red_loc /* the first of four locations for the color */
9087 @d obj_grey_loc obj_red_loc /* the location for the color */
9088 @d red_val(A) mp->mem[(A)+3].sc
9089 /* the red component of the color in the range $0\ldots1$ */
9092 @d green_val(A) mp->mem[(A)+4].sc
9093 /* the green component of the color in the range $0\ldots1$ */
9094 @d magenta_val green_val
9095 @d blue_val(A) mp->mem[(A)+5].sc
9096 /* the blue component of the color in the range $0\ldots1$ */
9097 @d yellow_val blue_val
9098 @d black_val(A) mp->mem[(A)+6].sc
9099 /* the blue component of the color in the range $0\ldots1$ */
9100 @d ljoin_val(A) name_type((A)) /* the value of \&{linejoin} */
9101 @:mp_linejoin_}{\&{linejoin} primitive@>
9102 @d miterlim_val(A) mp->mem[(A)+7].sc /* the value of \&{miterlimit} */
9103 @:mp_miterlimit_}{\&{miterlimit} primitive@>
9104 @d obj_color_part(A) mp->mem[(A)+3-red_part].sc
9105 /* interpret an object pointer that has been offset by |red_part..blue_part| */
9106 @d pre_script(A) mp->mem[(A)+8].hh.lh
9107 @d post_script(A) mp->mem[(A)+8].hh.rh
9110 @ @<Graphical object codes@>=
9114 pointer mp_new_fill_node (MP mp,pointer p) {
9115 /* make a fill node for cyclic path |p| and color black */
9116 pointer t; /* the new node */
9117 t=mp_get_node(mp, fill_node_size);
9118 type(t)=mp_fill_code;
9120 pen_p(t)=null; /* |null| means don't use a pen */
9125 color_model(t)=mp_uninitialized_model;
9127 post_script(t)=null;
9128 @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>;
9132 @ @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>=
9133 if ( mp->internal[mp_linejoin]>unity ) ljoin_val(t)=2;
9134 else if ( mp->internal[mp_linejoin]>0 ) ljoin_val(t)=1;
9135 else ljoin_val(t)=0;
9136 if ( mp->internal[mp_miterlimit]<unity )
9137 miterlim_val(t)=unity;
9139 miterlim_val(t)=mp->internal[mp_miterlimit]
9141 @ A stroked path is represented by an eight-word node that is like a filled
9142 contour node except that it contains the current \&{linecap} value, a scale
9143 factor for the dash pattern, and a pointer that is non-null if the stroke
9144 is to be dashed. The purpose of the scale factor is to allow a picture to
9145 be transformed without touching the picture that |dash_p| points to.
9147 @d dash_p(A) link((A)+9)
9148 /* a pointer to the edge structure that gives the dash pattern */
9149 @d lcap_val(A) type((A)+9)
9150 /* the value of \&{linecap} */
9151 @:mp_linecap_}{\&{linecap} primitive@>
9152 @d dash_scale(A) mp->mem[(A)+10].sc /* dash lengths are scaled by this factor */
9153 @d stroked_node_size 11
9155 @ @<Graphical object codes@>=
9159 pointer mp_new_stroked_node (MP mp,pointer p) {
9160 /* make a stroked node for path |p| with |pen_p(p)| temporarily |null| */
9161 pointer t; /* the new node */
9162 t=mp_get_node(mp, stroked_node_size);
9163 type(t)=mp_stroked_code;
9164 path_p(t)=p; pen_p(t)=null;
9166 dash_scale(t)=unity;
9171 color_model(t)=mp_uninitialized_model;
9173 post_script(t)=null;
9174 @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>;
9175 if ( mp->internal[mp_linecap]>unity ) lcap_val(t)=2;
9176 else if ( mp->internal[mp_linecap]>0 ) lcap_val(t)=1;
9181 @ When a dashed line is computed in a transformed coordinate system, the dash
9182 lengths get scaled like the pen shape and we need to compensate for this. Since
9183 there is no unique scale factor for an arbitrary transformation, we use the
9184 the square root of the determinant. The properties of the determinant make it
9185 easier to maintain the |dash_scale|. The computation is fairly straight-forward
9186 except for the initialization of the scale factor |s|. The factor of 64 is
9187 needed because |square_rt| scales its result by $2^8$ while we need $2^{14}$
9188 to counteract the effect of |take_fraction|.
9190 @<Declare subroutines needed by |print_edges|@>=
9191 scaled mp_sqrt_det (MP mp,scaled a, scaled b, scaled c, scaled d) {
9192 scaled maxabs; /* $max(|a|,|b|,|c|,|d|)$ */
9193 integer s; /* amount by which the result of |square_rt| needs to be scaled */
9194 @<Initialize |maxabs|@>;
9196 while ( (maxabs<fraction_one) && (s>1) ){
9197 a+=a; b+=b; c+=c; d+=d;
9198 maxabs+=maxabs; s=halfp(s);
9200 return s*mp_square_rt(mp, abs(mp_take_fraction(mp, a,d)-mp_take_fraction(mp, b,c)));
9203 scaled mp_get_pen_scale (MP mp,pointer p) {
9204 return mp_sqrt_det(mp,
9205 left_x(p)-x_coord(p), right_x(p)-x_coord(p),
9206 left_y(p)-y_coord(p), right_y(p)-y_coord(p));
9209 @ @<Internal library ...@>=
9210 scaled mp_sqrt_det (MP mp,scaled a, scaled b, scaled c, scaled d) ;
9213 @ @<Initialize |maxabs|@>=
9215 if ( abs(b)>maxabs ) maxabs=abs(b);
9216 if ( abs(c)>maxabs ) maxabs=abs(c);
9217 if ( abs(d)>maxabs ) maxabs=abs(d)
9219 @ When a picture contains text, this is represented by a fourteen-word node
9220 where the color information and |type| and |link| fields are augmented by
9221 additional fields that describe the text and how it is transformed.
9222 The |path_p| and |pen_p| pointers are replaced by a number that identifies
9223 the font and a string number that gives the text to be displayed.
9224 The |width|, |height|, and |depth| fields
9225 give the dimensions of the text at its design size, and the remaining six
9226 words give a transformation to be applied to the text. The |new_text_node|
9227 function initializes everything to default values so that the text comes out
9228 black with its reference point at the origin.
9230 @d text_p(A) link((A)+1) /* a string pointer for the text to display */
9231 @d font_n(A) info((A)+1) /* the font number */
9232 @d width_val(A) mp->mem[(A)+7].sc /* unscaled width of the text */
9233 @d height_val(A) mp->mem[(A)+9].sc /* unscaled height of the text */
9234 @d depth_val(A) mp->mem[(A)+10].sc /* unscaled depth of the text */
9235 @d text_tx_loc(A) ((A)+11)
9236 /* the first of six locations for transformation parameters */
9237 @d tx_val(A) mp->mem[(A)+11].sc /* $x$ shift amount */
9238 @d ty_val(A) mp->mem[(A)+12].sc /* $y$ shift amount */
9239 @d txx_val(A) mp->mem[(A)+13].sc /* |txx| transformation parameter */
9240 @d txy_val(A) mp->mem[(A)+14].sc /* |txy| transformation parameter */
9241 @d tyx_val(A) mp->mem[(A)+15].sc /* |tyx| transformation parameter */
9242 @d tyy_val(A) mp->mem[(A)+16].sc /* |tyy| transformation parameter */
9243 @d text_trans_part(A) mp->mem[(A)+11-x_part].sc
9244 /* interpret a text node pointer that has been offset by |x_part..yy_part| */
9245 @d text_node_size 17
9247 @ @<Graphical object codes@>=
9250 @ @c @<Declare text measuring subroutines@>
9251 pointer mp_new_text_node (MP mp,char *f,str_number s) {
9252 /* make a text node for font |f| and text string |s| */
9253 pointer t; /* the new node */
9254 t=mp_get_node(mp, text_node_size);
9255 type(t)=mp_text_code;
9257 font_n(t)=mp_find_font(mp, f); /* this identifies the font */
9262 color_model(t)=mp_uninitialized_model;
9264 post_script(t)=null;
9265 tx_val(t)=0; ty_val(t)=0;
9266 txx_val(t)=unity; txy_val(t)=0;
9267 tyx_val(t)=0; tyy_val(t)=unity;
9268 mp_set_text_box(mp, t); /* this finds the bounding box */
9272 @ The last two types of graphical objects that can occur in an edge structure
9273 are clipping paths and \&{setbounds} paths. These are slightly more difficult
9274 @:set_bounds_}{\&{setbounds} primitive@>
9275 to implement because we must keep track of exactly what is being clipped or
9276 bounded when pictures get merged together. For this reason, each clipping or
9277 \&{setbounds} operation is represented by a pair of nodes: first comes a
9278 two-word node whose |path_p| gives the relevant path, then there is the list
9279 of objects to clip or bound followed by a two-word node whose second word is
9282 Using at least two words for each graphical object node allows them all to be
9283 allocated and deallocated similarly with a global array |gr_object_size| to
9284 give the size in words for each object type.
9286 @d start_clip_size 2
9287 @d start_bounds_size 2
9288 @d stop_clip_size 2 /* the second word is not used here */
9289 @d stop_bounds_size 2 /* the second word is not used here */
9291 @d stop_type(A) ((A)+2)
9292 /* matching |type| for |start_clip_code| or |start_bounds_code| */
9293 @d has_color(A) (type((A))<mp_start_clip_code)
9294 /* does a graphical object have color fields? */
9295 @d has_pen(A) (type((A))<mp_text_code)
9296 /* does a graphical object have a |pen_p| field? */
9297 @d is_start_or_stop(A) (type((A))>=mp_start_clip_code)
9298 @d is_stop(A) (type((A))>=mp_stop_clip_code)
9300 @ @<Graphical object codes@>=
9301 mp_start_clip_code=4, /* |type| of a node that starts clipping */
9302 mp_start_bounds_code=5, /* |type| of a node that gives a \&{setbounds} path */
9303 mp_stop_clip_code=6, /* |type| of a node that stops clipping */
9304 mp_stop_bounds_code=7, /* |type| of a node that stops \&{setbounds} */
9307 pointer mp_new_bounds_node (MP mp,pointer p, small_number c) {
9308 /* make a node of type |c| where |p| is the clipping or \&{setbounds} path */
9309 pointer t; /* the new node */
9310 t=mp_get_node(mp, mp->gr_object_size[c]);
9316 @ We need an array to keep track of the sizes of graphical objects.
9319 small_number gr_object_size[mp_stop_bounds_code+1];
9322 mp->gr_object_size[mp_fill_code]=fill_node_size;
9323 mp->gr_object_size[mp_stroked_code]=stroked_node_size;
9324 mp->gr_object_size[mp_text_code]=text_node_size;
9325 mp->gr_object_size[mp_start_clip_code]=start_clip_size;
9326 mp->gr_object_size[mp_stop_clip_code]=stop_clip_size;
9327 mp->gr_object_size[mp_start_bounds_code]=start_bounds_size;
9328 mp->gr_object_size[mp_stop_bounds_code]=stop_bounds_size;
9330 @ All the essential information in an edge structure is encoded as a linked list
9331 of graphical objects as we have just seen, but it is helpful to add some
9332 redundant information. A single edge structure might be used as a dash pattern
9333 many times, and it would be nice to avoid scanning the same structure
9334 repeatedly. Thus, an edge structure known to be a suitable dash pattern
9335 has a header that gives a list of dashes in a sorted order designed for rapid
9336 translation into \ps.
9338 Each dash is represented by a three-word node containing the initial and final
9339 $x$~coordinates as well as the usual |link| field. The |link| fields points to
9340 the dash node with the next higher $x$-coordinates and the final link points
9341 to a special location called |null_dash|. (There should be no overlap between
9342 dashes). Since the $y$~coordinate of the dash pattern is needed to determine
9343 the period of repetition, this needs to be stored in the edge header along
9344 with a pointer to the list of dash nodes.
9346 @d start_x(A) mp->mem[(A)+1].sc /* the starting $x$~coordinate in a dash node */
9347 @d stop_x(A) mp->mem[(A)+2].sc /* the ending $x$~coordinate in a dash node */
9350 /* in an edge header this points to the first dash node */
9351 @d dash_y(A) mp->mem[(A)+1].sc /* $y$ value for the dash list in an edge header */
9353 @ It is also convenient for an edge header to contain the bounding
9354 box information needed by the \&{llcorner} and \&{urcorner} operators
9355 so that this does not have to be recomputed unnecessarily. This is done by
9356 adding fields for the $x$~and $y$ extremes as well as a pointer that indicates
9357 how far the bounding box computation has gotten. Thus if the user asks for
9358 the bounding box and then adds some more text to the picture before asking
9359 for more bounding box information, the second computation need only look at
9360 the additional text.
9362 When the bounding box has not been computed, the |bblast| pointer points
9363 to a dummy link at the head of the graphical object list while the |minx_val|
9364 and |miny_val| fields contain |el_gordo| and the |maxx_val| and |maxy_val|
9365 fields contain |-el_gordo|.
9367 Since the bounding box of pictures containing objects of type
9368 |mp_start_bounds_code| depends on the value of \&{truecorners}, the bounding box
9369 @:mp_true_corners_}{\&{truecorners} primitive@>
9370 data might not be valid for all values of this parameter. Hence, the |bbtype|
9371 field is needed to keep track of this.
9373 @d minx_val(A) mp->mem[(A)+2].sc
9374 @d miny_val(A) mp->mem[(A)+3].sc
9375 @d maxx_val(A) mp->mem[(A)+4].sc
9376 @d maxy_val(A) mp->mem[(A)+5].sc
9377 @d bblast(A) link((A)+6) /* last item considered in bounding box computation */
9378 @d bbtype(A) info((A)+6) /* tells how bounding box data depends on \&{truecorners} */
9379 @d dummy_loc(A) ((A)+7) /* where the object list begins in an edge header */
9381 /* |bbtype| value when bounding box data is valid for all \&{truecorners} values */
9383 /* |bbtype| value when bounding box data is for \&{truecorners}${}\le 0$ */
9385 /* |bbtype| value when bounding box data is for \&{truecorners}${}>0$ */
9388 void mp_init_bbox (MP mp,pointer h) {
9389 /* Initialize the bounding box information in edge structure |h| */
9390 bblast(h)=dummy_loc(h);
9391 bbtype(h)=no_bounds;
9392 minx_val(h)=el_gordo;
9393 miny_val(h)=el_gordo;
9394 maxx_val(h)=-el_gordo;
9395 maxy_val(h)=-el_gordo;
9398 @ The only other entries in an edge header are a reference count in the first
9399 word and a pointer to the tail of the object list in the last word.
9401 @d obj_tail(A) info((A)+7) /* points to the last entry in the object list */
9402 @d edge_header_size 8
9405 void mp_init_edges (MP mp,pointer h) {
9406 /* initialize an edge header to null values */
9407 dash_list(h)=null_dash;
9408 obj_tail(h)=dummy_loc(h);
9409 link(dummy_loc(h))=null;
9411 mp_init_bbox(mp, h);
9414 @ Here is how edge structures are deleted. The process can be recursive because
9415 of the need to dereference edge structures that are used as dash patterns.
9418 @d add_edge_ref(A) incr(ref_count(A))
9419 @d delete_edge_ref(A) {
9420 if ( ref_count((A))==null )
9421 mp_toss_edges(mp, A);
9426 @<Declare the recycling subroutines@>=
9427 void mp_flush_dash_list (MP mp,pointer h);
9428 pointer mp_toss_gr_object (MP mp,pointer p) ;
9429 void mp_toss_edges (MP mp,pointer h) ;
9431 @ @c void mp_toss_edges (MP mp,pointer h) {
9432 pointer p,q; /* pointers that scan the list being recycled */
9433 pointer r; /* an edge structure that object |p| refers to */
9434 mp_flush_dash_list(mp, h);
9435 q=link(dummy_loc(h));
9436 while ( (q!=null) ) {
9438 r=mp_toss_gr_object(mp, p);
9439 if ( r!=null ) delete_edge_ref(r);
9441 mp_free_node(mp, h,edge_header_size);
9443 void mp_flush_dash_list (MP mp,pointer h) {
9444 pointer p,q; /* pointers that scan the list being recycled */
9446 while ( q!=null_dash ) {
9448 mp_free_node(mp, p,dash_node_size);
9450 dash_list(h)=null_dash;
9452 pointer mp_toss_gr_object (MP mp,pointer p) {
9453 /* returns an edge structure that needs to be dereferenced */
9454 pointer e; /* the edge structure to return */
9456 @<Prepare to recycle graphical object |p|@>;
9457 mp_free_node(mp, p,mp->gr_object_size[type(p)]);
9461 @ @<Prepare to recycle graphical object |p|@>=
9464 mp_toss_knot_list(mp, path_p(p));
9465 if ( pen_p(p)!=null ) mp_toss_knot_list(mp, pen_p(p));
9466 if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
9467 if ( post_script(p)!=null ) delete_str_ref(post_script(p));
9469 case mp_stroked_code:
9470 mp_toss_knot_list(mp, path_p(p));
9471 if ( pen_p(p)!=null ) mp_toss_knot_list(mp, pen_p(p));
9472 if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
9473 if ( post_script(p)!=null ) delete_str_ref(post_script(p));
9477 delete_str_ref(text_p(p));
9478 if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
9479 if ( post_script(p)!=null ) delete_str_ref(post_script(p));
9481 case mp_start_clip_code:
9482 case mp_start_bounds_code:
9483 mp_toss_knot_list(mp, path_p(p));
9485 case mp_stop_clip_code:
9486 case mp_stop_bounds_code:
9488 } /* there are no other cases */
9490 @ If we use |add_edge_ref| to ``copy'' edge structures, the real copying needs
9491 to be done before making a significant change to an edge structure. Much of
9492 the work is done in a separate routine |copy_objects| that copies a list of
9493 graphical objects into a new edge header.
9495 @c @<Declare a function called |copy_objects|@>
9496 pointer mp_private_edges (MP mp,pointer h) {
9497 /* make a private copy of the edge structure headed by |h| */
9498 pointer hh; /* the edge header for the new copy */
9499 pointer p,pp; /* pointers for copying the dash list */
9500 if ( ref_count(h)==null ) {
9504 hh=mp_copy_objects(mp, link(dummy_loc(h)),null);
9505 @<Copy the dash list from |h| to |hh|@>;
9506 @<Copy the bounding box information from |h| to |hh| and make |bblast(hh)|
9507 point into the new object list@>;
9512 @ Here we use the fact that |dash_list(hh)=link(hh)|.
9513 @^data structure assumptions@>
9515 @<Copy the dash list from |h| to |hh|@>=
9516 pp=hh; p=dash_list(h);
9517 while ( (p!=null_dash) ) {
9518 link(pp)=mp_get_node(mp, dash_node_size);
9520 start_x(pp)=start_x(p);
9521 stop_x(pp)=stop_x(p);
9525 dash_y(hh)=dash_y(h)
9528 @ |h| is an edge structure
9531 mp_dash_object *mp_export_dashes (MP mp, pointer q, scaled *w) {
9534 scaled scf; /* scale factor */
9538 if (h==null || dash_list(h)==null_dash)
9541 scf=mp_get_pen_scale(mp, pen_p(q));
9543 if (*w==0) scf = dash_scale(q); else return NULL;
9545 scf=mp_make_scaled(mp, *w,scf);
9546 scf=mp_take_scaled(mp, scf,dash_scale(q));
9549 d = mp_xmalloc(mp,1,sizeof(mp_dash_object));
9550 start_x(null_dash)=start_x(p)+dash_y(h);
9551 while (p != null_dash) {
9552 dashes = mp_xrealloc(mp, dashes, num_dashes+2, sizeof(scaled));
9553 dashes[(num_dashes-1)] =
9554 mp_take_scaled(mp,(stop_x(p)-start_x(p)),scf);
9555 dashes[(num_dashes)] =
9556 mp_take_scaled(mp,(start_x(link(p))-stop_x(p)),scf);
9557 dashes[(num_dashes+1)] = -1; /* terminus */
9561 d->array_field = dashes;
9563 mp_take_scaled(mp,mp_dash_offset(mp, h),scf);
9569 @ @<Copy the bounding box information from |h| to |hh|...@>=
9570 minx_val(hh)=minx_val(h);
9571 miny_val(hh)=miny_val(h);
9572 maxx_val(hh)=maxx_val(h);
9573 maxy_val(hh)=maxy_val(h);
9574 bbtype(hh)=bbtype(h);
9575 p=dummy_loc(h); pp=dummy_loc(hh);
9576 while ((p!=bblast(h)) ) {
9577 if ( p==null ) mp_confusion(mp, "bblast");
9578 @:this can't happen bblast}{\quad bblast@>
9579 p=link(p); pp=link(pp);
9583 @ Here is the promised routine for copying graphical objects into a new edge
9584 structure. It starts copying at object~|p| and stops just before object~|q|.
9585 If |q| is null, it copies the entire sublist headed at |p|. The resulting edge
9586 structure requires further initialization by |init_bbox|.
9588 @<Declare a function called |copy_objects|@>=
9589 pointer mp_copy_objects (MP mp, pointer p, pointer q) {
9590 pointer hh; /* the new edge header */
9591 pointer pp; /* the last newly copied object */
9592 small_number k; /* temporary register */
9593 hh=mp_get_node(mp, edge_header_size);
9594 dash_list(hh)=null_dash;
9598 @<Make |link(pp)| point to a copy of object |p|, and update |p| and |pp|@>;
9605 @ @<Make |link(pp)| point to a copy of object |p|, and update |p| and |pp|@>=
9606 { k=mp->gr_object_size[type(p)];
9607 link(pp)=mp_get_node(mp, k);
9609 while ( (k>0) ) { decr(k); mp->mem[pp+k]=mp->mem[p+k]; };
9610 @<Fix anything in graphical object |pp| that should differ from the
9611 corresponding field in |p|@>;
9615 @ @<Fix anything in graphical object |pp| that should differ from the...@>=
9617 case mp_start_clip_code:
9618 case mp_start_bounds_code:
9619 path_p(pp)=mp_copy_path(mp, path_p(p));
9622 path_p(pp)=mp_copy_path(mp, path_p(p));
9623 if ( pre_script(p)!=null ) add_str_ref(pre_script(p));
9624 if ( post_script(p)!=null ) add_str_ref(post_script(p));
9625 if ( pen_p(p)!=null ) pen_p(pp)=copy_pen(pen_p(p));
9627 case mp_stroked_code:
9628 if ( pre_script(p)!=null ) add_str_ref(pre_script(p));
9629 if ( post_script(p)!=null ) add_str_ref(post_script(p));
9630 path_p(pp)=mp_copy_path(mp, path_p(p));
9631 pen_p(pp)=copy_pen(pen_p(p));
9632 if ( dash_p(p)!=null ) add_edge_ref(dash_p(pp));
9635 if ( pre_script(p)!=null ) add_str_ref(pre_script(p));
9636 if ( post_script(p)!=null ) add_str_ref(post_script(p));
9637 add_str_ref(text_p(pp));
9639 case mp_stop_clip_code:
9640 case mp_stop_bounds_code:
9642 } /* there are no other cases */
9644 @ Here is one way to find an acceptable value for the second argument to
9645 |copy_objects|. Given a non-null graphical object list, |skip_1component|
9646 skips past one picture component, where a ``picture component'' is a single
9647 graphical object, or a start bounds or start clip object and everything up
9648 through the matching stop bounds or stop clip object. The macro version avoids
9649 procedure call overhead and error handling: |skip_component(p)(e)| advances |p|
9650 unless |p| points to a stop bounds or stop clip node, in which case it executes
9653 @d skip_component(A)
9654 if ( ! is_start_or_stop((A)) ) (A)=link((A));
9655 else if ( ! is_stop((A)) ) (A)=mp_skip_1component(mp, (A));
9659 pointer mp_skip_1component (MP mp,pointer p) {
9660 integer lev; /* current nesting level */
9663 if ( is_start_or_stop(p) ) {
9664 if ( is_stop(p) ) decr(lev); else incr(lev);
9671 @ Here is a diagnostic routine for printing an edge structure in symbolic form.
9673 @<Declare subroutines for printing expressions@>=
9674 @<Declare subroutines needed by |print_edges|@>
9675 void mp_print_edges (MP mp,pointer h, const char *s, boolean nuline) {
9676 pointer p; /* a graphical object to be printed */
9677 pointer hh,pp; /* temporary pointers */
9678 scaled scf; /* a scale factor for the dash pattern */
9679 boolean ok_to_dash; /* |false| for polygonal pen strokes */
9680 mp_print_diagnostic(mp, "Edge structure",s,nuline);
9682 while ( link(p)!=null ) {
9686 @<Cases for printing graphical object node |p|@>;
9688 mp_print(mp, "[unknown object type!]");
9692 mp_print_nl(mp, "End edges");
9693 if ( p!=obj_tail(h) ) mp_print(mp, "?");
9695 mp_end_diagnostic(mp, true);
9698 @ @<Cases for printing graphical object node |p|@>=
9700 mp_print(mp, "Filled contour ");
9701 mp_print_obj_color(mp, p);
9702 mp_print_char(mp, ':'); mp_print_ln(mp);
9703 mp_pr_path(mp, path_p(p)); mp_print_ln(mp);
9704 if ( (pen_p(p)!=null) ) {
9705 @<Print join type for graphical object |p|@>;
9706 mp_print(mp, " with pen"); mp_print_ln(mp);
9707 mp_pr_pen(mp, pen_p(p));
9711 @ @<Print join type for graphical object |p|@>=
9712 switch (ljoin_val(p)) {
9714 mp_print(mp, "mitered joins limited ");
9715 mp_print_scaled(mp, miterlim_val(p));
9718 mp_print(mp, "round joins");
9721 mp_print(mp, "beveled joins");
9724 mp_print(mp, "?? joins");
9729 @ For stroked nodes, we need to print |lcap_val(p)| as well.
9731 @<Print join and cap types for stroked node |p|@>=
9732 switch (lcap_val(p)) {
9733 case 0:mp_print(mp, "butt"); break;
9734 case 1:mp_print(mp, "round"); break;
9735 case 2:mp_print(mp, "square"); break;
9736 default: mp_print(mp, "??"); break;
9739 mp_print(mp, " ends, ");
9740 @<Print join type for graphical object |p|@>
9742 @ Here is a routine that prints the color of a graphical object if it isn't
9743 black (the default color).
9745 @<Declare subroutines needed by |print_edges|@>=
9746 @<Declare a procedure called |print_compact_node|@>
9747 void mp_print_obj_color (MP mp,pointer p) {
9748 if ( color_model(p)==mp_grey_model ) {
9749 if ( grey_val(p)>0 ) {
9750 mp_print(mp, "greyed ");
9751 mp_print_compact_node(mp, obj_grey_loc(p),1);
9753 } else if ( color_model(p)==mp_cmyk_model ) {
9754 if ( (cyan_val(p)>0) || (magenta_val(p)>0) ||
9755 (yellow_val(p)>0) || (black_val(p)>0) ) {
9756 mp_print(mp, "processcolored ");
9757 mp_print_compact_node(mp, obj_cyan_loc(p),4);
9759 } else if ( color_model(p)==mp_rgb_model ) {
9760 if ( (red_val(p)>0) || (green_val(p)>0) || (blue_val(p)>0) ) {
9761 mp_print(mp, "colored ");
9762 mp_print_compact_node(mp, obj_red_loc(p),3);
9767 @ We also need a procedure for printing consecutive scaled values as if they
9768 were a known big node.
9770 @<Declare a procedure called |print_compact_node|@>=
9771 void mp_print_compact_node (MP mp,pointer p, small_number k) {
9772 pointer q; /* last location to print */
9774 mp_print_char(mp, '(');
9776 mp_print_scaled(mp, mp->mem[p].sc);
9777 if ( p<q ) mp_print_char(mp, ',');
9780 mp_print_char(mp, ')');
9783 @ @<Cases for printing graphical object node |p|@>=
9784 case mp_stroked_code:
9785 mp_print(mp, "Filled pen stroke ");
9786 mp_print_obj_color(mp, p);
9787 mp_print_char(mp, ':'); mp_print_ln(mp);
9788 mp_pr_path(mp, path_p(p));
9789 if ( dash_p(p)!=null ) {
9790 mp_print_nl(mp, "dashed (");
9791 @<Finish printing the dash pattern that |p| refers to@>;
9794 @<Print join and cap types for stroked node |p|@>;
9795 mp_print(mp, " with pen"); mp_print_ln(mp);
9796 if ( pen_p(p)==null ) mp_print(mp, "???"); /* shouldn't happen */
9798 else mp_pr_pen(mp, pen_p(p));
9801 @ Normally, the |dash_list| field in an edge header is set to |null_dash|
9802 when it is not known to define a suitable dash pattern. This is disallowed
9803 here because the |dash_p| field should never point to such an edge header.
9804 Note that memory is allocated for |start_x(null_dash)| and we are free to
9805 give it any convenient value.
9807 @<Finish printing the dash pattern that |p| refers to@>=
9808 ok_to_dash=pen_is_elliptical(pen_p(p));
9809 if ( ! ok_to_dash ) scf=unity; else scf=dash_scale(p);
9812 if ( (pp==null_dash) || (dash_y(hh)<0) ) {
9813 mp_print(mp, " ??");
9814 } else { start_x(null_dash)=start_x(pp)+dash_y(hh);
9815 while ( pp!=null_dash ) {
9816 mp_print(mp, "on ");
9817 mp_print_scaled(mp, mp_take_scaled(mp, stop_x(pp)-start_x(pp),scf));
9818 mp_print(mp, " off ");
9819 mp_print_scaled(mp, mp_take_scaled(mp, start_x(link(pp))-stop_x(pp),scf));
9821 if ( pp!=null_dash ) mp_print_char(mp, ' ');
9823 mp_print(mp, ") shifted ");
9824 mp_print_scaled(mp, -mp_take_scaled(mp, mp_dash_offset(mp, hh),scf));
9825 if ( ! ok_to_dash || (dash_y(hh)==0) ) mp_print(mp, " (this will be ignored)");
9828 @ @<Declare subroutines needed by |print_edges|@>=
9829 scaled mp_dash_offset (MP mp,pointer h) {
9830 scaled x; /* the answer */
9831 if (dash_list(h)==null_dash || dash_y(h)<0) mp_confusion(mp, "dash0");
9832 @:this can't happen dash0}{\quad dash0@>
9833 if ( dash_y(h)==0 ) {
9836 x=-(start_x(dash_list(h)) % dash_y(h));
9837 if ( x<0 ) x=x+dash_y(h);
9842 @ @<Cases for printing graphical object node |p|@>=
9844 mp_print_char(mp, '"'); mp_print_str(mp,text_p(p));
9845 mp_print(mp, "\" infont \""); mp_print(mp, mp->font_name[font_n(p)]);
9846 mp_print_char(mp, '"'); mp_print_ln(mp);
9847 mp_print_obj_color(mp, p);
9848 mp_print(mp, "transformed ");
9849 mp_print_compact_node(mp, text_tx_loc(p),6);
9852 @ @<Cases for printing graphical object node |p|@>=
9853 case mp_start_clip_code:
9854 mp_print(mp, "clipping path:");
9856 mp_pr_path(mp, path_p(p));
9858 case mp_stop_clip_code:
9859 mp_print(mp, "stop clipping");
9862 @ @<Cases for printing graphical object node |p|@>=
9863 case mp_start_bounds_code:
9864 mp_print(mp, "setbounds path:");
9866 mp_pr_path(mp, path_p(p));
9868 case mp_stop_bounds_code:
9869 mp_print(mp, "end of setbounds");
9872 @ To initialize the |dash_list| field in an edge header~|h|, we need a
9873 subroutine that scans an edge structure and tries to interpret it as a dash
9874 pattern. This can only be done when there are no filled regions or clipping
9875 paths and all the pen strokes have the same color. The first step is to let
9876 $y_0$ be the initial $y$~coordinate of the first pen stroke. Then we implicitly
9877 project all the pen stroke paths onto the line $y=y_0$ and require that there
9878 be no retracing. If the resulting paths cover a range of $x$~coordinates of
9879 length $\Delta x$, we set |dash_y(h)| to the length of the dash pattern by
9880 finding the maximum of $\Delta x$ and the absolute value of~$y_0$.
9882 @c @<Declare a procedure called |x_retrace_error|@>
9883 pointer mp_make_dashes (MP mp,pointer h) { /* returns |h| or |null| */
9884 pointer p; /* this scans the stroked nodes in the object list */
9885 pointer p0; /* if not |null| this points to the first stroked node */
9886 pointer pp,qq,rr; /* pointers into |path_p(p)| */
9887 pointer d,dd; /* pointers used to create the dash list */
9889 @<Other local variables in |make_dashes|@>;
9890 y0=0; /* the initial $y$ coordinate */
9891 if ( dash_list(h)!=null_dash )
9894 p=link(dummy_loc(h));
9896 if ( type(p)!=mp_stroked_code ) {
9897 @<Compain that the edge structure contains a node of the wrong type
9898 and |goto not_found|@>;
9901 if ( p0==null ){ p0=p; y0=y_coord(pp); };
9902 @<Make |d| point to a new dash node created from stroke |p| and path |pp|
9903 or |goto not_found| if there is an error@>;
9904 @<Insert |d| into the dash list and |goto not_found| if there is an error@>;
9907 if ( dash_list(h)==null_dash )
9908 goto NOT_FOUND; /* No error message */
9909 @<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>;
9910 @<Set |dash_y(h)| and merge the first and last dashes if necessary@>;
9913 @<Flush the dash list, recycle |h| and return |null|@>;
9916 @ @<Compain that the edge structure contains a node of the wrong type...@>=
9918 print_err("Picture is too complicated to use as a dash pattern");
9919 help3("When you say `dashed p', picture p should not contain any")
9920 ("text, filled regions, or clipping paths. This time it did")
9921 ("so I'll just make it a solid line instead.");
9922 mp_put_get_error(mp);
9926 @ A similar error occurs when monotonicity fails.
9928 @<Declare a procedure called |x_retrace_error|@>=
9929 void mp_x_retrace_error (MP mp) {
9930 print_err("Picture is too complicated to use as a dash pattern");
9931 help3("When you say `dashed p', every path in p should be monotone")
9932 ("in x and there must be no overlapping. This failed")
9933 ("so I'll just make it a solid line instead.");
9934 mp_put_get_error(mp);
9937 @ We stash |p| in |info(d)| if |dash_p(p)<>0| so that subsequent processing can
9938 handle the case where the pen stroke |p| is itself dashed.
9940 @<Make |d| point to a new dash node created from stroke |p| and path...@>=
9941 @<Make sure |p| and |p0| are the same color and |goto not_found| if there is
9944 if ( link(pp)!=pp ) {
9947 @<Check for retracing between knots |qq| and |rr| and |goto not_found|
9948 if there is a problem@>;
9949 } while (right_type(rr)!=mp_endpoint);
9951 d=mp_get_node(mp, dash_node_size);
9952 if ( dash_p(p)==0 ) info(d)=0; else info(d)=p;
9953 if ( x_coord(pp)<x_coord(rr) ) {
9954 start_x(d)=x_coord(pp);
9955 stop_x(d)=x_coord(rr);
9957 start_x(d)=x_coord(rr);
9958 stop_x(d)=x_coord(pp);
9961 @ We also need to check for the case where the segment from |qq| to |rr| is
9962 monotone in $x$ but is reversed relative to the path from |pp| to |qq|.
9964 @<Check for retracing between knots |qq| and |rr| and |goto not_found|...@>=
9969 if ( (x0>x1) || (x1>x2) || (x2>x3) ) {
9970 if ( (x0<x1) || (x1<x2) || (x2<x3) ) {
9971 if ( mp_ab_vs_cd(mp, x2-x1,x2-x1,x1-x0,x3-x2)>0 ) {
9972 mp_x_retrace_error(mp); goto NOT_FOUND;
9976 if ( (x_coord(pp)>x0) || (x0>x3) ) {
9977 if ( (x_coord(pp)<x0) || (x0<x3) ) {
9978 mp_x_retrace_error(mp); goto NOT_FOUND;
9982 @ @<Other local variables in |make_dashes|@>=
9983 scaled x0,x1,x2,x3; /* $x$ coordinates of the segment from |qq| to |rr| */
9985 @ @<Make sure |p| and |p0| are the same color and |goto not_found|...@>=
9986 if ( (red_val(p)!=red_val(p0)) || (black_val(p)!=black_val(p0)) ||
9987 (green_val(p)!=green_val(p0)) || (blue_val(p)!=blue_val(p0)) ) {
9988 print_err("Picture is too complicated to use as a dash pattern");
9989 help3("When you say `dashed p', everything in picture p should")
9990 ("be the same color. I can\'t handle your color changes")
9991 ("so I'll just make it a solid line instead.");
9992 mp_put_get_error(mp);
9996 @ @<Insert |d| into the dash list and |goto not_found| if there is an error@>=
9997 start_x(null_dash)=stop_x(d);
9998 dd=h; /* this makes |link(dd)=dash_list(h)| */
9999 while ( start_x(link(dd))<stop_x(d) )
10002 if ( (stop_x(dd)>start_x(d)) )
10003 { mp_x_retrace_error(mp); goto NOT_FOUND; };
10008 @ @<Set |dash_y(h)| and merge the first and last dashes if necessary@>=
10010 while ( (link(d)!=null_dash) )
10013 dash_y(h)=stop_x(d)-start_x(dd);
10014 if ( abs(y0)>dash_y(h) ) {
10016 } else if ( d!=dd ) {
10017 dash_list(h)=link(dd);
10018 stop_x(d)=stop_x(dd)+dash_y(h);
10019 mp_free_node(mp, dd,dash_node_size);
10022 @ We get here when the argument is a null picture or when there is an error.
10023 Recovering from an error involves making |dash_list(h)| empty to indicate
10024 that |h| is not known to be a valid dash pattern. We also dereference |h|
10025 since it is not being used for the return value.
10027 @<Flush the dash list, recycle |h| and return |null|@>=
10028 mp_flush_dash_list(mp, h);
10029 delete_edge_ref(h);
10032 @ Having carefully saved the dashed stroked nodes in the
10033 corresponding dash nodes, we must be prepared to break up these dashes into
10036 @<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>=
10037 d=h; /* now |link(d)=dash_list(h)| */
10038 while ( link(d)!=null_dash ) {
10044 hsf=dash_scale(ds);
10045 if ( (hh==null) ) mp_confusion(mp, "dash1");
10046 @:this can't happen dash0}{\quad dash1@>
10047 if ( dash_y(hh)==0 ) {
10050 if ( dash_list(hh)==null ) mp_confusion(mp, "dash1");
10051 @:this can't happen dash0}{\quad dash1@>
10052 @<Replace |link(d)| by a dashed version as determined by edge header
10053 |hh| and scale factor |ds|@>;
10058 @ @<Other local variables in |make_dashes|@>=
10059 pointer dln; /* |link(d)| */
10060 pointer hh; /* an edge header that tells how to break up |dln| */
10061 scaled hsf; /* the dash pattern from |hh| gets scaled by this */
10062 pointer ds; /* the stroked node from which |hh| and |hsf| are derived */
10063 scaled xoff; /* added to $x$ values in |dash_list(hh)| to match |dln| */
10065 @ @<Replace |link(d)| by a dashed version as determined by edge header...@>=
10068 xoff=start_x(dln)-mp_take_scaled(mp, hsf,start_x(dd))-
10069 mp_take_scaled(mp, hsf,mp_dash_offset(mp, hh));
10070 start_x(null_dash)=mp_take_scaled(mp, hsf,start_x(dd))
10071 +mp_take_scaled(mp, hsf,dash_y(hh));
10072 stop_x(null_dash)=start_x(null_dash);
10073 @<Advance |dd| until finding the first dash that overlaps |dln| when
10074 offset by |xoff|@>;
10075 while ( start_x(dln)<=stop_x(dln) ) {
10076 @<If |dd| has `fallen off the end', back up to the beginning and fix |xoff|@>;
10077 @<Insert a dash between |d| and |dln| for the overlap with the offset version
10080 start_x(dln)=xoff+mp_take_scaled(mp, hsf,start_x(dd));
10083 mp_free_node(mp, dln,dash_node_size)
10085 @ The name of this module is a bit of a lie because we just find the
10086 first |dd| where |take_scaled (hsf, stop_x(dd))| is large enough to make an
10087 overlap possible. It could be that the unoffset version of dash |dln| falls
10088 in the gap between |dd| and its predecessor.
10090 @<Advance |dd| until finding the first dash that overlaps |dln| when...@>=
10091 while ( xoff+mp_take_scaled(mp, hsf,stop_x(dd))<start_x(dln) ) {
10095 @ @<If |dd| has `fallen off the end', back up to the beginning and fix...@>=
10096 if ( dd==null_dash ) {
10098 xoff=xoff+mp_take_scaled(mp, hsf,dash_y(hh));
10101 @ At this point we already know that
10102 |start_x(dln)<=xoff+take_scaled(hsf,stop_x(dd))|.
10104 @<Insert a dash between |d| and |dln| for the overlap with the offset...@>=
10105 if ( (xoff+mp_take_scaled(mp, hsf,start_x(dd)))<=stop_x(dln) ) {
10106 link(d)=mp_get_node(mp, dash_node_size);
10109 if ( start_x(dln)>(xoff+mp_take_scaled(mp, hsf,start_x(dd))))
10110 start_x(d)=start_x(dln);
10112 start_x(d)=xoff+mp_take_scaled(mp, hsf,start_x(dd));
10113 if ( stop_x(dln)<(xoff+mp_take_scaled(mp, hsf,stop_x(dd))))
10114 stop_x(d)=stop_x(dln);
10116 stop_x(d)=xoff+mp_take_scaled(mp, hsf,stop_x(dd));
10119 @ The next major task is to update the bounding box information in an edge
10120 header~|h|. This is done via a procedure |adjust_bbox| that enlarges an edge
10121 header's bounding box to accommodate the box computed by |path_bbox| or
10122 |pen_bbox|. (This is stored in global variables |minx|, |miny|, |maxx|, and
10125 @c void mp_adjust_bbox (MP mp,pointer h) {
10126 if ( minx<minx_val(h) ) minx_val(h)=minx;
10127 if ( miny<miny_val(h) ) miny_val(h)=miny;
10128 if ( maxx>maxx_val(h) ) maxx_val(h)=maxx;
10129 if ( maxy>maxy_val(h) ) maxy_val(h)=maxy;
10132 @ Here is a special routine for updating the bounding box information in
10133 edge header~|h| to account for the squared-off ends of a non-cyclic path~|p|
10134 that is to be stroked with the pen~|pp|.
10136 @c void mp_box_ends (MP mp, pointer p, pointer pp, pointer h) {
10137 pointer q; /* a knot node adjacent to knot |p| */
10138 fraction dx,dy; /* a unit vector in the direction out of the path at~|p| */
10139 scaled d; /* a factor for adjusting the length of |(dx,dy)| */
10140 scaled z; /* a coordinate being tested against the bounding box */
10141 scaled xx,yy; /* the extreme pen vertex in the |(dx,dy)| direction */
10142 integer i; /* a loop counter */
10143 if ( right_type(p)!=mp_endpoint ) {
10146 @<Make |(dx,dy)| the final direction for the path segment from
10147 |q| to~|p|; set~|d|@>;
10148 d=mp_pyth_add(mp, dx,dy);
10150 @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>;
10151 for (i=1;i<= 2;i++) {
10152 @<Use |(dx,dy)| to generate a vertex of the square end cap and
10153 update the bounding box to accommodate it@>;
10157 if ( right_type(p)==mp_endpoint ) {
10160 @<Advance |p| to the end of the path and make |q| the previous knot@>;
10166 @ @<Make |(dx,dy)| the final direction for the path segment from...@>=
10167 if ( q==link(p) ) {
10168 dx=x_coord(p)-right_x(p);
10169 dy=y_coord(p)-right_y(p);
10170 if ( (dx==0)&&(dy==0) ) {
10171 dx=x_coord(p)-left_x(q);
10172 dy=y_coord(p)-left_y(q);
10175 dx=x_coord(p)-left_x(p);
10176 dy=y_coord(p)-left_y(p);
10177 if ( (dx==0)&&(dy==0) ) {
10178 dx=x_coord(p)-right_x(q);
10179 dy=y_coord(p)-right_y(q);
10182 dx=x_coord(p)-x_coord(q);
10183 dy=y_coord(p)-y_coord(q)
10185 @ @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>=
10186 dx=mp_make_fraction(mp, dx,d);
10187 dy=mp_make_fraction(mp, dy,d);
10188 mp_find_offset(mp, -dy,dx,pp);
10189 xx=mp->cur_x; yy=mp->cur_y
10191 @ @<Use |(dx,dy)| to generate a vertex of the square end cap and...@>=
10192 mp_find_offset(mp, dx,dy,pp);
10193 d=mp_take_fraction(mp, xx-mp->cur_x,dx)+mp_take_fraction(mp, yy-mp->cur_y,dy);
10194 if ( ((d<0)&&(i==1)) || ((d>0)&&(i==2)))
10195 mp_confusion(mp, "box_ends");
10196 @:this can't happen box ends}{\quad\\{box\_ends}@>
10197 z=x_coord(p)+mp->cur_x+mp_take_fraction(mp, d,dx);
10198 if ( z<minx_val(h) ) minx_val(h)=z;
10199 if ( z>maxx_val(h) ) maxx_val(h)=z;
10200 z=y_coord(p)+mp->cur_y+mp_take_fraction(mp, d,dy);
10201 if ( z<miny_val(h) ) miny_val(h)=z;
10202 if ( z>maxy_val(h) ) maxy_val(h)=z
10204 @ @<Advance |p| to the end of the path and make |q| the previous knot@>=
10208 } while (right_type(p)!=mp_endpoint)
10210 @ The major difficulty in finding the bounding box of an edge structure is the
10211 effect of clipping paths. We treat them conservatively by only clipping to the
10212 clipping path's bounding box, but this still
10213 requires recursive calls to |set_bbox| in order to find the bounding box of
10215 the objects to be clipped. Such calls are distinguished by the fact that the
10216 boolean parameter |top_level| is false.
10218 @c void mp_set_bbox (MP mp,pointer h, boolean top_level) {
10219 pointer p; /* a graphical object being considered */
10220 scaled sminx,sminy,smaxx,smaxy;
10221 /* for saving the bounding box during recursive calls */
10222 scaled x0,x1,y0,y1; /* temporary registers */
10223 integer lev; /* nesting level for |mp_start_bounds_code| nodes */
10224 @<Wipe out any existing bounding box information if |bbtype(h)| is
10225 incompatible with |internal[mp_true_corners]|@>;
10226 while ( link(bblast(h))!=null ) {
10230 case mp_stop_clip_code:
10231 if ( top_level ) mp_confusion(mp, "bbox"); else return;
10232 @:this can't happen bbox}{\quad bbox@>
10234 @<Other cases for updating the bounding box based on the type of object |p|@>;
10235 } /* all cases are enumerated above */
10237 if ( ! top_level ) mp_confusion(mp, "bbox");
10240 @ @<Internal library declarations@>=
10241 void mp_set_bbox (MP mp,pointer h, boolean top_level);
10243 @ @<Wipe out any existing bounding box information if |bbtype(h)| is...@>=
10244 switch (bbtype(h)) {
10248 if ( mp->internal[mp_true_corners]>0 ) mp_init_bbox(mp, h);
10251 if ( mp->internal[mp_true_corners]<=0 ) mp_init_bbox(mp, h);
10253 } /* there are no other cases */
10255 @ @<Other cases for updating the bounding box...@>=
10257 mp_path_bbox(mp, path_p(p));
10258 if ( pen_p(p)!=null ) {
10261 mp_pen_bbox(mp, pen_p(p));
10267 mp_adjust_bbox(mp, h);
10270 @ @<Other cases for updating the bounding box...@>=
10271 case mp_start_bounds_code:
10272 if ( mp->internal[mp_true_corners]>0 ) {
10273 bbtype(h)=bounds_unset;
10275 bbtype(h)=bounds_set;
10276 mp_path_bbox(mp, path_p(p));
10277 mp_adjust_bbox(mp, h);
10278 @<Scan to the matching |mp_stop_bounds_code| node and update |p| and
10282 case mp_stop_bounds_code:
10283 if ( mp->internal[mp_true_corners]<=0 ) mp_confusion(mp, "bbox2");
10284 @:this can't happen bbox2}{\quad bbox2@>
10287 @ @<Scan to the matching |mp_stop_bounds_code| node and update |p| and...@>=
10290 if ( link(p)==null ) mp_confusion(mp, "bbox2");
10291 @:this can't happen bbox2}{\quad bbox2@>
10293 if ( type(p)==mp_start_bounds_code ) incr(lev);
10294 else if ( type(p)==mp_stop_bounds_code ) decr(lev);
10298 @ It saves a lot of grief here to be slightly conservative and not account for
10299 omitted parts of dashed lines. We also don't worry about the material omitted
10300 when using butt end caps. The basic computation is for round end caps and
10301 |box_ends| augments it for square end caps.
10303 @<Other cases for updating the bounding box...@>=
10304 case mp_stroked_code:
10305 mp_path_bbox(mp, path_p(p));
10308 mp_pen_bbox(mp, pen_p(p));
10313 mp_adjust_bbox(mp, h);
10314 if ( (left_type(path_p(p))==mp_endpoint)&&(lcap_val(p)==2) )
10315 mp_box_ends(mp, path_p(p), pen_p(p), h);
10318 @ The height width and depth information stored in a text node determines a
10319 rectangle that needs to be transformed according to the transformation
10320 parameters stored in the text node.
10322 @<Other cases for updating the bounding box...@>=
10324 x1=mp_take_scaled(mp, txx_val(p),width_val(p));
10325 y0=mp_take_scaled(mp, txy_val(p),-depth_val(p));
10326 y1=mp_take_scaled(mp, txy_val(p),height_val(p));
10329 if ( y0<y1 ) { minx=minx+y0; maxx=maxx+y1; }
10330 else { minx=minx+y1; maxx=maxx+y0; }
10331 if ( x1<0 ) minx=minx+x1; else maxx=maxx+x1;
10332 x1=mp_take_scaled(mp, tyx_val(p),width_val(p));
10333 y0=mp_take_scaled(mp, tyy_val(p),-depth_val(p));
10334 y1=mp_take_scaled(mp, tyy_val(p),height_val(p));
10337 if ( y0<y1 ) { miny=miny+y0; maxy=maxy+y1; }
10338 else { miny=miny+y1; maxy=maxy+y0; }
10339 if ( x1<0 ) miny=miny+x1; else maxy=maxy+x1;
10340 mp_adjust_bbox(mp, h);
10343 @ This case involves a recursive call that advances |bblast(h)| to the node of
10344 type |mp_stop_clip_code| that matches |p|.
10346 @<Other cases for updating the bounding box...@>=
10347 case mp_start_clip_code:
10348 mp_path_bbox(mp, path_p(p));
10351 sminx=minx_val(h); sminy=miny_val(h);
10352 smaxx=maxx_val(h); smaxy=maxy_val(h);
10353 @<Reinitialize the bounding box in header |h| and call |set_bbox| recursively
10354 starting at |link(p)|@>;
10355 @<Clip the bounding box in |h| to the rectangle given by |x0|, |x1|,
10357 minx=sminx; miny=sminy;
10358 maxx=smaxx; maxy=smaxy;
10359 mp_adjust_bbox(mp, h);
10362 @ @<Reinitialize the bounding box in header |h| and call |set_bbox|...@>=
10363 minx_val(h)=el_gordo;
10364 miny_val(h)=el_gordo;
10365 maxx_val(h)=-el_gordo;
10366 maxy_val(h)=-el_gordo;
10367 mp_set_bbox(mp, h,false)
10369 @ @<Clip the bounding box in |h| to the rectangle given by |x0|, |x1|,...@>=
10370 if ( minx_val(h)<x0 ) minx_val(h)=x0;
10371 if ( miny_val(h)<y0 ) miny_val(h)=y0;
10372 if ( maxx_val(h)>x1 ) maxx_val(h)=x1;
10373 if ( maxy_val(h)>y1 ) maxy_val(h)=y1
10375 @* \[22] Finding an envelope.
10376 When \MP\ has a path and a polygonal pen, it needs to express the desired
10377 shape in terms of things \ps\ can understand. The present task is to compute
10378 a new path that describes the region to be filled. It is convenient to
10379 define this as a two step process where the first step is determining what
10380 offset to use for each segment of the path.
10382 @ Given a pointer |c| to a cyclic path,
10383 and a pointer~|h| to the first knot of a pen polygon,
10384 the |offset_prep| routine changes the path into cubics that are
10385 associated with particular pen offsets. Thus if the cubic between |p|
10386 and~|q| is associated with the |k|th offset and the cubic between |q| and~|r|
10387 has offset |l| then |info(q)=zero_off+l-k|. (The constant |zero_off| is added
10388 to because |l-k| could be negative.)
10390 After overwriting the type information with offset differences, we no longer
10391 have a true path so we refer to the knot list returned by |offset_prep| as an
10394 Since an envelope spec only determines relative changes in pen offsets,
10395 |offset_prep| sets a global variable |spec_offset| to the relative change from
10396 |h| to the first offset.
10398 @d zero_off 16384 /* added to offset changes to make them positive */
10401 integer spec_offset; /* number of pen edges between |h| and the initial offset */
10403 @ @c @<Declare subroutines needed by |offset_prep|@>
10404 pointer mp_offset_prep (MP mp,pointer c, pointer h) {
10405 halfword n; /* the number of vertices in the pen polygon */
10406 pointer c0,p,q,q0,r,w, ww; /* for list manipulation */
10407 integer k_needed; /* amount to be added to |info(p)| when it is computed */
10408 pointer w0; /* a pointer to pen offset to use just before |p| */
10409 scaled dxin,dyin; /* the direction into knot |p| */
10410 integer turn_amt; /* change in pen offsets for the current cubic */
10411 @<Other local variables for |offset_prep|@>;
10413 @<Initialize the pen size~|n|@>;
10414 @<Initialize the incoming direction and pen offset at |c|@>;
10415 p=c; c0=c; k_needed=0;
10418 @<Split the cubic between |p| and |q|, if necessary, into cubics
10419 associated with single offsets, after which |q| should
10420 point to the end of the final such cubic@>;
10422 @<Advance |p| to node |q|, removing any ``dead'' cubics that
10423 might have been introduced by the splitting process@>;
10425 @<Fix the offset change in |info(c)| and set |c| to the return value of
10430 @ We shall want to keep track of where certain knots on the cyclic path
10431 wind up in the envelope spec. It doesn't suffice just to keep pointers to
10432 knot nodes because some nodes are deleted while removing dead cubics. Thus
10433 |offset_prep| updates the following pointers
10437 pointer spec_p2; /* pointers to distinguished knots */
10440 mp->spec_p1=null; mp->spec_p2=null;
10442 @ @<Initialize the pen size~|n|@>=
10449 @ Since the true incoming direction isn't known yet, we just pick a direction
10450 consistent with the pen offset~|h|. If this is wrong, it can be corrected
10453 @<Initialize the incoming direction and pen offset at |c|@>=
10454 dxin=x_coord(link(h))-x_coord(knil(h));
10455 dyin=y_coord(link(h))-y_coord(knil(h));
10456 if ( (dxin==0)&&(dyin==0) ) {
10457 dxin=y_coord(knil(h))-y_coord(h);
10458 dyin=x_coord(h)-x_coord(knil(h));
10462 @ We must be careful not to remove the only cubic in a cycle.
10464 But we must also be careful for another reason. If the user-supplied
10465 path starts with a set of degenerate cubics, the target node |q| can
10466 be collapsed to the initial node |p| which might be the same as the
10467 initial node |c| of the curve. This would cause the |offset_prep| routine
10468 to bail out too early, causing distress later on. (See for example
10469 the testcase reported by Bogus\l{}aw Jackowski in tracker id 267, case 52c
10472 @<Advance |p| to node |q|, removing any ``dead'' cubics...@>=
10476 if ( x_coord(p)==right_x(p) && y_coord(p)==right_y(p) &&
10477 x_coord(p)==left_x(r) && y_coord(p)==left_y(r) &&
10478 x_coord(p)==x_coord(r) && y_coord(p)==y_coord(r) &&
10480 @<Remove the cubic following |p| and update the data structures
10481 to merge |r| into |p|@>;
10485 /* Check if we removed too much */
10486 if ((q!=q0)&&(q!=c||c==c0))
10489 @ @<Remove the cubic following |p| and update the data structures...@>=
10490 { k_needed=info(p)-zero_off;
10494 info(p)=k_needed+info(r);
10497 if ( r==c ) { info(p)=info(c); c=p; };
10498 if ( r==mp->spec_p1 ) mp->spec_p1=p;
10499 if ( r==mp->spec_p2 ) mp->spec_p2=p;
10500 r=p; mp_remove_cubic(mp, p);
10503 @ Not setting the |info| field of the newly created knot allows the splitting
10504 routine to work for paths.
10506 @<Declare subroutines needed by |offset_prep|@>=
10507 void mp_split_cubic (MP mp,pointer p, fraction t) { /* splits the cubic after |p| */
10508 scaled v; /* an intermediate value */
10509 pointer q,r; /* for list manipulation */
10510 q=link(p); r=mp_get_node(mp, knot_node_size); link(p)=r; link(r)=q;
10511 originator(r)=mp_program_code;
10512 left_type(r)=mp_explicit; right_type(r)=mp_explicit;
10513 v=t_of_the_way(right_x(p),left_x(q));
10514 right_x(p)=t_of_the_way(x_coord(p),right_x(p));
10515 left_x(q)=t_of_the_way(left_x(q),x_coord(q));
10516 left_x(r)=t_of_the_way(right_x(p),v);
10517 right_x(r)=t_of_the_way(v,left_x(q));
10518 x_coord(r)=t_of_the_way(left_x(r),right_x(r));
10519 v=t_of_the_way(right_y(p),left_y(q));
10520 right_y(p)=t_of_the_way(y_coord(p),right_y(p));
10521 left_y(q)=t_of_the_way(left_y(q),y_coord(q));
10522 left_y(r)=t_of_the_way(right_y(p),v);
10523 right_y(r)=t_of_the_way(v,left_y(q));
10524 y_coord(r)=t_of_the_way(left_y(r),right_y(r));
10527 @ This does not set |info(p)| or |right_type(p)|.
10529 @<Declare subroutines needed by |offset_prep|@>=
10530 void mp_remove_cubic (MP mp,pointer p) { /* removes the dead cubic following~|p| */
10531 pointer q; /* the node that disappears */
10532 q=link(p); link(p)=link(q);
10533 right_x(p)=right_x(q); right_y(p)=right_y(q);
10534 mp_free_node(mp, q,knot_node_size);
10537 @ Let $d\prec d'$ mean that the counter-clockwise angle from $d$ to~$d'$ is
10538 strictly between zero and $180^\circ$. Then we can define $d\preceq d'$ to
10539 mean that the angle could be zero or $180^\circ$. If $w_k=(u_k,v_k)$ is the
10540 $k$th pen offset, the $k$th pen edge direction is defined by the formula
10541 $$d_k=(u\k-u_k,\,v\k-v_k).$$
10542 When listed by increasing $k$, these directions occur in counter-clockwise
10543 order so that $d_k\preceq d\k$ for all~$k$.
10544 The goal of |offset_prep| is to find an offset index~|k| to associate with
10545 each cubic, such that the direction $d(t)$ of the cubic satisfies
10546 $$d_{k-1}\preceq d(t)\preceq d_k\qquad\hbox{for $0\le t\le 1$.}\eqno(*)$$
10547 We may have to split a cubic into many pieces before each
10548 piece corresponds to a unique offset.
10550 @<Split the cubic between |p| and |q|, if necessary, into cubics...@>=
10551 info(p)=zero_off+k_needed;
10553 @<Prepare for derivative computations;
10554 |goto not_found| if the current cubic is dead@>;
10555 @<Find the initial direction |(dx,dy)|@>;
10556 @<Update |info(p)| and find the offset $w_k$ such that
10557 $d_{k-1}\preceq(\\{dx},\\{dy})\prec d_k$; also advance |w0| for
10558 the direction change at |p|@>;
10559 @<Find the final direction |(dxin,dyin)|@>;
10560 @<Decide on the net change in pen offsets and set |turn_amt|@>;
10561 @<Complete the offset splitting process@>;
10562 w0=mp_pen_walk(mp, w0,turn_amt)
10564 @ @<Declare subroutines needed by |offset_prep|@>=
10565 pointer mp_pen_walk (MP mp,pointer w, integer k) {
10566 /* walk |k| steps around a pen from |w| */
10567 while ( k>0 ) { w=link(w); decr(k); };
10568 while ( k<0 ) { w=knil(w); incr(k); };
10572 @ The direction of a cubic $B(z_0,z_1,z_2,z_3;t)=\bigl(x(t),y(t)\bigr)$ can be
10573 calculated from the quadratic polynomials
10574 ${1\over3}x'(t)=B(x_1-x_0,x_2-x_1,x_3-x_2;t)$ and
10575 ${1\over3}y'(t)=B(y_1-y_0,y_2-y_1,y_3-y_2;t)$.
10576 Since we may be calculating directions from several cubics
10577 split from the current one, it is desirable to do these calculations
10578 without losing too much precision. ``Scaled up'' values of the
10579 derivatives, which will be less tainted by accumulated errors than
10580 derivatives found from the cubics themselves, are maintained in
10581 local variables |x0|, |x1|, and |x2|, representing $X_0=2^l(x_1-x_0)$,
10582 $X_1=2^l(x_2-x_1)$, and $X_2=2^l(x_3-x_2)$; similarly |y0|, |y1|, and~|y2|
10583 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)$.
10585 @<Other local variables for |offset_prep|@>=
10586 integer x0,x1,x2,y0,y1,y2; /* representatives of derivatives */
10587 integer t0,t1,t2; /* coefficients of polynomial for slope testing */
10588 integer du,dv,dx,dy; /* for directions of the pen and the curve */
10589 integer dx0,dy0; /* initial direction for the first cubic in the curve */
10590 integer max_coef; /* used while scaling */
10591 integer x0a,x1a,x2a,y0a,y1a,y2a; /* intermediate values */
10592 fraction t; /* where the derivative passes through zero */
10593 fraction s; /* a temporary value */
10595 @ @<Prepare for derivative computations...@>=
10596 x0=right_x(p)-x_coord(p);
10597 x2=x_coord(q)-left_x(q);
10598 x1=left_x(q)-right_x(p);
10599 y0=right_y(p)-y_coord(p); y2=y_coord(q)-left_y(q);
10600 y1=left_y(q)-right_y(p);
10602 if ( abs(x1)>max_coef ) max_coef=abs(x1);
10603 if ( abs(x2)>max_coef ) max_coef=abs(x2);
10604 if ( abs(y0)>max_coef ) max_coef=abs(y0);
10605 if ( abs(y1)>max_coef ) max_coef=abs(y1);
10606 if ( abs(y2)>max_coef ) max_coef=abs(y2);
10607 if ( max_coef==0 ) goto NOT_FOUND;
10608 while ( max_coef<fraction_half ) {
10610 double(x0); double(x1); double(x2);
10611 double(y0); double(y1); double(y2);
10614 @ Let us first solve a special case of the problem: Suppose we
10615 know an index~$k$ such that either (i)~$d(t)\succeq d_{k-1}$ for all~$t$
10616 and $d(0)\prec d_k$, or (ii)~$d(t)\preceq d_k$ for all~$t$ and
10617 $d(0)\succ d_{k-1}$.
10618 Then, in a sense, we're halfway done, since one of the two relations
10619 in $(*)$ is satisfied, and the other couldn't be satisfied for
10620 any other value of~|k|.
10622 Actually, the conditions can be relaxed somewhat since a relation such as
10623 $d(t)\succeq d_{k-1}$ restricts $d(t)$ to a half plane when all that really
10624 matters is whether $d(t)$ crosses the ray in the $d_{k-1}$ direction from
10625 the origin. The condition for case~(i) becomes $d_{k-1}\preceq d(0)\prec d_k$
10626 and $d(t)$ never crosses the $d_{k-1}$ ray in the clockwise direction.
10627 Case~(ii) is similar except $d(t)$ cannot cross the $d_k$ ray in the
10628 counterclockwise direction.
10630 The |fin_offset_prep| subroutine solves the stated subproblem.
10631 It has a parameter called |rise| that is |1| in
10632 case~(i), |-1| in case~(ii). Parameters |x0| through |y2| represent
10633 the derivative of the cubic following |p|.
10634 The |w| parameter should point to offset~$w_k$ and |info(p)| should already
10635 be set properly. The |turn_amt| parameter gives the absolute value of the
10636 overall net change in pen offsets.
10638 @<Declare subroutines needed by |offset_prep|@>=
10639 void mp_fin_offset_prep (MP mp,pointer p, pointer w, integer
10640 x0,integer x1, integer x2, integer y0, integer y1, integer y2,
10641 integer rise, integer turn_amt) {
10642 pointer ww; /* for list manipulation */
10643 scaled du,dv; /* for slope calculation */
10644 integer t0,t1,t2; /* test coefficients */
10645 fraction t; /* place where the derivative passes a critical slope */
10646 fraction s; /* slope or reciprocal slope */
10647 integer v; /* intermediate value for updating |x0..y2| */
10648 pointer q; /* original |link(p)| */
10651 if ( rise>0 ) ww=link(w); /* a pointer to $w\k$ */
10652 else ww=knil(w); /* a pointer to $w_{k-1}$ */
10653 @<Compute test coefficients |(t0,t1,t2)|
10654 for $d(t)$ versus $d_k$ or $d_{k-1}$@>;
10655 t=mp_crossing_point(mp, t0,t1,t2);
10656 if ( t>=fraction_one ) {
10657 if ( turn_amt>0 ) t=fraction_one; else return;
10659 @<Split the cubic at $t$,
10660 and split off another cubic if the derivative crosses back@>;
10665 @ We want $B(\\{t0},\\{t1},\\{t2};t)$ to be the dot product of $d(t)$ with a
10666 $-90^\circ$ rotation of the vector from |w| to |ww|. This makes the resulting
10667 function cross from positive to negative when $d_{k-1}\preceq d(t)\preceq d_k$
10670 @<Compute test coefficients |(t0,t1,t2)| for $d(t)$ versus...@>=
10671 du=x_coord(ww)-x_coord(w); dv=y_coord(ww)-y_coord(w);
10672 if ( abs(du)>=abs(dv) ) {
10673 s=mp_make_fraction(mp, dv,du);
10674 t0=mp_take_fraction(mp, x0,s)-y0;
10675 t1=mp_take_fraction(mp, x1,s)-y1;
10676 t2=mp_take_fraction(mp, x2,s)-y2;
10677 if ( du<0 ) { negate(t0); negate(t1); negate(t2); }
10679 s=mp_make_fraction(mp, du,dv);
10680 t0=x0-mp_take_fraction(mp, y0,s);
10681 t1=x1-mp_take_fraction(mp, y1,s);
10682 t2=x2-mp_take_fraction(mp, y2,s);
10683 if ( dv<0 ) { negate(t0); negate(t1); negate(t2); }
10685 if ( t0<0 ) t0=0 /* should be positive without rounding error */
10687 @ The curve has crossed $d_k$ or $d_{k-1}$; its initial segment satisfies
10688 $(*)$, and it might cross again and return towards $s_{k-1}$ or $s_k$,
10689 respectively, yielding another solution of $(*)$.
10691 @<Split the cubic at $t$, and split off another...@>=
10693 mp_split_cubic(mp, p,t); p=link(p); info(p)=zero_off+rise;
10695 v=t_of_the_way(x0,x1); x1=t_of_the_way(x1,x2);
10696 x0=t_of_the_way(v,x1);
10697 v=t_of_the_way(y0,y1); y1=t_of_the_way(y1,y2);
10698 y0=t_of_the_way(v,y1);
10699 if ( turn_amt<0 ) {
10700 t1=t_of_the_way(t1,t2);
10701 if ( t1>0 ) t1=0; /* without rounding error, |t1| would be |<=0| */
10702 t=mp_crossing_point(mp, 0,-t1,-t2);
10703 if ( t>fraction_one ) t=fraction_one;
10705 if ( (t==fraction_one)&&(link(p)!=q) ) {
10706 info(link(p))=info(link(p))-rise;
10708 mp_split_cubic(mp, p,t); info(link(p))=zero_off-rise;
10709 v=t_of_the_way(x1,x2); x1=t_of_the_way(x0,x1);
10710 x2=t_of_the_way(x1,v);
10711 v=t_of_the_way(y1,y2); y1=t_of_the_way(y0,y1);
10712 y2=t_of_the_way(y1,v);
10717 @ Now we must consider the general problem of |offset_prep|, when
10718 nothing is known about a given cubic. We start by finding its
10719 direction in the vicinity of |t=0|.
10721 If $z'(t)=0$, the given cubic is numerically unstable but |offset_prep|
10722 has not yet introduced any more numerical errors. Thus we can compute
10723 the true initial direction for the given cubic, even if it is almost
10726 @<Find the initial direction |(dx,dy)|@>=
10728 if ( dx==0 && dy==0 ) {
10730 if ( dx==0 && dy==0 ) {
10734 if ( p==c ) { dx0=dx; dy0=dy; }
10736 @ @<Find the final direction |(dxin,dyin)|@>=
10738 if ( dxin==0 && dyin==0 ) {
10740 if ( dxin==0 && dyin==0 ) {
10745 @ The next step is to bracket the initial direction between consecutive
10746 edges of the pen polygon. We must be careful to turn clockwise only if
10747 this makes the turn less than $180^\circ$. (A $180^\circ$ turn must be
10748 counter-clockwise in order to make \&{doublepath} envelopes come out
10749 @:double_path_}{\&{doublepath} primitive@>
10750 right.) This code depends on |w0| being the offset for |(dxin,dyin)|.
10752 @<Update |info(p)| and find the offset $w_k$ such that...@>=
10753 turn_amt=mp_get_turn_amt(mp,w0,dx,dy,(mp_ab_vs_cd(mp, dy,dxin,dx,dyin)>=0));
10754 w=mp_pen_walk(mp, w0, turn_amt);
10756 info(p)=info(p)+turn_amt
10758 @ Decide how many pen offsets to go away from |w| in order to find the offset
10759 for |(dx,dy)|, going counterclockwise if |ccw| is |true|. This assumes that
10760 |w| is the offset for some direction $(x',y')$ from which the angle to |(dx,dy)|
10761 in the sense determined by |ccw| is less than or equal to $180^\circ$.
10763 If the pen polygon has only two edges, they could both be parallel
10764 to |(dx,dy)|. In this case, we must be careful to stop after crossing the first
10765 such edge in order to avoid an infinite loop.
10767 @<Declare subroutines needed by |offset_prep|@>=
10768 integer mp_get_turn_amt (MP mp,pointer w, scaled dx,
10769 scaled dy, boolean ccw) {
10770 pointer ww; /* a neighbor of knot~|w| */
10771 integer s; /* turn amount so far */
10772 integer t; /* |ab_vs_cd| result */
10777 t=mp_ab_vs_cd(mp, dy,(x_coord(ww)-x_coord(w)),
10778 dx,(y_coord(ww)-y_coord(w)));
10785 while ( mp_ab_vs_cd(mp, dy,(x_coord(w)-x_coord(ww)),
10786 dx,(y_coord(w)-y_coord(ww))) < 0) {
10794 @ When we're all done, the final offset is |w0| and the final curve direction
10795 is |(dxin,dyin)|. With this knowledge of the incoming direction at |c|, we
10796 can correct |info(c)| which was erroneously based on an incoming offset
10799 @d fix_by(A) info(c)=info(c)+(A)
10801 @<Fix the offset change in |info(c)| and set |c| to the return value of...@>=
10802 mp->spec_offset=info(c)-zero_off;
10803 if ( link(c)==c ) {
10804 info(c)=zero_off+n;
10807 while ( w0!=h ) { fix_by(1); w0=link(w0); };
10808 while ( info(c)<=zero_off-n ) fix_by(n);
10809 while ( info(c)>zero_off ) fix_by(-n);
10810 if ( (info(c)!=zero_off)&&(mp_ab_vs_cd(mp, dy0,dxin,dx0,dyin)>=0) ) fix_by(n);
10813 @ Finally we want to reduce the general problem to situations that
10814 |fin_offset_prep| can handle. We split the cubic into at most three parts
10815 with respect to $d_{k-1}$, and apply |fin_offset_prep| to each part.
10817 @<Complete the offset splitting process@>=
10819 @<Compute test coeff...@>;
10820 @<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set
10821 |t:=fraction_one+1|@>;
10822 if ( t>fraction_one ) {
10823 mp_fin_offset_prep(mp, p,w,x0,x1,x2,y0,y1,y2,1,turn_amt);
10825 mp_split_cubic(mp, p,t); r=link(p);
10826 x1a=t_of_the_way(x0,x1); x1=t_of_the_way(x1,x2);
10827 x2a=t_of_the_way(x1a,x1);
10828 y1a=t_of_the_way(y0,y1); y1=t_of_the_way(y1,y2);
10829 y2a=t_of_the_way(y1a,y1);
10830 mp_fin_offset_prep(mp, p,w,x0,x1a,x2a,y0,y1a,y2a,1,0); x0=x2a; y0=y2a;
10831 info(r)=zero_off-1;
10832 if ( turn_amt>=0 ) {
10833 t1=t_of_the_way(t1,t2);
10835 t=mp_crossing_point(mp, 0,-t1,-t2);
10836 if ( t>fraction_one ) t=fraction_one;
10837 @<Split off another rising cubic for |fin_offset_prep|@>;
10838 mp_fin_offset_prep(mp, r,ww,x0,x1,x2,y0,y1,y2,-1,0);
10840 mp_fin_offset_prep(mp, r,ww,x0,x1,x2,y0,y1,y2,-1,(-1-turn_amt));
10844 @ @<Split off another rising cubic for |fin_offset_prep|@>=
10845 mp_split_cubic(mp, r,t); info(link(r))=zero_off+1;
10846 x1a=t_of_the_way(x1,x2); x1=t_of_the_way(x0,x1);
10847 x0a=t_of_the_way(x1,x1a);
10848 y1a=t_of_the_way(y1,y2); y1=t_of_the_way(y0,y1);
10849 y0a=t_of_the_way(y1,y1a);
10850 mp_fin_offset_prep(mp, link(r),w,x0a,x1a,x2,y0a,y1a,y2,1,turn_amt);
10853 @ At this point, the direction of the incoming pen edge is |(-du,-dv)|.
10854 When the component of $d(t)$ perpendicular to |(-du,-dv)| crosses zero, we
10855 need to decide whether the directions are parallel or antiparallel. We
10856 can test this by finding the dot product of $d(t)$ and |(-du,-dv)|, but this
10857 should be avoided when the value of |turn_amt| already determines the
10858 answer. If |t2<0|, there is one crossing and it is antiparallel only if
10859 |turn_amt>=0|. If |turn_amt<0|, there should always be at least one
10860 crossing and the first crossing cannot be antiparallel.
10862 @<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set...@>=
10863 t=mp_crossing_point(mp, t0,t1,t2);
10864 if ( turn_amt>=0 ) {
10868 u0=t_of_the_way(x0,x1);
10869 u1=t_of_the_way(x1,x2);
10870 ss=mp_take_fraction(mp, -du,t_of_the_way(u0,u1));
10871 v0=t_of_the_way(y0,y1);
10872 v1=t_of_the_way(y1,y2);
10873 ss=ss+mp_take_fraction(mp, -dv,t_of_the_way(v0,v1));
10874 if ( ss<0 ) t=fraction_one+1;
10876 } else if ( t>fraction_one ) {
10880 @ @<Other local variables for |offset_prep|@>=
10881 integer u0,u1,v0,v1; /* intermediate values for $d(t)$ calculation */
10882 integer ss = 0; /* the part of the dot product computed so far */
10883 int d_sign; /* sign of overall change in direction for this cubic */
10885 @ If the cubic almost has a cusp, it is a numerically ill-conditioned
10886 problem to decide which way it loops around but that's OK as long we're
10887 consistent. To make \&{doublepath} envelopes work properly, reversing
10888 the path should always change the sign of |turn_amt|.
10890 @<Decide on the net change in pen offsets and set |turn_amt|@>=
10891 d_sign=mp_ab_vs_cd(mp, dx,dyin, dxin,dy);
10893 @<Check rotation direction based on node position@>
10897 if ( dy>0 ) d_sign=1; else d_sign=-1;
10899 if ( dx>0 ) d_sign=1; else d_sign=-1;
10902 @<Make |ss| negative if and only if the total change in direction is
10903 more than $180^\circ$@>;
10904 turn_amt=mp_get_turn_amt(mp, w, dxin, dyin, (d_sign>0));
10905 if ( ss<0 ) turn_amt=turn_amt-d_sign*n
10907 @ We check rotation direction by looking at the vector connecting the current
10908 node with the next. If its angle with incoming and outgoing tangents has the
10909 same sign, we pick this as |d_sign|, since it means we have a flex, not a cusp.
10910 Otherwise we proceed to the cusp code.
10912 @<Check rotation direction based on node position@>=
10913 u0=x_coord(q)-x_coord(p);
10914 u1=y_coord(q)-y_coord(p);
10915 d_sign = half(mp_ab_vs_cd(mp, dx, u1, u0, dy)+
10916 mp_ab_vs_cd(mp, u0, dyin, dxin, u1));
10918 @ In order to be invariant under path reversal, the result of this computation
10919 should not change when |x0|, |y0|, $\ldots$ are all negated and |(x0,y0)| is
10920 then swapped with |(x2,y2)|. We make use of the identities
10921 |take_fraction(-a,-b)=take_fraction(a,b)| and
10922 |t_of_the_way(-a,-b)=-(t_of_the_way(a,b))|.
10924 @<Make |ss| negative if and only if the total change in direction is...@>=
10925 t0=half(mp_take_fraction(mp, x0,y2))-half(mp_take_fraction(mp, x2,y0));
10926 t1=half(mp_take_fraction(mp, x1,(y0+y2)))-half(mp_take_fraction(mp, y1,(x0+x2)));
10927 if ( t0==0 ) t0=d_sign; /* path reversal always negates |d_sign| */
10929 t=mp_crossing_point(mp, t0,t1,-t0);
10930 u0=t_of_the_way(x0,x1);
10931 u1=t_of_the_way(x1,x2);
10932 v0=t_of_the_way(y0,y1);
10933 v1=t_of_the_way(y1,y2);
10935 t=mp_crossing_point(mp, -t0,t1,t0);
10936 u0=t_of_the_way(x2,x1);
10937 u1=t_of_the_way(x1,x0);
10938 v0=t_of_the_way(y2,y1);
10939 v1=t_of_the_way(y1,y0);
10941 ss=mp_take_fraction(mp, (x0+x2),t_of_the_way(u0,u1))+
10942 mp_take_fraction(mp, (y0+y2),t_of_the_way(v0,v1))
10944 @ Here's a routine that prints an envelope spec in symbolic form. It assumes
10945 that the |cur_pen| has not been walked around to the first offset.
10948 void mp_print_spec (MP mp,pointer cur_spec, pointer cur_pen, const char *s) {
10949 pointer p,q; /* list traversal */
10950 pointer w; /* the current pen offset */
10951 mp_print_diagnostic(mp, "Envelope spec",s,true);
10952 p=cur_spec; w=mp_pen_walk(mp, cur_pen,mp->spec_offset);
10954 mp_print_two(mp, x_coord(cur_spec),y_coord(cur_spec));
10955 mp_print(mp, " % beginning with offset ");
10956 mp_print_two(mp, x_coord(w),y_coord(w));
10960 @<Print the cubic between |p| and |q|@>;
10962 if ((p==cur_spec) || (info(p)!=zero_off))
10965 if ( info(p)!=zero_off ) {
10966 @<Update |w| as indicated by |info(p)| and print an explanation@>;
10968 } while (p!=cur_spec);
10969 mp_print_nl(mp, " & cycle");
10970 mp_end_diagnostic(mp, true);
10973 @ @<Update |w| as indicated by |info(p)| and print an explanation@>=
10975 w=mp_pen_walk(mp, w, (info(p)-zero_off));
10976 mp_print(mp, " % ");
10977 if ( info(p)>zero_off ) mp_print(mp, "counter");
10978 mp_print(mp, "clockwise to offset ");
10979 mp_print_two(mp, x_coord(w),y_coord(w));
10982 @ @<Print the cubic between |p| and |q|@>=
10984 mp_print_nl(mp, " ..controls ");
10985 mp_print_two(mp, right_x(p),right_y(p));
10986 mp_print(mp, " and ");
10987 mp_print_two(mp, left_x(q),left_y(q));
10988 mp_print_nl(mp, " ..");
10989 mp_print_two(mp, x_coord(q),y_coord(q));
10992 @ Once we have an envelope spec, the remaining task to construct the actual
10993 envelope by offsetting each cubic as determined by the |info| fields in
10994 the knots. First we use |offset_prep| to convert the |c| into an envelope
10995 spec. Then we add the offsets so that |c| becomes a cyclic path that represents
10998 The |ljoin| and |miterlim| parameters control the treatment of points where the
10999 pen offset changes, and |lcap| controls the endpoints of a \&{doublepath}.
11000 The endpoints are easily located because |c| is given in undoubled form
11001 and then doubled in this procedure. We use |spec_p1| and |spec_p2| to keep
11002 track of the endpoints and treat them like very sharp corners.
11003 Butt end caps are treated like beveled joins; round end caps are treated like
11004 round joins; and square end caps are achieved by setting |join_type:=3|.
11006 None of these parameters apply to inside joins where the convolution tracing
11007 has retrograde lines. In such cases we use a simple connect-the-endpoints
11008 approach that is achieved by setting |join_type:=2|.
11010 @c @<Declare a function called |insert_knot|@>
11011 pointer mp_make_envelope (MP mp,pointer c, pointer h, small_number ljoin,
11012 small_number lcap, scaled miterlim) {
11013 pointer p,q,r,q0; /* for manipulating the path */
11014 int join_type=0; /* codes |0..3| for mitered, round, beveled, or square */
11015 pointer w,w0; /* the pen knot for the current offset */
11016 scaled qx,qy; /* unshifted coordinates of |q| */
11017 halfword k,k0; /* controls pen edge insertion */
11018 @<Other local variables for |make_envelope|@>;
11019 dxin=0; dyin=0; dxout=0; dyout=0;
11020 mp->spec_p1=null; mp->spec_p2=null;
11021 @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>;
11022 @<Use |offset_prep| to compute the envelope spec then walk |h| around to
11023 the initial offset@>;
11028 qx=x_coord(q); qy=y_coord(q);
11031 if ( k!=zero_off ) {
11032 @<Set |join_type| to indicate how to handle offset changes at~|q|@>;
11034 @<Add offset |w| to the cubic from |p| to |q|@>;
11035 while ( k!=zero_off ) {
11036 @<Step |w| and move |k| one step closer to |zero_off|@>;
11037 if ( (join_type==1)||(k==zero_off) )
11038 q=mp_insert_knot(mp, q,qx+x_coord(w),qy+y_coord(w));
11040 if ( q!=link(p) ) {
11041 @<Set |p=link(p)| and add knots between |p| and |q| as
11042 required by |join_type|@>;
11049 @ @<Use |offset_prep| to compute the envelope spec then walk |h| around to...@>=
11050 c=mp_offset_prep(mp, c,h);
11051 if ( mp->internal[mp_tracing_specs]>0 )
11052 mp_print_spec(mp, c,h,"");
11053 h=mp_pen_walk(mp, h,mp->spec_offset)
11055 @ Mitered and squared-off joins depend on path directions that are difficult to
11056 compute for degenerate cubics. The envelope spec computed by |offset_prep| can
11057 have degenerate cubics only if the entire cycle collapses to a single
11058 degenerate cubic. Setting |join_type:=2| in this case makes the computed
11059 envelope degenerate as well.
11061 @<Set |join_type| to indicate how to handle offset changes at~|q|@>=
11062 if ( k<zero_off ) {
11065 if ( (q!=mp->spec_p1)&&(q!=mp->spec_p2) ) join_type=ljoin;
11066 else if ( lcap==2 ) join_type=3;
11067 else join_type=2-lcap;
11068 if ( (join_type==0)||(join_type==3) ) {
11069 @<Set the incoming and outgoing directions at |q|; in case of
11070 degeneracy set |join_type:=2|@>;
11071 if ( join_type==0 ) {
11072 @<If |miterlim| is less than the secant of half the angle at |q|
11073 then set |join_type:=2|@>;
11078 @ @<If |miterlim| is less than the secant of half the angle at |q|...@>=
11080 tmp=mp_take_fraction(mp, miterlim,fraction_half+
11081 half(mp_take_fraction(mp, dxin,dxout)+mp_take_fraction(mp, dyin,dyout)));
11083 if ( mp_take_scaled(mp, miterlim,tmp)<unity ) join_type=2;
11086 @ @<Other local variables for |make_envelope|@>=
11087 fraction dxin,dyin,dxout,dyout; /* directions at |q| when square or mitered */
11088 scaled tmp; /* a temporary value */
11090 @ The coordinates of |p| have already been shifted unless |p| is the first
11091 knot in which case they get shifted at the very end.
11093 @<Add offset |w| to the cubic from |p| to |q|@>=
11094 right_x(p)=right_x(p)+x_coord(w);
11095 right_y(p)=right_y(p)+y_coord(w);
11096 left_x(q)=left_x(q)+x_coord(w);
11097 left_y(q)=left_y(q)+y_coord(w);
11098 x_coord(q)=x_coord(q)+x_coord(w);
11099 y_coord(q)=y_coord(q)+y_coord(w);
11100 left_type(q)=mp_explicit;
11101 right_type(q)=mp_explicit
11103 @ @<Step |w| and move |k| one step closer to |zero_off|@>=
11104 if ( k>zero_off ){ w=link(w); decr(k); }
11105 else { w=knil(w); incr(k); }
11107 @ The cubic from |q| to the new knot at |(x,y)| becomes a line segment and
11108 the |right_x| and |right_y| fields of |r| are set from |q|. This is done in
11109 case the cubic containing these control points is ``yet to be examined.''
11111 @<Declare a function called |insert_knot|@>=
11112 pointer mp_insert_knot (MP mp,pointer q, scaled x, scaled y) {
11113 /* returns the inserted knot */
11114 pointer r; /* the new knot */
11115 r=mp_get_node(mp, knot_node_size);
11116 link(r)=link(q); link(q)=r;
11117 right_x(r)=right_x(q);
11118 right_y(r)=right_y(q);
11121 right_x(q)=x_coord(q);
11122 right_y(q)=y_coord(q);
11123 left_x(r)=x_coord(r);
11124 left_y(r)=y_coord(r);
11125 left_type(r)=mp_explicit;
11126 right_type(r)=mp_explicit;
11127 originator(r)=mp_program_code;
11131 @ After setting |p:=link(p)|, either |join_type=1| or |q=link(p)|.
11133 @<Set |p=link(p)| and add knots between |p| and |q| as...@>=
11136 if ( (join_type==0)||(join_type==3) ) {
11137 if ( join_type==0 ) {
11138 @<Insert a new knot |r| between |p| and |q| as required for a mitered join@>
11140 @<Make |r| the last of two knots inserted between |p| and |q| to form a
11144 right_x(r)=x_coord(r);
11145 right_y(r)=y_coord(r);
11150 @ For very small angles, adding a knot is unnecessary and would cause numerical
11151 problems, so we just set |r:=null| in that case.
11153 @<Insert a new knot |r| between |p| and |q| as required for a mitered join@>=
11155 det=mp_take_fraction(mp, dyout,dxin)-mp_take_fraction(mp, dxout,dyin);
11156 if ( abs(det)<26844 ) {
11157 r=null; /* sine $<10^{-4}$ */
11159 tmp=mp_take_fraction(mp, x_coord(q)-x_coord(p),dyout)-
11160 mp_take_fraction(mp, y_coord(q)-y_coord(p),dxout);
11161 tmp=mp_make_fraction(mp, tmp,det);
11162 r=mp_insert_knot(mp, p,x_coord(p)+mp_take_fraction(mp, tmp,dxin),
11163 y_coord(p)+mp_take_fraction(mp, tmp,dyin));
11167 @ @<Other local variables for |make_envelope|@>=
11168 fraction det; /* a determinant used for mitered join calculations */
11170 @ @<Make |r| the last of two knots inserted between |p| and |q| to form a...@>=
11172 ht_x=y_coord(w)-y_coord(w0);
11173 ht_y=x_coord(w0)-x_coord(w);
11174 while ( (abs(ht_x)<fraction_half)&&(abs(ht_y)<fraction_half) ) {
11175 ht_x+=ht_x; ht_y+=ht_y;
11177 @<Scan the pen polygon between |w0| and |w| and make |max_ht| the range dot
11178 product with |(ht_x,ht_y)|@>;
11179 tmp=mp_make_fraction(mp, max_ht,mp_take_fraction(mp, dxin,ht_x)+
11180 mp_take_fraction(mp, dyin,ht_y));
11181 r=mp_insert_knot(mp, p,x_coord(p)+mp_take_fraction(mp, tmp,dxin),
11182 y_coord(p)+mp_take_fraction(mp, tmp,dyin));
11183 tmp=mp_make_fraction(mp, max_ht,mp_take_fraction(mp, dxout,ht_x)+
11184 mp_take_fraction(mp, dyout,ht_y));
11185 r=mp_insert_knot(mp, r,x_coord(q)+mp_take_fraction(mp, tmp,dxout),
11186 y_coord(q)+mp_take_fraction(mp, tmp,dyout));
11189 @ @<Other local variables for |make_envelope|@>=
11190 fraction ht_x,ht_y; /* perpendicular to the segment from |p| to |q| */
11191 scaled max_ht; /* maximum height of the pen polygon above the |w0|-|w| line */
11192 halfword kk; /* keeps track of the pen vertices being scanned */
11193 pointer ww; /* the pen vertex being tested */
11195 @ The dot product of the vector from |w0| to |ww| with |(ht_x,ht_y)| ranges
11196 from zero to |max_ht|.
11198 @<Scan the pen polygon between |w0| and |w| and make |max_ht| the range...@>=
11203 @<Step |ww| and move |kk| one step closer to |k0|@>;
11204 if ( kk==k0 ) break;
11205 tmp=mp_take_fraction(mp, (x_coord(ww)-x_coord(w0)),ht_x)+
11206 mp_take_fraction(mp, (y_coord(ww)-y_coord(w0)),ht_y);
11207 if ( tmp>max_ht ) max_ht=tmp;
11211 @ @<Step |ww| and move |kk| one step closer to |k0|@>=
11212 if ( kk>k0 ) { ww=link(ww); decr(kk); }
11213 else { ww=knil(ww); incr(kk); }
11215 @ @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>=
11216 if ( left_type(c)==mp_endpoint ) {
11217 mp->spec_p1=mp_htap_ypoc(mp, c);
11218 mp->spec_p2=mp->path_tail;
11219 originator(mp->spec_p1)=mp_program_code;
11220 link(mp->spec_p2)=link(mp->spec_p1);
11221 link(mp->spec_p1)=c;
11222 mp_remove_cubic(mp, mp->spec_p1);
11224 if ( c!=link(c) ) {
11225 originator(mp->spec_p2)=mp_program_code;
11226 mp_remove_cubic(mp, mp->spec_p2);
11228 @<Make |c| look like a cycle of length one@>;
11232 @ @<Make |c| look like a cycle of length one@>=
11234 left_type(c)=mp_explicit; right_type(c)=mp_explicit;
11235 left_x(c)=x_coord(c); left_y(c)=y_coord(c);
11236 right_x(c)=x_coord(c); right_y(c)=y_coord(c);
11239 @ In degenerate situations we might have to look at the knot preceding~|q|.
11240 That knot is |p| but if |p<>c|, its coordinates have already been offset by |w|.
11242 @<Set the incoming and outgoing directions at |q|; in case of...@>=
11243 dxin=x_coord(q)-left_x(q);
11244 dyin=y_coord(q)-left_y(q);
11245 if ( (dxin==0)&&(dyin==0) ) {
11246 dxin=x_coord(q)-right_x(p);
11247 dyin=y_coord(q)-right_y(p);
11248 if ( (dxin==0)&&(dyin==0) ) {
11249 dxin=x_coord(q)-x_coord(p);
11250 dyin=y_coord(q)-y_coord(p);
11251 if ( p!=c ) { /* the coordinates of |p| have been offset by |w| */
11252 dxin=dxin+x_coord(w);
11253 dyin=dyin+y_coord(w);
11257 tmp=mp_pyth_add(mp, dxin,dyin);
11261 dxin=mp_make_fraction(mp, dxin,tmp);
11262 dyin=mp_make_fraction(mp, dyin,tmp);
11263 @<Set the outgoing direction at |q|@>;
11266 @ If |q=c| then the coordinates of |r| and the control points between |q|
11267 and~|r| have already been offset by |h|.
11269 @<Set the outgoing direction at |q|@>=
11270 dxout=right_x(q)-x_coord(q);
11271 dyout=right_y(q)-y_coord(q);
11272 if ( (dxout==0)&&(dyout==0) ) {
11274 dxout=left_x(r)-x_coord(q);
11275 dyout=left_y(r)-y_coord(q);
11276 if ( (dxout==0)&&(dyout==0) ) {
11277 dxout=x_coord(r)-x_coord(q);
11278 dyout=y_coord(r)-y_coord(q);
11282 dxout=dxout-x_coord(h);
11283 dyout=dyout-y_coord(h);
11285 tmp=mp_pyth_add(mp, dxout,dyout);
11286 if ( tmp==0 ) mp_confusion(mp, "degenerate spec");
11287 @:this can't happen degerate spec}{\quad degenerate spec@>
11288 dxout=mp_make_fraction(mp, dxout,tmp);
11289 dyout=mp_make_fraction(mp, dyout,tmp)
11291 @* \[23] Direction and intersection times.
11292 A path of length $n$ is defined parametrically by functions $x(t)$ and
11293 $y(t)$, for |0<=t<=n|; we can regard $t$ as the ``time'' at which the path
11294 reaches the point $\bigl(x(t),y(t)\bigr)$. In this section of the program
11295 we shall consider operations that determine special times associated with
11296 given paths: the first time that a path travels in a given direction, and
11297 a pair of times at which two paths cross each other.
11299 @ Let's start with the easier task. The function |find_direction_time| is
11300 given a direction |(x,y)| and a path starting at~|h|. If the path never
11301 travels in direction |(x,y)|, the direction time will be~|-1|; otherwise
11302 it will be nonnegative.
11304 Certain anomalous cases can arise: If |(x,y)=(0,0)|, so that the given
11305 direction is undefined, the direction time will be~0. If $\bigl(x'(t),
11306 y'(t)\bigr)=(0,0)$, so that the path direction is undefined, it will be
11307 assumed to match any given direction at time~|t|.
11309 The routine solves this problem in nondegenerate cases by rotating the path
11310 and the given direction so that |(x,y)=(1,0)|; i.e., the main task will be
11311 to find when a given path first travels ``due east.''
11314 scaled mp_find_direction_time (MP mp,scaled x, scaled y, pointer h) {
11315 scaled max; /* $\max\bigl(\vert x\vert,\vert y\vert\bigr)$ */
11316 pointer p,q; /* for list traversal */
11317 scaled n; /* the direction time at knot |p| */
11318 scaled tt; /* the direction time within a cubic */
11319 @<Other local variables for |find_direction_time|@>;
11320 @<Normalize the given direction for better accuracy;
11321 but |return| with zero result if it's zero@>;
11324 if ( right_type(p)==mp_endpoint ) break;
11326 @<Rotate the cubic between |p| and |q|; then
11327 |goto found| if the rotated cubic travels due east at some time |tt|;
11328 but |break| if an entire cyclic path has been traversed@>;
11336 @ @<Normalize the given direction for better accuracy...@>=
11337 if ( abs(x)<abs(y) ) {
11338 x=mp_make_fraction(mp, x,abs(y));
11339 if ( y>0 ) y=fraction_one; else y=-fraction_one;
11340 } else if ( x==0 ) {
11343 y=mp_make_fraction(mp, y,abs(x));
11344 if ( x>0 ) x=fraction_one; else x=-fraction_one;
11347 @ Since we're interested in the tangent directions, we work with the
11348 derivative $${1\over3}B'(x_0,x_1,x_2,x_3;t)=
11349 B(x_1-x_0,x_2-x_1,x_3-x_2;t)$$ instead of
11350 $B(x_0,x_1,x_2,x_3;t)$ itself. The derived coefficients are also scaled up
11351 in order to achieve better accuracy.
11353 The given path may turn abruptly at a knot, and it might pass the critical
11354 tangent direction at such a time. Therefore we remember the direction |phi|
11355 in which the previous rotated cubic was traveling. (The value of |phi| will be
11356 undefined on the first cubic, i.e., when |n=0|.)
11358 @<Rotate the cubic between |p| and |q|; then...@>=
11360 @<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples of the control
11361 points of the rotated derivatives@>;
11362 if ( y1==0 ) if ( x1>=0 ) goto FOUND;
11364 @<Exit to |found| if an eastward direction occurs at knot |p|@>;
11367 if ( (x3!=0)||(y3!=0) ) phi=mp_n_arg(mp, x3,y3);
11368 @<Exit to |found| if the curve whose derivatives are specified by
11369 |x1,x2,x3,y1,y2,y3| travels eastward at some time~|tt|@>
11371 @ @<Other local variables for |find_direction_time|@>=
11372 scaled x1,x2,x3,y1,y2,y3; /* multiples of rotated derivatives */
11373 angle theta,phi; /* angles of exit and entry at a knot */
11374 fraction t; /* temp storage */
11376 @ @<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples...@>=
11377 x1=right_x(p)-x_coord(p); x2=left_x(q)-right_x(p);
11378 x3=x_coord(q)-left_x(q);
11379 y1=right_y(p)-y_coord(p); y2=left_y(q)-right_y(p);
11380 y3=y_coord(q)-left_y(q);
11382 if ( abs(x2)>max ) max=abs(x2);
11383 if ( abs(x3)>max ) max=abs(x3);
11384 if ( abs(y1)>max ) max=abs(y1);
11385 if ( abs(y2)>max ) max=abs(y2);
11386 if ( abs(y3)>max ) max=abs(y3);
11387 if ( max==0 ) goto FOUND;
11388 while ( max<fraction_half ){
11389 max+=max; x1+=x1; x2+=x2; x3+=x3;
11390 y1+=y1; y2+=y2; y3+=y3;
11392 t=x1; x1=mp_take_fraction(mp, x1,x)+mp_take_fraction(mp, y1,y);
11393 y1=mp_take_fraction(mp, y1,x)-mp_take_fraction(mp, t,y);
11394 t=x2; x2=mp_take_fraction(mp, x2,x)+mp_take_fraction(mp, y2,y);
11395 y2=mp_take_fraction(mp, y2,x)-mp_take_fraction(mp, t,y);
11396 t=x3; x3=mp_take_fraction(mp, x3,x)+mp_take_fraction(mp, y3,y);
11397 y3=mp_take_fraction(mp, y3,x)-mp_take_fraction(mp, t,y)
11399 @ @<Exit to |found| if an eastward direction occurs at knot |p|@>=
11400 theta=mp_n_arg(mp, x1,y1);
11401 if ( theta>=0 ) if ( phi<=0 ) if ( phi>=theta-one_eighty_deg ) goto FOUND;
11402 if ( theta<=0 ) if ( phi>=0 ) if ( phi<=theta+one_eighty_deg ) goto FOUND
11404 @ In this step we want to use the |crossing_point| routine to find the
11405 roots of the quadratic equation $B(y_1,y_2,y_3;t)=0$.
11406 Several complications arise: If the quadratic equation has a double root,
11407 the curve never crosses zero, and |crossing_point| will find nothing;
11408 this case occurs iff $y_1y_3=y_2^2$ and $y_1y_2<0$. If the quadratic
11409 equation has simple roots, or only one root, we may have to negate it
11410 so that $B(y_1,y_2,y_3;t)$ crosses from positive to negative at its first root.
11411 And finally, we need to do special things if $B(y_1,y_2,y_3;t)$ is
11414 @ @<Exit to |found| if the curve whose derivatives are specified by...@>=
11415 if ( x1<0 ) if ( x2<0 ) if ( x3<0 ) goto DONE;
11416 if ( mp_ab_vs_cd(mp, y1,y3,y2,y2)==0 ) {
11417 @<Handle the test for eastward directions when $y_1y_3=y_2^2$;
11418 either |goto found| or |goto done|@>;
11421 if ( y1<0 ) { y1=-y1; y2=-y2; y3=-y3; }
11422 else if ( y2>0 ){ y2=-y2; y3=-y3; };
11424 @<Check the places where $B(y_1,y_2,y_3;t)=0$ to see if
11425 $B(x_1,x_2,x_3;t)\ge0$@>;
11428 @ The quadratic polynomial $B(y_1,y_2,y_3;t)$ begins |>=0| and has at most
11429 two roots, because we know that it isn't identically zero.
11431 It must be admitted that the |crossing_point| routine is not perfectly accurate;
11432 rounding errors might cause it to find a root when $y_1y_3>y_2^2$, or to
11433 miss the roots when $y_1y_3<y_2^2$. The rotation process is itself
11434 subject to rounding errors. Yet this code optimistically tries to
11435 do the right thing.
11437 @d we_found_it { tt=(t+04000) / 010000; goto FOUND; }
11439 @<Check the places where $B(y_1,y_2,y_3;t)=0$...@>=
11440 t=mp_crossing_point(mp, y1,y2,y3);
11441 if ( t>fraction_one ) goto DONE;
11442 y2=t_of_the_way(y2,y3);
11443 x1=t_of_the_way(x1,x2);
11444 x2=t_of_the_way(x2,x3);
11445 x1=t_of_the_way(x1,x2);
11446 if ( x1>=0 ) we_found_it;
11448 tt=t; t=mp_crossing_point(mp, 0,-y2,-y3);
11449 if ( t>fraction_one ) goto DONE;
11450 x1=t_of_the_way(x1,x2);
11451 x2=t_of_the_way(x2,x3);
11452 if ( t_of_the_way(x1,x2)>=0 ) {
11453 t=t_of_the_way(tt,fraction_one); we_found_it;
11456 @ @<Handle the test for eastward directions when $y_1y_3=y_2^2$;
11457 either |goto found| or |goto done|@>=
11459 if ( mp_ab_vs_cd(mp, y1,y2,0,0)<0 ) {
11460 t=mp_make_fraction(mp, y1,y1-y2);
11461 x1=t_of_the_way(x1,x2);
11462 x2=t_of_the_way(x2,x3);
11463 if ( t_of_the_way(x1,x2)>=0 ) we_found_it;
11464 } else if ( y3==0 ) {
11466 @<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|@>;
11467 } else if ( x3>=0 ) {
11468 tt=unity; goto FOUND;
11474 @ At this point we know that the derivative of |y(t)| is identically zero,
11475 and that |x1<0|; but either |x2>=0| or |x3>=0|, so there's some hope of
11478 @<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|...@>=
11480 t=mp_crossing_point(mp, -x1,-x2,-x3);
11481 if ( t<=fraction_one ) we_found_it;
11482 if ( mp_ab_vs_cd(mp, x1,x3,x2,x2)<=0 ) {
11483 t=mp_make_fraction(mp, x1,x1-x2); we_found_it;
11487 @ The intersection of two cubics can be found by an interesting variant
11488 of the general bisection scheme described in the introduction to
11490 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)$,
11491 we wish to find a pair of times $(t_1,t_2)$ such that $w(t_1)=z(t_2)$,
11492 if an intersection exists. First we find the smallest rectangle that
11493 encloses the points $\{w_0,w_1,w_2,w_3\}$ and check that it overlaps
11494 the smallest rectangle that encloses
11495 $\{z_0,z_1,z_2,z_3\}$; if not, the cubics certainly don't intersect.
11496 But if the rectangles do overlap, we bisect the intervals, getting
11497 new cubics $w'$ and~$w''$, $z'$~and~$z''$; the intersection routine first
11498 tries for an intersection between $w'$ and~$z'$, then (if unsuccessful)
11499 between $w'$ and~$z''$, then (if still unsuccessful) between $w''$ and~$z'$,
11500 finally (if thrice unsuccessful) between $w''$ and~$z''$. After $l$~successful
11501 levels of bisection we will have determined the intersection times $t_1$
11502 and~$t_2$ to $l$~bits of accuracy.
11504 \def\submin{_{\rm min}} \def\submax{_{\rm max}}
11505 As before, it is better to work with the numbers $W_k=2^l(w_k-w_{k-1})$
11506 and $Z_k=2^l(z_k-z_{k-1})$ rather than the coefficients $w_k$ and $z_k$
11507 themselves. We also need one other quantity, $\Delta=2^l(w_0-z_0)$,
11508 to determine when the enclosing rectangles overlap. Here's why:
11509 The $x$~coordinates of~$w(t)$ are between $u\submin$ and $u\submax$,
11510 and the $x$~coordinates of~$z(t)$ are between $x\submin$ and $x\submax$,
11511 if we write $w_k=(u_k,v_k)$ and $z_k=(x_k,y_k)$ and $u\submin=
11512 \min(u_0,u_1,u_2,u_3)$, etc. These intervals of $x$~coordinates
11513 overlap if and only if $u\submin\L x\submax$ and
11514 $x\submin\L u\submax$. Letting
11515 $$U\submin=\min(0,U_1,U_1+U_2,U_1+U_2+U_3),\;
11516 U\submax=\max(0,U_1,U_1+U_2,U_1+U_2+U_3),$$
11517 we have $2^lu\submin=2^lu_0+U\submin$, etc.; the condition for overlap
11519 $$X\submin-U\submax\L 2^l(u_0-x_0)\L X\submax-U\submin.$$
11520 Thus we want to maintain the quantity $2^l(u_0-x_0)$; similarly,
11521 the quantity $2^l(v_0-y_0)$ accounts for the $y$~coordinates. The
11522 coordinates of $\Delta=2^l(w_0-z_0)$ must stay bounded as $l$ increases,
11523 because of the overlap condition; i.e., we know that $X\submin$,
11524 $X\submax$, and their relatives are bounded, hence $X\submax-
11525 U\submin$ and $X\submin-U\submax$ are bounded.
11527 @ Incidentally, if the given cubics intersect more than once, the process
11528 just sketched will not necessarily find the lexicographically smallest pair
11529 $(t_1,t_2)$. The solution actually obtained will be smallest in ``shuffled
11530 order''; i.e., if $t_1=(.a_1a_2\ldots a_{16})_2$ and
11531 $t_2=(.b_1b_2\ldots b_{16})_2$, then we will minimize
11532 $a_1b_1a_2b_2\ldots a_{16}b_{16}$, not
11533 $a_1a_2\ldots a_{16}b_1b_2\ldots b_{16}$.
11534 Shuffled order agrees with lexicographic order if all pairs of solutions
11535 $(t_1,t_2)$ and $(t_1',t_2')$ have the property that $t_1<t_1'$ iff
11536 $t_2<t_2'$; but in general, lexicographic order can be quite different,
11537 and the bisection algorithm would be substantially less efficient if it were
11538 constrained by lexicographic order.
11540 For example, suppose that an overlap has been found for $l=3$ and
11541 $(t_1,t_2)= (.101,.011)$ in binary, but that no overlap is produced by
11542 either of the alternatives $(.1010,.0110)$, $(.1010,.0111)$ at level~4.
11543 Then there is probably an intersection in one of the subintervals
11544 $(.1011,.011x)$; but lexicographic order would require us to explore
11545 $(.1010,.1xxx)$ and $(.1011,.00xx)$ and $(.1011,.010x)$ first. We wouldn't
11546 want to store all of the subdivision data for the second path, so the
11547 subdivisions would have to be regenerated many times. Such inefficiencies
11548 would be associated with every `1' in the binary representation of~$t_1$.
11550 @ The subdivision process introduces rounding errors, hence we need to
11551 make a more liberal test for overlap. It is not hard to show that the
11552 computed values of $U_i$ differ from the truth by at most~$l$, on
11553 level~$l$, hence $U\submin$ and $U\submax$ will be at most $3l$ in error.
11554 If $\beta$ is an upper bound on the absolute error in the computed
11555 components of $\Delta=(|delx|,|dely|)$ on level~$l$, we will replace
11556 the test `$X\submin-U\submax\L|delx|$' by the more liberal test
11557 `$X\submin-U\submax\L|delx|+|tol|$', where $|tol|=6l+\beta$.
11559 More accuracy is obtained if we try the algorithm first with |tol=0|;
11560 the more liberal tolerance is used only if an exact approach fails.
11561 It is convenient to do this double-take by letting `3' in the preceding
11562 paragraph be a parameter, which is first 0, then 3.
11565 unsigned int tol_step; /* either 0 or 3, usually */
11567 @ We shall use an explicit stack to implement the recursive bisection
11568 method described above. The |bisect_stack| array will contain numerous 5-word
11569 packets like $(U_1,U_2,U_3,U\submin,U\submax)$, as well as 20-word packets
11570 comprising the 5-word packets for $U$, $V$, $X$, and~$Y$.
11572 The following macros define the allocation of stack positions to
11573 the quantities needed for bisection-intersection.
11575 @d stack_1(A) mp->bisect_stack[(A)] /* $U_1$, $V_1$, $X_1$, or $Y_1$ */
11576 @d stack_2(A) mp->bisect_stack[(A)+1] /* $U_2$, $V_2$, $X_2$, or $Y_2$ */
11577 @d stack_3(A) mp->bisect_stack[(A)+2] /* $U_3$, $V_3$, $X_3$, or $Y_3$ */
11578 @d stack_min(A) mp->bisect_stack[(A)+3]
11579 /* $U\submin$, $V\submin$, $X\submin$, or $Y\submin$ */
11580 @d stack_max(A) mp->bisect_stack[(A)+4]
11581 /* $U\submax$, $V\submax$, $X\submax$, or $Y\submax$ */
11582 @d int_packets 20 /* number of words to represent $U_k$, $V_k$, $X_k$, and $Y_k$ */
11584 @d u_packet(A) ((A)-5)
11585 @d v_packet(A) ((A)-10)
11586 @d x_packet(A) ((A)-15)
11587 @d y_packet(A) ((A)-20)
11588 @d l_packets (mp->bisect_ptr-int_packets)
11589 @d r_packets mp->bisect_ptr
11590 @d ul_packet u_packet(l_packets) /* base of $U'_k$ variables */
11591 @d vl_packet v_packet(l_packets) /* base of $V'_k$ variables */
11592 @d xl_packet x_packet(l_packets) /* base of $X'_k$ variables */
11593 @d yl_packet y_packet(l_packets) /* base of $Y'_k$ variables */
11594 @d ur_packet u_packet(r_packets) /* base of $U''_k$ variables */
11595 @d vr_packet v_packet(r_packets) /* base of $V''_k$ variables */
11596 @d xr_packet x_packet(r_packets) /* base of $X''_k$ variables */
11597 @d yr_packet y_packet(r_packets) /* base of $Y''_k$ variables */
11599 @d u1l stack_1(ul_packet) /* $U'_1$ */
11600 @d u2l stack_2(ul_packet) /* $U'_2$ */
11601 @d u3l stack_3(ul_packet) /* $U'_3$ */
11602 @d v1l stack_1(vl_packet) /* $V'_1$ */
11603 @d v2l stack_2(vl_packet) /* $V'_2$ */
11604 @d v3l stack_3(vl_packet) /* $V'_3$ */
11605 @d x1l stack_1(xl_packet) /* $X'_1$ */
11606 @d x2l stack_2(xl_packet) /* $X'_2$ */
11607 @d x3l stack_3(xl_packet) /* $X'_3$ */
11608 @d y1l stack_1(yl_packet) /* $Y'_1$ */
11609 @d y2l stack_2(yl_packet) /* $Y'_2$ */
11610 @d y3l stack_3(yl_packet) /* $Y'_3$ */
11611 @d u1r stack_1(ur_packet) /* $U''_1$ */
11612 @d u2r stack_2(ur_packet) /* $U''_2$ */
11613 @d u3r stack_3(ur_packet) /* $U''_3$ */
11614 @d v1r stack_1(vr_packet) /* $V''_1$ */
11615 @d v2r stack_2(vr_packet) /* $V''_2$ */
11616 @d v3r stack_3(vr_packet) /* $V''_3$ */
11617 @d x1r stack_1(xr_packet) /* $X''_1$ */
11618 @d x2r stack_2(xr_packet) /* $X''_2$ */
11619 @d x3r stack_3(xr_packet) /* $X''_3$ */
11620 @d y1r stack_1(yr_packet) /* $Y''_1$ */
11621 @d y2r stack_2(yr_packet) /* $Y''_2$ */
11622 @d y3r stack_3(yr_packet) /* $Y''_3$ */
11624 @d stack_dx mp->bisect_stack[mp->bisect_ptr] /* stacked value of |delx| */
11625 @d stack_dy mp->bisect_stack[mp->bisect_ptr+1] /* stacked value of |dely| */
11626 @d stack_tol mp->bisect_stack[mp->bisect_ptr+2] /* stacked value of |tol| */
11627 @d stack_uv mp->bisect_stack[mp->bisect_ptr+3] /* stacked value of |uv| */
11628 @d stack_xy mp->bisect_stack[mp->bisect_ptr+4] /* stacked value of |xy| */
11629 @d int_increment (int_packets+int_packets+5) /* number of stack words per level */
11632 integer *bisect_stack;
11633 unsigned int bisect_ptr;
11635 @ @<Allocate or initialize ...@>=
11636 mp->bisect_stack = xmalloc((bistack_size+1),sizeof(integer));
11638 @ @<Dealloc variables@>=
11639 xfree(mp->bisect_stack);
11641 @ @<Check the ``constant''...@>=
11642 if ( int_packets+17*int_increment>bistack_size ) mp->bad=19;
11644 @ Computation of the min and max is a tedious but fairly fast sequence of
11645 instructions; exactly four comparisons are made in each branch.
11648 if ( stack_1((A))<0 ) {
11649 if ( stack_3((A))>=0 ) {
11650 if ( stack_2((A))<0 ) stack_min((A))=stack_1((A))+stack_2((A));
11651 else stack_min((A))=stack_1((A));
11652 stack_max((A))=stack_1((A))+stack_2((A))+stack_3((A));
11653 if ( stack_max((A))<0 ) stack_max((A))=0;
11655 stack_min((A))=stack_1((A))+stack_2((A))+stack_3((A));
11656 if ( stack_min((A))>stack_1((A)) ) stack_min((A))=stack_1((A));
11657 stack_max((A))=stack_1((A))+stack_2((A));
11658 if ( stack_max((A))<0 ) stack_max((A))=0;
11660 } else if ( stack_3((A))<=0 ) {
11661 if ( stack_2((A))>0 ) stack_max((A))=stack_1((A))+stack_2((A));
11662 else stack_max((A))=stack_1((A));
11663 stack_min((A))=stack_1((A))+stack_2((A))+stack_3((A));
11664 if ( stack_min((A))>0 ) stack_min((A))=0;
11666 stack_max((A))=stack_1((A))+stack_2((A))+stack_3((A));
11667 if ( stack_max((A))<stack_1((A)) ) stack_max((A))=stack_1((A));
11668 stack_min((A))=stack_1((A))+stack_2((A));
11669 if ( stack_min((A))>0 ) stack_min((A))=0;
11672 @ It's convenient to keep the current values of $l$, $t_1$, and $t_2$ in
11673 the integer form $2^l+2^lt_1$ and $2^l+2^lt_2$. The |cubic_intersection|
11674 routine uses global variables |cur_t| and |cur_tt| for this purpose;
11675 after successful completion, |cur_t| and |cur_tt| will contain |unity|
11676 plus the |scaled| values of $t_1$ and~$t_2$.
11678 The values of |cur_t| and |cur_tt| will be set to zero if |cubic_intersection|
11679 finds no intersection. The routine gives up and gives an approximate answer
11680 if it has backtracked
11681 more than 5000 times (otherwise there are cases where several minutes
11682 of fruitless computation would be possible).
11684 @d max_patience 5000
11687 integer cur_t;integer cur_tt; /* controls and results of |cubic_intersection| */
11688 integer time_to_go; /* this many backtracks before giving up */
11689 integer max_t; /* maximum of $2^{l+1}$ so far achieved */
11691 @ The given cubics $B(w_0,w_1,w_2,w_3;t)$ and
11692 $B(z_0,z_1,z_2,z_3;t)$ are specified in adjacent knot nodes |(p,link(p))|
11693 and |(pp,link(pp))|, respectively.
11695 @c void mp_cubic_intersection (MP mp,pointer p, pointer pp) {
11696 pointer q,qq; /* |link(p)|, |link(pp)| */
11697 mp->time_to_go=max_patience; mp->max_t=2;
11698 @<Initialize for intersections at level zero@>;
11701 if ( mp->delx-mp->tol<=stack_max(x_packet(mp->xy))-stack_min(u_packet(mp->uv)))
11702 if ( mp->delx+mp->tol>=stack_min(x_packet(mp->xy))-stack_max(u_packet(mp->uv)))
11703 if ( mp->dely-mp->tol<=stack_max(y_packet(mp->xy))-stack_min(v_packet(mp->uv)))
11704 if ( mp->dely+mp->tol>=stack_min(y_packet(mp->xy))-stack_max(v_packet(mp->uv)))
11706 if ( mp->cur_t>=mp->max_t ){
11707 if ( mp->max_t==two ) { /* we've done 17 bisections */
11708 mp->cur_t=halfp(mp->cur_t+1);
11709 mp->cur_tt=halfp(mp->cur_tt+1);
11712 mp->max_t+=mp->max_t; mp->appr_t=mp->cur_t; mp->appr_tt=mp->cur_tt;
11714 @<Subdivide for a new level of intersection@>;
11717 if ( mp->time_to_go>0 ) {
11718 decr(mp->time_to_go);
11720 while ( mp->appr_t<unity ) {
11721 mp->appr_t+=mp->appr_t; mp->appr_tt+=mp->appr_tt;
11723 mp->cur_t=mp->appr_t; mp->cur_tt=mp->appr_tt; return;
11725 @<Advance to the next pair |(cur_t,cur_tt)|@>;
11729 @ The following variables are global, although they are used only by
11730 |cubic_intersection|, because it is necessary on some machines to
11731 split |cubic_intersection| up into two procedures.
11734 integer delx;integer dely; /* the components of $\Delta=2^l(w_0-z_0)$ */
11735 integer tol; /* bound on the uncertainty in the overlap test */
11737 unsigned int xy; /* pointers to the current packets of interest */
11738 integer three_l; /* |tol_step| times the bisection level */
11739 integer appr_t;integer appr_tt; /* best approximations known to the answers */
11741 @ We shall assume that the coordinates are sufficiently non-extreme that
11742 integer overflow will not occur.
11743 @^overflow in arithmetic@>
11745 @<Initialize for intersections at level zero@>=
11746 q=link(p); qq=link(pp); mp->bisect_ptr=int_packets;
11747 u1r=right_x(p)-x_coord(p); u2r=left_x(q)-right_x(p);
11748 u3r=x_coord(q)-left_x(q); set_min_max(ur_packet);
11749 v1r=right_y(p)-y_coord(p); v2r=left_y(q)-right_y(p);
11750 v3r=y_coord(q)-left_y(q); set_min_max(vr_packet);
11751 x1r=right_x(pp)-x_coord(pp); x2r=left_x(qq)-right_x(pp);
11752 x3r=x_coord(qq)-left_x(qq); set_min_max(xr_packet);
11753 y1r=right_y(pp)-y_coord(pp); y2r=left_y(qq)-right_y(pp);
11754 y3r=y_coord(qq)-left_y(qq); set_min_max(yr_packet);
11755 mp->delx=x_coord(p)-x_coord(pp); mp->dely=y_coord(p)-y_coord(pp);
11756 mp->tol=0; mp->uv=r_packets; mp->xy=r_packets;
11757 mp->three_l=0; mp->cur_t=1; mp->cur_tt=1
11759 @ @<Subdivide for a new level of intersection@>=
11760 stack_dx=mp->delx; stack_dy=mp->dely; stack_tol=mp->tol;
11761 stack_uv=mp->uv; stack_xy=mp->xy;
11762 mp->bisect_ptr=mp->bisect_ptr+int_increment;
11763 mp->cur_t+=mp->cur_t; mp->cur_tt+=mp->cur_tt;
11764 u1l=stack_1(u_packet(mp->uv)); u3r=stack_3(u_packet(mp->uv));
11765 u2l=half(u1l+stack_2(u_packet(mp->uv)));
11766 u2r=half(u3r+stack_2(u_packet(mp->uv)));
11767 u3l=half(u2l+u2r); u1r=u3l;
11768 set_min_max(ul_packet); set_min_max(ur_packet);
11769 v1l=stack_1(v_packet(mp->uv)); v3r=stack_3(v_packet(mp->uv));
11770 v2l=half(v1l+stack_2(v_packet(mp->uv)));
11771 v2r=half(v3r+stack_2(v_packet(mp->uv)));
11772 v3l=half(v2l+v2r); v1r=v3l;
11773 set_min_max(vl_packet); set_min_max(vr_packet);
11774 x1l=stack_1(x_packet(mp->xy)); x3r=stack_3(x_packet(mp->xy));
11775 x2l=half(x1l+stack_2(x_packet(mp->xy)));
11776 x2r=half(x3r+stack_2(x_packet(mp->xy)));
11777 x3l=half(x2l+x2r); x1r=x3l;
11778 set_min_max(xl_packet); set_min_max(xr_packet);
11779 y1l=stack_1(y_packet(mp->xy)); y3r=stack_3(y_packet(mp->xy));
11780 y2l=half(y1l+stack_2(y_packet(mp->xy)));
11781 y2r=half(y3r+stack_2(y_packet(mp->xy)));
11782 y3l=half(y2l+y2r); y1r=y3l;
11783 set_min_max(yl_packet); set_min_max(yr_packet);
11784 mp->uv=l_packets; mp->xy=l_packets;
11785 mp->delx+=mp->delx; mp->dely+=mp->dely;
11786 mp->tol=mp->tol-mp->three_l+mp->tol_step;
11787 mp->tol+=mp->tol; mp->three_l=mp->three_l+mp->tol_step
11789 @ @<Advance to the next pair |(cur_t,cur_tt)|@>=
11791 if ( odd(mp->cur_tt) ) {
11792 if ( odd(mp->cur_t) ) {
11793 @<Descend to the previous level and |goto not_found|@>;
11796 mp->delx=mp->delx+stack_1(u_packet(mp->uv))+stack_2(u_packet(mp->uv))
11797 +stack_3(u_packet(mp->uv));
11798 mp->dely=mp->dely+stack_1(v_packet(mp->uv))+stack_2(v_packet(mp->uv))
11799 +stack_3(v_packet(mp->uv));
11800 mp->uv=mp->uv+int_packets; /* switch from |l_packets| to |r_packets| */
11801 decr(mp->cur_tt); mp->xy=mp->xy-int_packets;
11802 /* switch from |r_packets| to |l_packets| */
11803 mp->delx=mp->delx+stack_1(x_packet(mp->xy))+stack_2(x_packet(mp->xy))
11804 +stack_3(x_packet(mp->xy));
11805 mp->dely=mp->dely+stack_1(y_packet(mp->xy))+stack_2(y_packet(mp->xy))
11806 +stack_3(y_packet(mp->xy));
11809 incr(mp->cur_tt); mp->tol=mp->tol+mp->three_l;
11810 mp->delx=mp->delx-stack_1(x_packet(mp->xy))-stack_2(x_packet(mp->xy))
11811 -stack_3(x_packet(mp->xy));
11812 mp->dely=mp->dely-stack_1(y_packet(mp->xy))-stack_2(y_packet(mp->xy))
11813 -stack_3(y_packet(mp->xy));
11814 mp->xy=mp->xy+int_packets; /* switch from |l_packets| to |r_packets| */
11817 @ @<Descend to the previous level...@>=
11819 mp->cur_t=halfp(mp->cur_t); mp->cur_tt=halfp(mp->cur_tt);
11820 if ( mp->cur_t==0 ) return;
11821 mp->bisect_ptr=mp->bisect_ptr-int_increment;
11822 mp->three_l=mp->three_l-mp->tol_step;
11823 mp->delx=stack_dx; mp->dely=stack_dy; mp->tol=stack_tol;
11824 mp->uv=stack_uv; mp->xy=stack_xy;
11828 @ The |path_intersection| procedure is much simpler.
11829 It invokes |cubic_intersection| in lexicographic order until finding a
11830 pair of cubics that intersect. The final intersection times are placed in
11831 |cur_t| and~|cur_tt|.
11833 @c void mp_path_intersection (MP mp,pointer h, pointer hh) {
11834 pointer p,pp; /* link registers that traverse the given paths */
11835 integer n,nn; /* integer parts of intersection times, minus |unity| */
11836 @<Change one-point paths into dead cycles@>;
11841 if ( right_type(p)!=mp_endpoint ) {
11844 if ( right_type(pp)!=mp_endpoint ) {
11845 mp_cubic_intersection(mp, p,pp);
11846 if ( mp->cur_t>0 ) {
11847 mp->cur_t=mp->cur_t+n; mp->cur_tt=mp->cur_tt+nn;
11851 nn=nn+unity; pp=link(pp);
11854 n=n+unity; p=link(p);
11856 mp->tol_step=mp->tol_step+3;
11857 } while (mp->tol_step<=3);
11858 mp->cur_t=-unity; mp->cur_tt=-unity;
11861 @ @<Change one-point paths...@>=
11862 if ( right_type(h)==mp_endpoint ) {
11863 right_x(h)=x_coord(h); left_x(h)=x_coord(h);
11864 right_y(h)=y_coord(h); left_y(h)=y_coord(h); right_type(h)=mp_explicit;
11866 if ( right_type(hh)==mp_endpoint ) {
11867 right_x(hh)=x_coord(hh); left_x(hh)=x_coord(hh);
11868 right_y(hh)=y_coord(hh); left_y(hh)=y_coord(hh); right_type(hh)=mp_explicit;
11871 @* \[24] Dynamic linear equations.
11872 \MP\ users define variables implicitly by stating equations that should be
11873 satisfied; the computer is supposed to be smart enough to solve those equations.
11874 And indeed, the computer tries valiantly to do so, by distinguishing five
11875 different types of numeric values:
11878 |type(p)=mp_known| is the nice case, when |value(p)| is the |scaled| value
11879 of the variable whose address is~|p|.
11882 |type(p)=mp_dependent| means that |value(p)| is not present, but |dep_list(p)|
11883 points to a {\sl dependency list\/} that expresses the value of variable~|p|
11884 as a |scaled| number plus a sum of independent variables with |fraction|
11888 |type(p)=mp_independent| means that |value(p)=64s+m|, where |s>0| is a ``serial
11889 number'' reflecting the time this variable was first used in an equation;
11890 also |0<=m<64|, and each dependent variable
11891 that refers to this one is actually referring to the future value of
11892 this variable times~$2^m$. (Usually |m=0|, but higher degrees of
11893 scaling are sometimes needed to keep the coefficients in dependency lists
11894 from getting too large. The value of~|m| will always be even.)
11897 |type(p)=mp_numeric_type| means that variable |p| hasn't appeared in an
11898 equation before, but it has been explicitly declared to be numeric.
11901 |type(p)=undefined| means that variable |p| hasn't appeared before.
11903 \smallskip\noindent
11904 We have actually discussed these five types in the reverse order of their
11905 history during a computation: Once |known|, a variable never again
11906 becomes |dependent|; once |dependent|, it almost never again becomes
11907 |mp_independent|; once |mp_independent|, it never again becomes |mp_numeric_type|;
11908 and once |mp_numeric_type|, it never again becomes |undefined| (except
11909 of course when the user specifically decides to scrap the old value
11910 and start again). A backward step may, however, take place: Sometimes
11911 a |dependent| variable becomes |mp_independent| again, when one of the
11912 independent variables it depends on is reverting to |undefined|.
11915 The next patch detects overflow of independent-variable serial
11916 numbers. Diagnosed and patched by Thorsten Dahlheimer.
11918 @d s_scale 64 /* the serial numbers are multiplied by this factor */
11919 @d new_indep(A) /* create a new independent variable */
11920 { if ( mp->serial_no>el_gordo-s_scale )
11921 mp_fatal_error(mp, "variable instance identifiers exhausted");
11922 type((A))=mp_independent; mp->serial_no=mp->serial_no+s_scale;
11923 value((A))=mp->serial_no;
11927 integer serial_no; /* the most recent serial number, times |s_scale| */
11929 @ @<Make variable |q+s| newly independent@>=new_indep(q+s)
11931 @ But how are dependency lists represented? It's simple: The linear combination
11932 $\alpha_1v_1+\cdots+\alpha_kv_k+\beta$ appears in |k+1| value nodes. If
11933 |q=dep_list(p)| points to this list, and if |k>0|, then |value(q)=
11934 @t$\alpha_1$@>| (which is a |fraction|); |info(q)| points to the location
11935 of $\alpha_1$; and |link(p)| points to the dependency list
11936 $\alpha_2v_2+\cdots+\alpha_kv_k+\beta$. On the other hand if |k=0|,
11937 then |value(q)=@t$\beta$@>| (which is |scaled|) and |info(q)=null|.
11938 The independent variables $v_1$, \dots,~$v_k$ have been sorted so that
11939 they appear in decreasing order of their |value| fields (i.e., of
11940 their serial numbers). \ (It is convenient to use decreasing order,
11941 since |value(null)=0|. If the independent variables were not sorted by
11942 serial number but by some other criterion, such as their location in |mem|,
11943 the equation-solving mechanism would be too system-dependent, because
11944 the ordering can affect the computed results.)
11946 The |link| field in the node that contains the constant term $\beta$ is
11947 called the {\sl final link\/} of the dependency list. \MP\ maintains
11948 a doubly-linked master list of all dependency lists, in terms of a permanently
11950 in |mem| called |dep_head|. If there are no dependencies, we have
11951 |link(dep_head)=dep_head| and |prev_dep(dep_head)=dep_head|;
11952 otherwise |link(dep_head)| points to the first dependent variable, say~|p|,
11953 and |prev_dep(p)=dep_head|. We have |type(p)=mp_dependent|, and |dep_list(p)|
11954 points to its dependency list. If the final link of that dependency list
11955 occurs in location~|q|, then |link(q)| points to the next dependent
11956 variable (say~|r|); and we have |prev_dep(r)=q|, etc.
11958 @d dep_list(A) link(value_loc((A)))
11959 /* half of the |value| field in a |dependent| variable */
11960 @d prev_dep(A) info(value_loc((A)))
11961 /* the other half; makes a doubly linked list */
11962 @d dep_node_size 2 /* the number of words per dependency node */
11964 @<Initialize table entries...@>= mp->serial_no=0;
11965 link(dep_head)=dep_head; prev_dep(dep_head)=dep_head;
11966 info(dep_head)=null; dep_list(dep_head)=null;
11968 @ Actually the description above contains a little white lie. There's
11969 another kind of variable called |mp_proto_dependent|, which is
11970 just like a |dependent| one except that the $\alpha$ coefficients
11971 in its dependency list are |scaled| instead of being fractions.
11972 Proto-dependency lists are mixed with dependency lists in the
11973 nodes reachable from |dep_head|.
11975 @ Here is a procedure that prints a dependency list in symbolic form.
11976 The second parameter should be either |dependent| or |mp_proto_dependent|,
11977 to indicate the scaling of the coefficients.
11979 @<Declare subroutines for printing expressions@>=
11980 void mp_print_dependency (MP mp,pointer p, small_number t) {
11981 integer v; /* a coefficient */
11982 pointer pp,q; /* for list manipulation */
11985 v=abs(value(p)); q=info(p);
11986 if ( q==null ) { /* the constant term */
11987 if ( (v!=0)||(p==pp) ) {
11988 if ( value(p)>0 ) if ( p!=pp ) mp_print_char(mp, '+');
11989 mp_print_scaled(mp, value(p));
11993 @<Print the coefficient, unless it's $\pm1.0$@>;
11994 if ( type(q)!=mp_independent ) mp_confusion(mp, "dep");
11995 @:this can't happen dep}{\quad dep@>
11996 mp_print_variable_name(mp, q); v=value(q) % s_scale;
11997 while ( v>0 ) { mp_print(mp, "*4"); v=v-2; }
12002 @ @<Print the coefficient, unless it's $\pm1.0$@>=
12003 if ( value(p)<0 ) mp_print_char(mp, '-');
12004 else if ( p!=pp ) mp_print_char(mp, '+');
12005 if ( t==mp_dependent ) v=mp_round_fraction(mp, v);
12006 if ( v!=unity ) mp_print_scaled(mp, v)
12008 @ The maximum absolute value of a coefficient in a given dependency list
12009 is returned by the following simple function.
12011 @c fraction mp_max_coef (MP mp,pointer p) {
12012 fraction x; /* the maximum so far */
12014 while ( info(p)!=null ) {
12015 if ( abs(value(p))>x ) x=abs(value(p));
12021 @ One of the main operations needed on dependency lists is to add a multiple
12022 of one list to the other; we call this |p_plus_fq|, where |p| and~|q| point
12023 to dependency lists and |f| is a fraction.
12025 If the coefficient of any independent variable becomes |coef_bound| or
12026 more, in absolute value, this procedure changes the type of that variable
12027 to `|independent_needing_fix|', and sets the global variable |fix_needed|
12028 to~|true|. The value of $|coef_bound|=\mu$ is chosen so that
12029 $\mu^2+\mu<8$; this means that the numbers we deal with won't
12030 get too large. (Instead of the ``optimum'' $\mu=(\sqrt{33}-1)/2\approx
12031 2.3723$, the safer value 7/3 is taken as the threshold.)
12033 The changes mentioned in the preceding paragraph are actually done only if
12034 the global variable |watch_coefs| is |true|. But it usually is; in fact,
12035 it is |false| only when \MP\ is making a dependency list that will soon
12036 be equated to zero.
12038 Several procedures that act on dependency lists, including |p_plus_fq|,
12039 set the global variable |dep_final| to the final (constant term) node of
12040 the dependency list that they produce.
12042 @d coef_bound 04525252525 /* |fraction| approximation to 7/3 */
12043 @d independent_needing_fix 0
12046 boolean fix_needed; /* does at least one |independent| variable need scaling? */
12047 boolean watch_coefs; /* should we scale coefficients that exceed |coef_bound|? */
12048 pointer dep_final; /* location of the constant term and final link */
12051 mp->fix_needed=false; mp->watch_coefs=true;
12053 @ The |p_plus_fq| procedure has a fourth parameter, |t|, that should be
12054 set to |mp_proto_dependent| if |p| is a proto-dependency list. In this
12055 case |f| will be |scaled|, not a |fraction|. Similarly, the fifth parameter~|tt|
12056 should be |mp_proto_dependent| if |q| is a proto-dependency list.
12058 List |q| is unchanged by the operation; but list |p| is totally destroyed.
12060 The final link of the dependency list or proto-dependency list returned
12061 by |p_plus_fq| is the same as the original final link of~|p|. Indeed, the
12062 constant term of the result will be located in the same |mem| location
12063 as the original constant term of~|p|.
12065 Coefficients of the result are assumed to be zero if they are less than
12066 a certain threshold. This compensates for inevitable rounding errors,
12067 and tends to make more variables `|known|'. The threshold is approximately
12068 $10^{-5}$ in the case of normal dependency lists, $10^{-4}$ for
12069 proto-dependencies.
12071 @d fraction_threshold 2685 /* a |fraction| coefficient less than this is zeroed */
12072 @d half_fraction_threshold 1342 /* half of |fraction_threshold| */
12073 @d scaled_threshold 8 /* a |scaled| coefficient less than this is zeroed */
12074 @d half_scaled_threshold 4 /* half of |scaled_threshold| */
12076 @<Declare basic dependency-list subroutines@>=
12077 pointer mp_p_plus_fq ( MP mp, pointer p, integer f,
12078 pointer q, small_number t, small_number tt) ;
12081 pointer mp_p_plus_fq ( MP mp, pointer p, integer f,
12082 pointer q, small_number t, small_number tt) {
12083 pointer pp,qq; /* |info(p)| and |info(q)|, respectively */
12084 pointer r,s; /* for list manipulation */
12085 integer threshold; /* defines a neighborhood of zero */
12086 integer v; /* temporary register */
12087 if ( t==mp_dependent ) threshold=fraction_threshold;
12088 else threshold=scaled_threshold;
12089 r=temp_head; pp=info(p); qq=info(q);
12095 @<Contribute a term from |p|, plus |f| times the
12096 corresponding term from |q|@>
12098 } else if ( value(pp)<value(qq) ) {
12099 @<Contribute a term from |q|, multiplied by~|f|@>
12101 link(r)=p; r=p; p=link(p); pp=info(p);
12104 if ( t==mp_dependent )
12105 value(p)=mp_slow_add(mp, value(p),mp_take_fraction(mp, value(q),f));
12107 value(p)=mp_slow_add(mp, value(p),mp_take_scaled(mp, value(q),f));
12108 link(r)=p; mp->dep_final=p;
12109 return link(temp_head);
12112 @ @<Contribute a term from |p|, plus |f|...@>=
12114 if ( tt==mp_dependent ) v=value(p)+mp_take_fraction(mp, f,value(q));
12115 else v=value(p)+mp_take_scaled(mp, f,value(q));
12116 value(p)=v; s=p; p=link(p);
12117 if ( abs(v)<threshold ) {
12118 mp_free_node(mp, s,dep_node_size);
12120 if ( (abs(v)>=coef_bound) && mp->watch_coefs ) {
12121 type(qq)=independent_needing_fix; mp->fix_needed=true;
12125 pp=info(p); q=link(q); qq=info(q);
12128 @ @<Contribute a term from |q|, multiplied by~|f|@>=
12130 if ( tt==mp_dependent ) v=mp_take_fraction(mp, f,value(q));
12131 else v=mp_take_scaled(mp, f,value(q));
12132 if ( abs(v)>halfp(threshold) ) {
12133 s=mp_get_node(mp, dep_node_size); info(s)=qq; value(s)=v;
12134 if ( (abs(v)>=coef_bound) && mp->watch_coefs ) {
12135 type(qq)=independent_needing_fix; mp->fix_needed=true;
12139 q=link(q); qq=info(q);
12142 @ It is convenient to have another subroutine for the special case
12143 of |p_plus_fq| when |f=1.0|. In this routine lists |p| and |q| are
12144 both of the same type~|t| (either |dependent| or |mp_proto_dependent|).
12146 @c pointer mp_p_plus_q (MP mp,pointer p, pointer q, small_number t) {
12147 pointer pp,qq; /* |info(p)| and |info(q)|, respectively */
12148 pointer r,s; /* for list manipulation */
12149 integer threshold; /* defines a neighborhood of zero */
12150 integer v; /* temporary register */
12151 if ( t==mp_dependent ) threshold=fraction_threshold;
12152 else threshold=scaled_threshold;
12153 r=temp_head; pp=info(p); qq=info(q);
12159 @<Contribute a term from |p|, plus the
12160 corresponding term from |q|@>
12163 if ( value(pp)<value(qq) ) {
12164 s=mp_get_node(mp, dep_node_size); info(s)=qq; value(s)=value(q);
12165 q=link(q); qq=info(q); link(r)=s; r=s;
12167 link(r)=p; r=p; p=link(p); pp=info(p);
12171 value(p)=mp_slow_add(mp, value(p),value(q));
12172 link(r)=p; mp->dep_final=p;
12173 return link(temp_head);
12176 @ @<Contribute a term from |p|, plus the...@>=
12178 v=value(p)+value(q);
12179 value(p)=v; s=p; p=link(p); pp=info(p);
12180 if ( abs(v)<threshold ) {
12181 mp_free_node(mp, s,dep_node_size);
12183 if ( (abs(v)>=coef_bound ) && mp->watch_coefs ) {
12184 type(qq)=independent_needing_fix; mp->fix_needed=true;
12188 q=link(q); qq=info(q);
12191 @ A somewhat simpler routine will multiply a dependency list
12192 by a given constant~|v|. The constant is either a |fraction| less than
12193 |fraction_one|, or it is |scaled|. In the latter case we might be forced to
12194 convert a dependency list to a proto-dependency list.
12195 Parameters |t0| and |t1| are the list types before and after;
12196 they should agree unless |t0=mp_dependent| and |t1=mp_proto_dependent|
12197 and |v_is_scaled=true|.
12199 @c pointer mp_p_times_v (MP mp,pointer p, integer v, small_number t0,
12200 small_number t1, boolean v_is_scaled) {
12201 pointer r,s; /* for list manipulation */
12202 integer w; /* tentative coefficient */
12204 boolean scaling_down;
12205 if ( t0!=t1 ) scaling_down=true; else scaling_down=(!v_is_scaled);
12206 if ( t1==mp_dependent ) threshold=half_fraction_threshold;
12207 else threshold=half_scaled_threshold;
12209 while ( info(p)!=null ) {
12210 if ( scaling_down ) w=mp_take_fraction(mp, v,value(p));
12211 else w=mp_take_scaled(mp, v,value(p));
12212 if ( abs(w)<=threshold ) {
12213 s=link(p); mp_free_node(mp, p,dep_node_size); p=s;
12215 if ( abs(w)>=coef_bound ) {
12216 mp->fix_needed=true; type(info(p))=independent_needing_fix;
12218 link(r)=p; r=p; value(p)=w; p=link(p);
12222 if ( v_is_scaled ) value(p)=mp_take_scaled(mp, value(p),v);
12223 else value(p)=mp_take_fraction(mp, value(p),v);
12224 return link(temp_head);
12227 @ Similarly, we sometimes need to divide a dependency list
12228 by a given |scaled| constant.
12230 @<Declare basic dependency-list subroutines@>=
12231 pointer mp_p_over_v (MP mp,pointer p, scaled v, small_number
12232 t0, small_number t1) ;
12235 pointer mp_p_over_v (MP mp,pointer p, scaled v, small_number
12236 t0, small_number t1) {
12237 pointer r,s; /* for list manipulation */
12238 integer w; /* tentative coefficient */
12240 boolean scaling_down;
12241 if ( t0!=t1 ) scaling_down=true; else scaling_down=false;
12242 if ( t1==mp_dependent ) threshold=half_fraction_threshold;
12243 else threshold=half_scaled_threshold;
12245 while ( info( p)!=null ) {
12246 if ( scaling_down ) {
12247 if ( abs(v)<02000000 ) w=mp_make_scaled(mp, value(p),v*010000);
12248 else w=mp_make_scaled(mp, mp_round_fraction(mp, value(p)),v);
12250 w=mp_make_scaled(mp, value(p),v);
12252 if ( abs(w)<=threshold ) {
12253 s=link(p); mp_free_node(mp, p,dep_node_size); p=s;
12255 if ( abs(w)>=coef_bound ) {
12256 mp->fix_needed=true; type(info(p))=independent_needing_fix;
12258 link(r)=p; r=p; value(p)=w; p=link(p);
12261 link(r)=p; value(p)=mp_make_scaled(mp, value(p),v);
12262 return link(temp_head);
12265 @ Here's another utility routine for dependency lists. When an independent
12266 variable becomes dependent, we want to remove it from all existing
12267 dependencies. The |p_with_x_becoming_q| function computes the
12268 dependency list of~|p| after variable~|x| has been replaced by~|q|.
12270 This procedure has basically the same calling conventions as |p_plus_fq|:
12271 List~|q| is unchanged; list~|p| is destroyed; the constant node and the
12272 final link are inherited from~|p|; and the fourth parameter tells whether
12273 or not |p| is |mp_proto_dependent|. However, the global variable |dep_final|
12274 is not altered if |x| does not occur in list~|p|.
12276 @c pointer mp_p_with_x_becoming_q (MP mp,pointer p,
12277 pointer x, pointer q, small_number t) {
12278 pointer r,s; /* for list manipulation */
12279 integer v; /* coefficient of |x| */
12280 integer sx; /* serial number of |x| */
12281 s=p; r=temp_head; sx=value(x);
12282 while ( value(info(s))>sx ) { r=s; s=link(s); };
12283 if ( info(s)!=x ) {
12286 link(temp_head)=p; link(r)=link(s); v=value(s);
12287 mp_free_node(mp, s,dep_node_size);
12288 return mp_p_plus_fq(mp, link(temp_head),v,q,t,mp_dependent);
12292 @ Here's a simple procedure that reports an error when a variable
12293 has just received a known value that's out of the required range.
12295 @<Declare basic dependency-list subroutines@>=
12296 void mp_val_too_big (MP mp,scaled x) ;
12298 @ @c void mp_val_too_big (MP mp,scaled x) {
12299 if ( mp->internal[mp_warning_check]>0 ) {
12300 print_err("Value is too large ("); mp_print_scaled(mp, x); mp_print_char(mp, ')');
12301 @.Value is too large@>
12302 help4("The equation I just processed has given some variable")
12303 ("a value of 4096 or more. Continue and I'll try to cope")
12304 ("with that big value; but it might be dangerous.")
12305 ("(Set warningcheck:=0 to suppress this message.)");
12310 @ When a dependent variable becomes known, the following routine
12311 removes its dependency list. Here |p| points to the variable, and
12312 |q| points to the dependency list (which is one node long).
12314 @<Declare basic dependency-list subroutines@>=
12315 void mp_make_known (MP mp,pointer p, pointer q) ;
12317 @ @c void mp_make_known (MP mp,pointer p, pointer q) {
12318 int t; /* the previous type */
12319 prev_dep(link(q))=prev_dep(p);
12320 link(prev_dep(p))=link(q); t=type(p);
12321 type(p)=mp_known; value(p)=value(q); mp_free_node(mp, q,dep_node_size);
12322 if ( abs(value(p))>=fraction_one ) mp_val_too_big(mp, value(p));
12323 if (( mp->internal[mp_tracing_equations]>0) && mp_interesting(mp, p) ) {
12324 mp_begin_diagnostic(mp); mp_print_nl(mp, "#### ");
12325 @:]]]\#\#\#\#_}{\.{\#\#\#\#}@>
12326 mp_print_variable_name(mp, p);
12327 mp_print_char(mp, '='); mp_print_scaled(mp, value(p));
12328 mp_end_diagnostic(mp, false);
12330 if (( mp->cur_exp==p ) && mp->cur_type==t ) {
12331 mp->cur_type=mp_known; mp->cur_exp=value(p);
12332 mp_free_node(mp, p,value_node_size);
12336 @ The |fix_dependencies| routine is called into action when |fix_needed|
12337 has been triggered. The program keeps a list~|s| of independent variables
12338 whose coefficients must be divided by~4.
12340 In unusual cases, this fixup process might reduce one or more coefficients
12341 to zero, so that a variable will become known more or less by default.
12343 @<Declare basic dependency-list subroutines@>=
12344 void mp_fix_dependencies (MP mp);
12346 @ @c void mp_fix_dependencies (MP mp) {
12347 pointer p,q,r,s,t; /* list manipulation registers */
12348 pointer x; /* an independent variable */
12349 r=link(dep_head); s=null;
12350 while ( r!=dep_head ){
12352 @<Run through the dependency list for variable |t|, fixing
12353 all nodes, and ending with final link~|q|@>;
12355 if ( q==dep_list(t) ) mp_make_known(mp, t,q);
12357 while ( s!=null ) {
12358 p=link(s); x=info(s); free_avail(s); s=p;
12359 type(x)=mp_independent; value(x)=value(x)+2;
12361 mp->fix_needed=false;
12364 @ @d independent_being_fixed 1 /* this variable already appears in |s| */
12366 @<Run through the dependency list for variable |t|...@>=
12367 r=value_loc(t); /* |link(r)=dep_list(t)| */
12369 q=link(r); x=info(q);
12370 if ( x==null ) break;
12371 if ( type(x)<=independent_being_fixed ) {
12372 if ( type(x)<independent_being_fixed ) {
12373 p=mp_get_avail(mp); link(p)=s; s=p;
12374 info(s)=x; type(x)=independent_being_fixed;
12376 value(q)=value(q) / 4;
12377 if ( value(q)==0 ) {
12378 link(r)=link(q); mp_free_node(mp, q,dep_node_size); q=r;
12385 @ The |new_dep| routine installs a dependency list~|p| into the value node~|q|,
12386 linking it into the list of all known dependencies. We assume that
12387 |dep_final| points to the final node of list~|p|.
12389 @c void mp_new_dep (MP mp,pointer q, pointer p) {
12390 pointer r; /* what used to be the first dependency */
12391 dep_list(q)=p; prev_dep(q)=dep_head;
12392 r=link(dep_head); link(mp->dep_final)=r; prev_dep(r)=mp->dep_final;
12396 @ Here is one of the ways a dependency list gets started.
12397 The |const_dependency| routine produces a list that has nothing but
12400 @c pointer mp_const_dependency (MP mp, scaled v) {
12401 mp->dep_final=mp_get_node(mp, dep_node_size);
12402 value(mp->dep_final)=v; info(mp->dep_final)=null;
12403 return mp->dep_final;
12406 @ And here's a more interesting way to start a dependency list from scratch:
12407 The parameter to |single_dependency| is the location of an
12408 independent variable~|x|, and the result is the simple dependency list
12411 In the unlikely event that the given independent variable has been doubled so
12412 often that we can't refer to it with a nonzero coefficient,
12413 |single_dependency| returns the simple list `0'. This case can be
12414 recognized by testing that the returned list pointer is equal to
12417 @c pointer mp_single_dependency (MP mp,pointer p) {
12418 pointer q; /* the new dependency list */
12419 integer m; /* the number of doublings */
12420 m=value(p) % s_scale;
12422 return mp_const_dependency(mp, 0);
12424 q=mp_get_node(mp, dep_node_size);
12425 value(q)=two_to_the(28-m); info(q)=p;
12426 link(q)=mp_const_dependency(mp, 0);
12431 @ We sometimes need to make an exact copy of a dependency list.
12433 @c pointer mp_copy_dep_list (MP mp,pointer p) {
12434 pointer q; /* the new dependency list */
12435 q=mp_get_node(mp, dep_node_size); mp->dep_final=q;
12437 info(mp->dep_final)=info(p); value(mp->dep_final)=value(p);
12438 if ( info(mp->dep_final)==null ) break;
12439 link(mp->dep_final)=mp_get_node(mp, dep_node_size);
12440 mp->dep_final=link(mp->dep_final); p=link(p);
12445 @ But how do variables normally become known? Ah, now we get to the heart of the
12446 equation-solving mechanism. The |linear_eq| procedure is given a |dependent|
12447 or |mp_proto_dependent| list,~|p|, in which at least one independent variable
12448 appears. It equates this list to zero, by choosing an independent variable
12449 with the largest coefficient and making it dependent on the others. The
12450 newly dependent variable is eliminated from all current dependencies,
12451 thereby possibly making other dependent variables known.
12453 The given list |p| is, of course, totally destroyed by all this processing.
12455 @c void mp_linear_eq (MP mp, pointer p, small_number t) {
12456 pointer q,r,s; /* for link manipulation */
12457 pointer x; /* the variable that loses its independence */
12458 integer n; /* the number of times |x| had been halved */
12459 integer v; /* the coefficient of |x| in list |p| */
12460 pointer prev_r; /* lags one step behind |r| */
12461 pointer final_node; /* the constant term of the new dependency list */
12462 integer w; /* a tentative coefficient */
12463 @<Find a node |q| in list |p| whose coefficient |v| is largest@>;
12464 x=info(q); n=value(x) % s_scale;
12465 @<Divide list |p| by |-v|, removing node |q|@>;
12466 if ( mp->internal[mp_tracing_equations]>0 ) {
12467 @<Display the new dependency@>;
12469 @<Simplify all existing dependencies by substituting for |x|@>;
12470 @<Change variable |x| from |independent| to |dependent| or |known|@>;
12471 if ( mp->fix_needed ) mp_fix_dependencies(mp);
12474 @ @<Find a node |q| in list |p| whose coefficient |v| is largest@>=
12475 q=p; r=link(p); v=value(q);
12476 while ( info(r)!=null ) {
12477 if ( abs(value(r))>abs(v) ) { q=r; v=value(r); };
12481 @ Here we want to change the coefficients from |scaled| to |fraction|,
12482 except in the constant term. In the common case of a trivial equation
12483 like `\.{x=3.14}', we will have |v=-fraction_one|, |q=p|, and |t=mp_dependent|.
12485 @<Divide list |p| by |-v|, removing node |q|@>=
12486 s=temp_head; link(s)=p; r=p;
12489 link(s)=link(r); mp_free_node(mp, r,dep_node_size);
12491 w=mp_make_fraction(mp, value(r),v);
12492 if ( abs(w)<=half_fraction_threshold ) {
12493 link(s)=link(r); mp_free_node(mp, r,dep_node_size);
12499 } while (info(r)!=null);
12500 if ( t==mp_proto_dependent ) {
12501 value(r)=-mp_make_scaled(mp, value(r),v);
12502 } else if ( v!=-fraction_one ) {
12503 value(r)=-mp_make_fraction(mp, value(r),v);
12505 final_node=r; p=link(temp_head)
12507 @ @<Display the new dependency@>=
12508 if ( mp_interesting(mp, x) ) {
12509 mp_begin_diagnostic(mp); mp_print_nl(mp, "## ");
12510 mp_print_variable_name(mp, x);
12511 @:]]]\#\#_}{\.{\#\#}@>
12513 while ( w>0 ) { mp_print(mp, "*4"); w=w-2; };
12514 mp_print_char(mp, '='); mp_print_dependency(mp, p,mp_dependent);
12515 mp_end_diagnostic(mp, false);
12518 @ @<Simplify all existing dependencies by substituting for |x|@>=
12519 prev_r=dep_head; r=link(dep_head);
12520 while ( r!=dep_head ) {
12521 s=dep_list(r); q=mp_p_with_x_becoming_q(mp, s,x,p,type(r));
12522 if ( info(q)==null ) {
12523 mp_make_known(mp, r,q);
12526 do { q=link(q); } while (info(q)!=null);
12532 @ @<Change variable |x| from |independent| to |dependent| or |known|@>=
12533 if ( n>0 ) @<Divide list |p| by $2^n$@>;
12534 if ( info(p)==null ) {
12537 if ( abs(value(x))>=fraction_one ) mp_val_too_big(mp, value(x));
12538 mp_free_node(mp, p,dep_node_size);
12539 if ( mp->cur_exp==x ) if ( mp->cur_type==mp_independent ) {
12540 mp->cur_exp=value(x); mp->cur_type=mp_known;
12541 mp_free_node(mp, x,value_node_size);
12544 type(x)=mp_dependent; mp->dep_final=final_node; mp_new_dep(mp, x,p);
12545 if ( mp->cur_exp==x ) if ( mp->cur_type==mp_independent ) mp->cur_type=mp_dependent;
12548 @ @<Divide list |p| by $2^n$@>=
12550 s=temp_head; link(temp_head)=p; r=p;
12553 else w=value(r) / two_to_the(n);
12554 if ( (abs(w)<=half_fraction_threshold)&&(info(r)!=null) ) {
12556 mp_free_node(mp, r,dep_node_size);
12561 } while (info(s)!=null);
12565 @ The |check_mem| procedure, which is used only when \MP\ is being
12566 debugged, makes sure that the current dependency lists are well formed.
12568 @<Check the list of linear dependencies@>=
12569 q=dep_head; p=link(q);
12570 while ( p!=dep_head ) {
12571 if ( prev_dep(p)!=q ) {
12572 mp_print_nl(mp, "Bad PREVDEP at "); mp_print_int(mp, p);
12577 r=info(p); q=p; p=link(q);
12578 if ( r==null ) break;
12579 if ( value(info(p))>=value(r) ) {
12580 mp_print_nl(mp, "Out of order at "); mp_print_int(mp, p);
12581 @.Out of order...@>
12586 @* \[25] Dynamic nonlinear equations.
12587 Variables of numeric type are maintained by the general scheme of
12588 independent, dependent, and known values that we have just studied;
12589 and the components of pair and transform variables are handled in the
12590 same way. But \MP\ also has five other types of values: \&{boolean},
12591 \&{string}, \&{pen}, \&{path}, and \&{picture}; what about them?
12593 Equations are allowed between nonlinear quantities, but only in a
12594 simple form. Two variables that haven't yet been assigned values are
12595 either equal to each other, or they're not.
12597 Before a boolean variable has received a value, its type is |mp_unknown_boolean|;
12598 similarly, there are variables whose type is |mp_unknown_string|, |mp_unknown_pen|,
12599 |mp_unknown_path|, and |mp_unknown_picture|. In such cases the value is either
12600 |null| (which means that no other variables are equivalent to this one), or
12601 it points to another variable of the same undefined type. The pointers in the
12602 latter case form a cycle of nodes, which we shall call a ``ring.''
12603 Rings of undefined variables may include capsules, which arise as
12604 intermediate results within expressions or as \&{expr} parameters to macros.
12606 When one member of a ring receives a value, the same value is given to
12607 all the other members. In the case of paths and pictures, this implies
12608 making separate copies of a potentially large data structure; users should
12609 restrain their enthusiasm for such generality, unless they have lots and
12610 lots of memory space.
12612 @ The following procedure is called when a capsule node is being
12613 added to a ring (e.g., when an unknown variable is mentioned in an expression).
12615 @c pointer mp_new_ring_entry (MP mp,pointer p) {
12616 pointer q; /* the new capsule node */
12617 q=mp_get_node(mp, value_node_size); name_type(q)=mp_capsule;
12619 if ( value(p)==null ) value(q)=p; else value(q)=value(p);
12624 @ Conversely, we might delete a capsule or a variable before it becomes known.
12625 The following procedure simply detaches a quantity from its ring,
12626 without recycling the storage.
12628 @<Declare the recycling subroutines@>=
12629 void mp_ring_delete (MP mp,pointer p) {
12632 if ( q!=null ) if ( q!=p ){
12633 while ( value(q)!=p ) q=value(q);
12638 @ Eventually there might be an equation that assigns values to all of the
12639 variables in a ring. The |nonlinear_eq| subroutine does the necessary
12640 propagation of values.
12642 If the parameter |flush_p| is |true|, node |p| itself needn't receive a
12643 value, it will soon be recycled.
12645 @c void mp_nonlinear_eq (MP mp,integer v, pointer p, boolean flush_p) {
12646 small_number t; /* the type of ring |p| */
12647 pointer q,r; /* link manipulation registers */
12648 t=type(p)-unknown_tag; q=value(p);
12649 if ( flush_p ) type(p)=mp_vacuous; else p=q;
12651 r=value(q); type(q)=t;
12653 case mp_boolean_type: value(q)=v; break;
12654 case mp_string_type: value(q)=v; add_str_ref(v); break;
12655 case mp_pen_type: value(q)=copy_pen(v); break;
12656 case mp_path_type: value(q)=mp_copy_path(mp, v); break;
12657 case mp_picture_type: value(q)=v; add_edge_ref(v); break;
12658 } /* there ain't no more cases */
12663 @ If two members of rings are equated, and if they have the same type,
12664 the |ring_merge| procedure is called on to make them equivalent.
12666 @c void mp_ring_merge (MP mp,pointer p, pointer q) {
12667 pointer r; /* traverses one list */
12671 @<Exclaim about a redundant equation@>;
12676 r=value(p); value(p)=value(q); value(q)=r;
12679 @ @<Exclaim about a redundant equation@>=
12681 print_err("Redundant equation");
12682 @.Redundant equation@>
12683 help2("I already knew that this equation was true.")
12684 ("But perhaps no harm has been done; let's continue.");
12685 mp_put_get_error(mp);
12688 @* \[26] Introduction to the syntactic routines.
12689 Let's pause a moment now and try to look at the Big Picture.
12690 The \MP\ program consists of three main parts: syntactic routines,
12691 semantic routines, and output routines. The chief purpose of the
12692 syntactic routines is to deliver the user's input to the semantic routines,
12693 while parsing expressions and locating operators and operands. The
12694 semantic routines act as an interpreter responding to these operators,
12695 which may be regarded as commands. And the output routines are
12696 periodically called on to produce compact font descriptions that can be
12697 used for typesetting or for making interim proof drawings. We have
12698 discussed the basic data structures and many of the details of semantic
12699 operations, so we are good and ready to plunge into the part of \MP\ that
12700 actually controls the activities.
12702 Our current goal is to come to grips with the |get_next| procedure,
12703 which is the keystone of \MP's input mechanism. Each call of |get_next|
12704 sets the value of three variables |cur_cmd|, |cur_mod|, and |cur_sym|,
12705 representing the next input token.
12706 $$\vbox{\halign{#\hfil\cr
12707 \hbox{|cur_cmd| denotes a command code from the long list of codes
12709 \hbox{|cur_mod| denotes a modifier of the command code;}\cr
12710 \hbox{|cur_sym| is the hash address of the symbolic token that was
12712 \hbox{\qquad or zero in the case of a numeric or string
12713 or capsule token.}\cr}}$$
12714 Underlying this external behavior of |get_next| is all the machinery
12715 necessary to convert from character files to tokens. At a given time we
12716 may be only partially finished with the reading of several files (for
12717 which \&{input} was specified), and partially finished with the expansion
12718 of some user-defined macros and/or some macro parameters, and partially
12719 finished reading some text that the user has inserted online,
12720 and so on. When reading a character file, the characters must be
12721 converted to tokens; comments and blank spaces must
12722 be removed, numeric and string tokens must be evaluated.
12724 To handle these situations, which might all be present simultaneously,
12725 \MP\ uses various stacks that hold information about the incomplete
12726 activities, and there is a finite state control for each level of the
12727 input mechanism. These stacks record the current state of an implicitly
12728 recursive process, but the |get_next| procedure is not recursive.
12731 eight_bits cur_cmd; /* current command set by |get_next| */
12732 integer cur_mod; /* operand of current command */
12733 halfword cur_sym; /* hash address of current symbol */
12735 @ The |print_cmd_mod| routine prints a symbolic interpretation of a
12736 command code and its modifier.
12737 It consists of a rather tedious sequence of print
12738 commands, and most of it is essentially an inverse to the |primitive|
12739 routine that enters a \MP\ primitive into |hash| and |eqtb|. Therefore almost
12740 all of this procedure appears elsewhere in the program, together with the
12741 corresponding |primitive| calls.
12743 @<Declare the procedure called |print_cmd_mod|@>=
12744 void mp_print_cmd_mod (MP mp,integer c, integer m) {
12746 @<Cases of |print_cmd_mod| for symbolic printing of primitives@>
12747 default: mp_print(mp, "[unknown command code!]"); break;
12751 @ Here is a procedure that displays a given command in braces, in the
12752 user's transcript file.
12754 @d show_cur_cmd_mod mp_show_cmd_mod(mp, mp->cur_cmd,mp->cur_mod)
12757 void mp_show_cmd_mod (MP mp,integer c, integer m) {
12758 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
12759 mp_print_cmd_mod(mp, c,m); mp_print_char(mp, '}');
12760 mp_end_diagnostic(mp, false);
12763 @* \[27] Input stacks and states.
12764 The state of \MP's input mechanism appears in the input stack, whose
12765 entries are records with five fields, called |index|, |start|, |loc|,
12766 |limit|, and |name|. The top element of this stack is maintained in a
12767 global variable for which no subscripting needs to be done; the other
12768 elements of the stack appear in an array. Hence the stack is declared thus:
12772 quarterword index_field;
12773 halfword start_field, loc_field, limit_field, name_field;
12777 in_state_record *input_stack;
12778 integer input_ptr; /* first unused location of |input_stack| */
12779 integer max_in_stack; /* largest value of |input_ptr| when pushing */
12780 in_state_record cur_input; /* the ``top'' input state */
12781 int stack_size; /* maximum number of simultaneous input sources */
12783 @ @<Allocate or initialize ...@>=
12784 mp->stack_size = 300;
12785 mp->input_stack = xmalloc((mp->stack_size+1),sizeof(in_state_record));
12787 @ @<Dealloc variables@>=
12788 xfree(mp->input_stack);
12790 @ We've already defined the special variable |loc==cur_input.loc_field|
12791 in our discussion of basic input-output routines. The other components of
12792 |cur_input| are defined in the same way:
12794 @d iindex mp->cur_input.index_field /* reference for buffer information */
12795 @d start mp->cur_input.start_field /* starting position in |buffer| */
12796 @d limit mp->cur_input.limit_field /* end of current line in |buffer| */
12797 @d name mp->cur_input.name_field /* name of the current file */
12799 @ Let's look more closely now at the five control variables
12800 (|index|,~|start|,~|loc|,~|limit|,~|name|),
12801 assuming that \MP\ is reading a line of characters that have been input
12802 from some file or from the user's terminal. There is an array called
12803 |buffer| that acts as a stack of all lines of characters that are
12804 currently being read from files, including all lines on subsidiary
12805 levels of the input stack that are not yet completed. \MP\ will return to
12806 the other lines when it is finished with the present input file.
12808 (Incidentally, on a machine with byte-oriented addressing, it would be
12809 appropriate to combine |buffer| with the |str_pool| array,
12810 letting the buffer entries grow downward from the top of the string pool
12811 and checking that these two tables don't bump into each other.)
12813 The line we are currently working on begins in position |start| of the
12814 buffer; the next character we are about to read is |buffer[loc]|; and
12815 |limit| is the location of the last character present. We always have
12816 |loc<=limit|. For convenience, |buffer[limit]| has been set to |"%"|, so
12817 that the end of a line is easily sensed.
12819 The |name| variable is a string number that designates the name of
12820 the current file, if we are reading an ordinary text file. Special codes
12821 |is_term..max_spec_src| indicate other sources of input text.
12823 @d is_term 0 /* |name| value when reading from the terminal for normal input */
12824 @d is_read 1 /* |name| value when executing a \&{readstring} or \&{readfrom} */
12825 @d is_scantok 2 /* |name| value when reading text generated by \&{scantokens} */
12826 @d max_spec_src is_scantok
12828 @ Additional information about the current line is available via the
12829 |index| variable, which counts how many lines of characters are present
12830 in the buffer below the current level. We have |index=0| when reading
12831 from the terminal and prompting the user for each line; then if the user types,
12832 e.g., `\.{input figs}', we will have |index=1| while reading
12833 the file \.{figs.mp}. However, it does not follow that |index| is the
12834 same as the input stack pointer, since many of the levels on the input
12835 stack may come from token lists and some |index| values may correspond
12836 to \.{MPX} files that are not currently on the stack.
12838 The global variable |in_open| is equal to the highest |index| value counting
12839 \.{MPX} files but excluding token-list input levels. Thus, the number of
12840 partially read lines in the buffer is |in_open+1| and we have |in_open>=index|
12841 when we are not reading a token list.
12843 If we are not currently reading from the terminal,
12844 we are reading from the file variable |input_file[index]|. We use
12845 the notation |terminal_input| as a convenient abbreviation for |name=is_term|,
12846 and |cur_file| as an abbreviation for |input_file[index]|.
12848 When \MP\ is not reading from the terminal, the global variable |line| contains
12849 the line number in the current file, for use in error messages. More precisely,
12850 |line| is a macro for |line_stack[index]| and the |line_stack| array gives
12851 the line number for each file in the |input_file| array.
12853 When an \.{MPX} file is opened the file name is stored in the |mpx_name|
12854 array so that the name doesn't get lost when the file is temporarily removed
12855 from the input stack.
12856 Thus when |input_file[k]| is an \.{MPX} file, its name is |mpx_name[k]|
12857 and it contains translated \TeX\ pictures for |input_file[k-1]|.
12858 Since this is not an \.{MPX} file, we have
12859 $$ \hbox{|mpx_name[k-1]<=absent|}. $$
12860 This |name| field is set to |finished| when |input_file[k]| is completely
12863 If more information about the input state is needed, it can be
12864 included in small arrays like those shown here. For example,
12865 the current page or segment number in the input file might be put
12866 into a variable |page|, that is really a macro for the current entry
12867 in `\ignorespaces|page_stack:array[0..max_in_open] of integer|\unskip'
12868 by analogy with |line_stack|.
12869 @^system dependencies@>
12871 @d terminal_input (name==is_term) /* are we reading from the terminal? */
12872 @d cur_file mp->input_file[iindex] /* the current |void *| variable */
12873 @d line mp->line_stack[iindex] /* current line number in the current source file */
12874 @d in_name mp->iname_stack[iindex] /* a string used to construct \.{MPX} file names */
12875 @d in_area mp->iarea_stack[iindex] /* another string for naming \.{MPX} files */
12876 @d absent 1 /* |name_field| value for unused |mpx_in_stack| entries */
12877 @d mpx_reading (mp->mpx_name[iindex]>absent)
12878 /* when reading a file, is it an \.{MPX} file? */
12880 /* |name_field| value when the corresponding \.{MPX} file is finished */
12883 integer in_open; /* the number of lines in the buffer, less one */
12884 unsigned int open_parens; /* the number of open text files */
12885 void * *input_file ;
12886 integer *line_stack ; /* the line number for each file */
12887 char * *iname_stack; /* used for naming \.{MPX} files */
12888 char * *iarea_stack; /* used for naming \.{MPX} files */
12889 halfword*mpx_name ;
12891 @ @<Allocate or ...@>=
12892 mp->input_file = xmalloc((mp->max_in_open+1),sizeof(void *));
12893 mp->line_stack = xmalloc((mp->max_in_open+1),sizeof(integer));
12894 mp->iname_stack = xmalloc((mp->max_in_open+1),sizeof(char *));
12895 mp->iarea_stack = xmalloc((mp->max_in_open+1),sizeof(char *));
12896 mp->mpx_name = xmalloc((mp->max_in_open+1),sizeof(halfword));
12899 for (k=0;k<=mp->max_in_open;k++) {
12900 mp->iname_stack[k] =NULL;
12901 mp->iarea_stack[k] =NULL;
12905 @ @<Dealloc variables@>=
12908 for (l=0;l<=mp->max_in_open;l++) {
12909 xfree(mp->iname_stack[l]);
12910 xfree(mp->iarea_stack[l]);
12913 xfree(mp->input_file);
12914 xfree(mp->line_stack);
12915 xfree(mp->iname_stack);
12916 xfree(mp->iarea_stack);
12917 xfree(mp->mpx_name);
12920 @ However, all this discussion about input state really applies only to the
12921 case that we are inputting from a file. There is another important case,
12922 namely when we are currently getting input from a token list. In this case
12923 |iindex>max_in_open|, and the conventions about the other state variables
12926 \yskip\hang|loc| is a pointer to the current node in the token list, i.e.,
12927 the node that will be read next. If |loc=null|, the token list has been
12930 \yskip\hang|start| points to the first node of the token list; this node
12931 may or may not contain a reference count, depending on the type of token
12934 \yskip\hang|token_type|, which takes the place of |iindex| in the
12935 discussion above, is a code number that explains what kind of token list
12938 \yskip\hang|name| points to the |eqtb| address of the control sequence
12939 being expanded, if the current token list is a macro not defined by
12940 \&{vardef}. Macros defined by \&{vardef} have |name=null|; their name
12941 can be deduced by looking at their first two parameters.
12943 \yskip\hang|param_start|, which takes the place of |limit|, tells where
12944 the parameters of the current macro or loop text begin in the |param_stack|.
12946 \yskip\noindent The |token_type| can take several values, depending on
12947 where the current token list came from:
12950 \indent|forever_text|, if the token list being scanned is the body of
12951 a \&{forever} loop;
12953 \indent|loop_text|, if the token list being scanned is the body of
12954 a \&{for} or \&{forsuffixes} loop;
12956 \indent|parameter|, if a \&{text} or \&{suffix} parameter is being scanned;
12958 \indent|backed_up|, if the token list being scanned has been inserted as
12959 `to be read again'.
12961 \indent|inserted|, if the token list being scanned has been inserted as
12962 part of error recovery;
12964 \indent|macro|, if the expansion of a user-defined symbolic token is being
12968 The token list begins with a reference count if and only if |token_type=
12970 @^reference counts@>
12972 @d token_type iindex /* type of current token list */
12973 @d token_state (iindex>(int)mp->max_in_open) /* are we scanning a token list? */
12974 @d file_state (iindex<=(int)mp->max_in_open) /* are we scanning a file line? */
12975 @d param_start limit /* base of macro parameters in |param_stack| */
12976 @d forever_text (mp->max_in_open+1) /* |token_type| code for loop texts */
12977 @d loop_text (mp->max_in_open+2) /* |token_type| code for loop texts */
12978 @d parameter (mp->max_in_open+3) /* |token_type| code for parameter texts */
12979 @d backed_up (mp->max_in_open+4) /* |token_type| code for texts to be reread */
12980 @d inserted (mp->max_in_open+5) /* |token_type| code for inserted texts */
12981 @d macro (mp->max_in_open+6) /* |token_type| code for macro replacement texts */
12983 @ The |param_stack| is an auxiliary array used to hold pointers to the token
12984 lists for parameters at the current level and subsidiary levels of input.
12985 This stack grows at a different rate from the others.
12988 pointer *param_stack; /* token list pointers for parameters */
12989 integer param_ptr; /* first unused entry in |param_stack| */
12990 integer max_param_stack; /* largest value of |param_ptr| */
12992 @ @<Allocate or initialize ...@>=
12993 mp->param_stack = xmalloc((mp->param_size+1),sizeof(pointer));
12995 @ @<Dealloc variables@>=
12996 xfree(mp->param_stack);
12998 @ Notice that the |line| isn't valid when |token_state| is true because it
12999 depends on |iindex|. If we really need to know the line number for the
13000 topmost file in the iindex stack we use the following function. If a page
13001 number or other information is needed, this routine should be modified to
13002 compute it as well.
13003 @^system dependencies@>
13005 @<Declare a function called |true_line|@>=
13006 integer mp_true_line (MP mp) {
13007 int k; /* an index into the input stack */
13008 if ( file_state && (name>max_spec_src) ) {
13013 ((mp->input_stack[(k-1)].index_field>mp->max_in_open)||
13014 (mp->input_stack[(k-1)].name_field<=max_spec_src))) {
13017 return (k>0 ? mp->line_stack[(k-1)] : 0 );
13021 @ Thus, the ``current input state'' can be very complicated indeed; there
13022 can be many levels and each level can arise in a variety of ways. The
13023 |show_context| procedure, which is used by \MP's error-reporting routine to
13024 print out the current input state on all levels down to the most recent
13025 line of characters from an input file, illustrates most of these conventions.
13026 The global variable |file_ptr| contains the lowest level that was
13027 displayed by this procedure.
13030 integer file_ptr; /* shallowest level shown by |show_context| */
13032 @ The status at each level is indicated by printing two lines, where the first
13033 line indicates what was read so far and the second line shows what remains
13034 to be read. The context is cropped, if necessary, so that the first line
13035 contains at most |half_error_line| characters, and the second contains
13036 at most |error_line|. Non-current input levels whose |token_type| is
13037 `|backed_up|' are shown only if they have not been fully read.
13039 @c void mp_show_context (MP mp) { /* prints where the scanner is */
13040 int old_setting; /* saved |selector| setting */
13041 @<Local variables for formatting calculations@>
13042 mp->file_ptr=mp->input_ptr; mp->input_stack[mp->file_ptr]=mp->cur_input;
13043 /* store current state */
13045 mp->cur_input=mp->input_stack[mp->file_ptr]; /* enter into the context */
13046 @<Display the current context@>;
13048 if ( (name>max_spec_src) || (mp->file_ptr==0) ) break;
13049 decr(mp->file_ptr);
13051 mp->cur_input=mp->input_stack[mp->input_ptr]; /* restore original state */
13054 @ @<Display the current context@>=
13055 if ( (mp->file_ptr==mp->input_ptr) || file_state ||
13056 (token_type!=backed_up) || (loc!=null) ) {
13057 /* we omit backed-up token lists that have already been read */
13058 mp->tally=0; /* get ready to count characters */
13059 old_setting=mp->selector;
13060 if ( file_state ) {
13061 @<Print location of current line@>;
13062 @<Pseudoprint the line@>;
13064 @<Print type of token list@>;
13065 @<Pseudoprint the token list@>;
13067 mp->selector=old_setting; /* stop pseudoprinting */
13068 @<Print two lines using the tricky pseudoprinted information@>;
13071 @ This routine should be changed, if necessary, to give the best possible
13072 indication of where the current line resides in the input file.
13073 For example, on some systems it is best to print both a page and line number.
13074 @^system dependencies@>
13076 @<Print location of current line@>=
13077 if ( name>max_spec_src ) {
13078 mp_print_nl(mp, "l."); mp_print_int(mp, mp_true_line(mp));
13079 } else if ( terminal_input ) {
13080 if ( mp->file_ptr==0 ) mp_print_nl(mp, "<*>");
13081 else mp_print_nl(mp, "<insert>");
13082 } else if ( name==is_scantok ) {
13083 mp_print_nl(mp, "<scantokens>");
13085 mp_print_nl(mp, "<read>");
13087 mp_print_char(mp, ' ')
13089 @ Can't use case statement here because the |token_type| is not
13090 a constant expression.
13092 @<Print type of token list@>=
13094 if(token_type==forever_text) {
13095 mp_print_nl(mp, "<forever> ");
13096 } else if (token_type==loop_text) {
13097 @<Print the current loop value@>;
13098 } else if (token_type==parameter) {
13099 mp_print_nl(mp, "<argument> ");
13100 } else if (token_type==backed_up) {
13101 if ( loc==null ) mp_print_nl(mp, "<recently read> ");
13102 else mp_print_nl(mp, "<to be read again> ");
13103 } else if (token_type==inserted) {
13104 mp_print_nl(mp, "<inserted text> ");
13105 } else if (token_type==macro) {
13107 if ( name!=null ) mp_print_text(name);
13108 else @<Print the name of a \&{vardef}'d macro@>;
13109 mp_print(mp, "->");
13111 mp_print_nl(mp, "?");/* this should never happen */
13116 @ The parameter that corresponds to a loop text is either a token list
13117 (in the case of \&{forsuffixes}) or a ``capsule'' (in the case of \&{for}).
13118 We'll discuss capsules later; for now, all we need to know is that
13119 the |link| field in a capsule parameter is |void| and that
13120 |print_exp(p,0)| displays the value of capsule~|p| in abbreviated form.
13122 @<Print the current loop value@>=
13123 { mp_print_nl(mp, "<for("); p=mp->param_stack[param_start];
13125 if ( link(p)==mp_void ) mp_print_exp(mp, p,0); /* we're in a \&{for} loop */
13126 else mp_show_token_list(mp, p,null,20,mp->tally);
13128 mp_print(mp, ")> ");
13131 @ The first two parameters of a macro defined by \&{vardef} will be token
13132 lists representing the macro's prefix and ``at point.'' By putting these
13133 together, we get the macro's full name.
13135 @<Print the name of a \&{vardef}'d macro@>=
13136 { p=mp->param_stack[param_start];
13138 mp_show_token_list(mp, mp->param_stack[param_start+1],null,20,mp->tally);
13141 while ( link(q)!=null ) q=link(q);
13142 link(q)=mp->param_stack[param_start+1];
13143 mp_show_token_list(mp, p,null,20,mp->tally);
13148 @ Now it is necessary to explain a little trick. We don't want to store a long
13149 string that corresponds to a token list, because that string might take up
13150 lots of memory; and we are printing during a time when an error message is
13151 being given, so we dare not do anything that might overflow one of \MP's
13152 tables. So `pseudoprinting' is the answer: We enter a mode of printing
13153 that stores characters into a buffer of length |error_line|, where character
13154 $k+1$ is placed into \hbox{|trick_buf[k mod error_line]|} if
13155 |k<trick_count|, otherwise character |k| is dropped. Initially we set
13156 |tally:=0| and |trick_count:=1000000|; then when we reach the
13157 point where transition from line 1 to line 2 should occur, we
13158 set |first_count:=tally| and |trick_count:=@tmax@>(error_line,
13159 tally+1+error_line-half_error_line)|. At the end of the
13160 pseudoprinting, the values of |first_count|, |tally|, and
13161 |trick_count| give us all the information we need to print the two lines,
13162 and all of the necessary text is in |trick_buf|.
13164 Namely, let |l| be the length of the descriptive information that appears
13165 on the first line. The length of the context information gathered for that
13166 line is |k=first_count|, and the length of the context information
13167 gathered for line~2 is $m=\min(|tally|, |trick_count|)-k$. If |l+k<=h|,
13168 where |h=half_error_line|, we print |trick_buf[0..k-1]| after the
13169 descriptive information on line~1, and set |n:=l+k|; here |n| is the
13170 length of line~1. If $l+k>h$, some cropping is necessary, so we set |n:=h|
13171 and print `\.{...}' followed by
13172 $$\hbox{|trick_buf[(l+k-h+3)..k-1]|,}$$
13173 where subscripts of |trick_buf| are circular modulo |error_line|. The
13174 second line consists of |n|~spaces followed by |trick_buf[k..(k+m-1)]|,
13175 unless |n+m>error_line|; in the latter case, further cropping is done.
13176 This is easier to program than to explain.
13178 @<Local variables for formatting...@>=
13179 int i; /* index into |buffer| */
13180 integer l; /* length of descriptive information on line 1 */
13181 integer m; /* context information gathered for line 2 */
13182 int n; /* length of line 1 */
13183 integer p; /* starting or ending place in |trick_buf| */
13184 integer q; /* temporary index */
13186 @ The following code tells the print routines to gather
13187 the desired information.
13189 @d begin_pseudoprint {
13190 l=mp->tally; mp->tally=0; mp->selector=pseudo;
13191 mp->trick_count=1000000;
13193 @d set_trick_count {
13194 mp->first_count=mp->tally;
13195 mp->trick_count=mp->tally+1+mp->error_line-mp->half_error_line;
13196 if ( mp->trick_count<mp->error_line ) mp->trick_count=mp->error_line;
13199 @ And the following code uses the information after it has been gathered.
13201 @<Print two lines using the tricky pseudoprinted information@>=
13202 if ( mp->trick_count==1000000 ) set_trick_count;
13203 /* |set_trick_count| must be performed */
13204 if ( mp->tally<mp->trick_count ) m=mp->tally-mp->first_count;
13205 else m=mp->trick_count-mp->first_count; /* context on line 2 */
13206 if ( l+mp->first_count<=mp->half_error_line ) {
13207 p=0; n=l+mp->first_count;
13209 mp_print(mp, "..."); p=l+mp->first_count-mp->half_error_line+3;
13210 n=mp->half_error_line;
13212 for (q=p;q<=mp->first_count-1;q++) {
13213 mp_print_char(mp, mp->trick_buf[q % mp->error_line]);
13216 for (q=1;q<=n;q++) {
13217 mp_print_char(mp, ' '); /* print |n| spaces to begin line~2 */
13219 if ( m+n<=mp->error_line ) p=mp->first_count+m;
13220 else p=mp->first_count+(mp->error_line-n-3);
13221 for (q=mp->first_count;q<=p-1;q++) {
13222 mp_print_char(mp, mp->trick_buf[q % mp->error_line]);
13224 if ( m+n>mp->error_line ) mp_print(mp, "...")
13226 @ But the trick is distracting us from our current goal, which is to
13227 understand the input state. So let's concentrate on the data structures that
13228 are being pseudoprinted as we finish up the |show_context| procedure.
13230 @<Pseudoprint the line@>=
13233 for (i=start;i<=limit-1;i++) {
13234 if ( i==loc ) set_trick_count;
13235 mp_print_str(mp, mp->buffer[i]);
13239 @ @<Pseudoprint the token list@>=
13241 if ( token_type!=macro ) mp_show_token_list(mp, start,loc,100000,0);
13242 else mp_show_macro(mp, start,loc,100000)
13244 @ Here is the missing piece of |show_token_list| that is activated when the
13245 token beginning line~2 is about to be shown:
13247 @<Do magic computation@>=set_trick_count
13249 @* \[28] Maintaining the input stacks.
13250 The following subroutines change the input status in commonly needed ways.
13252 First comes |push_input|, which stores the current state and creates a
13253 new level (having, initially, the same properties as the old).
13255 @d push_input { /* enter a new input level, save the old */
13256 if ( mp->input_ptr>mp->max_in_stack ) {
13257 mp->max_in_stack=mp->input_ptr;
13258 if ( mp->input_ptr==mp->stack_size ) {
13259 int l = (mp->stack_size+(mp->stack_size>>2));
13260 XREALLOC(mp->input_stack, l, in_state_record);
13261 mp->stack_size = l;
13264 mp->input_stack[mp->input_ptr]=mp->cur_input; /* stack the record */
13265 incr(mp->input_ptr);
13268 @ And of course what goes up must come down.
13270 @d pop_input { /* leave an input level, re-enter the old */
13271 decr(mp->input_ptr); mp->cur_input=mp->input_stack[mp->input_ptr];
13274 @ Here is a procedure that starts a new level of token-list input, given
13275 a token list |p| and its type |t|. If |t=macro|, the calling routine should
13276 set |name|, reset~|loc|, and increase the macro's reference count.
13278 @d back_list(A) mp_begin_token_list(mp, (A),backed_up) /* backs up a simple token list */
13280 @c void mp_begin_token_list (MP mp,pointer p, quarterword t) {
13281 push_input; start=p; token_type=t;
13282 param_start=mp->param_ptr; loc=p;
13285 @ When a token list has been fully scanned, the following computations
13286 should be done as we leave that level of input.
13289 @c void mp_end_token_list (MP mp) { /* leave a token-list input level */
13290 pointer p; /* temporary register */
13291 if ( token_type>=backed_up ) { /* token list to be deleted */
13292 if ( token_type<=inserted ) {
13293 mp_flush_token_list(mp, start); goto DONE;
13295 mp_delete_mac_ref(mp, start); /* update reference count */
13298 while ( mp->param_ptr>param_start ) { /* parameters must be flushed */
13299 decr(mp->param_ptr);
13300 p=mp->param_stack[mp->param_ptr];
13302 if ( link(p)==mp_void ) { /* it's an \&{expr} parameter */
13303 mp_recycle_value(mp, p); mp_free_node(mp, p,value_node_size);
13305 mp_flush_token_list(mp, p); /* it's a \&{suffix} or \&{text} parameter */
13310 pop_input; check_interrupt;
13313 @ The contents of |cur_cmd,cur_mod,cur_sym| are placed into an equivalent
13314 token by the |cur_tok| routine.
13317 @c @<Declare the procedure called |make_exp_copy|@>
13318 pointer mp_cur_tok (MP mp) {
13319 pointer p; /* a new token node */
13320 small_number save_type; /* |cur_type| to be restored */
13321 integer save_exp; /* |cur_exp| to be restored */
13322 if ( mp->cur_sym==0 ) {
13323 if ( mp->cur_cmd==capsule_token ) {
13324 save_type=mp->cur_type; save_exp=mp->cur_exp;
13325 mp_make_exp_copy(mp, mp->cur_mod); p=mp_stash_cur_exp(mp); link(p)=null;
13326 mp->cur_type=save_type; mp->cur_exp=save_exp;
13328 p=mp_get_node(mp, token_node_size);
13329 value(p)=mp->cur_mod; name_type(p)=mp_token;
13330 if ( mp->cur_cmd==numeric_token ) type(p)=mp_known;
13331 else type(p)=mp_string_type;
13334 fast_get_avail(p); info(p)=mp->cur_sym;
13339 @ Sometimes \MP\ has read too far and wants to ``unscan'' what it has
13340 seen. The |back_input| procedure takes care of this by putting the token
13341 just scanned back into the input stream, ready to be read again.
13342 If |cur_sym<>0|, the values of |cur_cmd| and |cur_mod| are irrelevant.
13345 void mp_back_input (MP mp);
13347 @ @c void mp_back_input (MP mp) {/* undoes one token of input */
13348 pointer p; /* a token list of length one */
13350 while ( token_state &&(loc==null) )
13351 mp_end_token_list(mp); /* conserve stack space */
13355 @ The |back_error| routine is used when we want to restore or replace an
13356 offending token just before issuing an error message. We disable interrupts
13357 during the call of |back_input| so that the help message won't be lost.
13360 void mp_error (MP mp);
13361 void mp_back_error (MP mp);
13363 @ @c void mp_back_error (MP mp) { /* back up one token and call |error| */
13364 mp->OK_to_interrupt=false;
13366 mp->OK_to_interrupt=true; mp_error(mp);
13368 void mp_ins_error (MP mp) { /* back up one inserted token and call |error| */
13369 mp->OK_to_interrupt=false;
13370 mp_back_input(mp); token_type=inserted;
13371 mp->OK_to_interrupt=true; mp_error(mp);
13374 @ The |begin_file_reading| procedure starts a new level of input for lines
13375 of characters to be read from a file, or as an insertion from the
13376 terminal. It does not take care of opening the file, nor does it set |loc|
13377 or |limit| or |line|.
13378 @^system dependencies@>
13380 @c void mp_begin_file_reading (MP mp) {
13381 if ( mp->in_open==mp->max_in_open )
13382 mp_overflow(mp, "text input levels",mp->max_in_open);
13383 @:MetaPost capacity exceeded text input levels}{\quad text input levels@>
13384 if ( mp->first==mp->buf_size )
13385 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
13386 incr(mp->in_open); push_input; iindex=mp->in_open;
13387 mp->mpx_name[iindex]=absent;
13389 name=is_term; /* |terminal_input| is now |true| */
13392 @ Conversely, the variables must be downdated when such a level of input
13393 is finished. Any associated \.{MPX} file must also be closed and popped
13394 off the file stack.
13396 @c void mp_end_file_reading (MP mp) {
13397 if ( mp->in_open>iindex ) {
13398 if ( (mp->mpx_name[mp->in_open]==absent)||(name<=max_spec_src) ) {
13399 mp_confusion(mp, "endinput");
13400 @:this can't happen endinput}{\quad endinput@>
13402 (mp->close_file)(mp,mp->input_file[mp->in_open]); /* close an \.{MPX} file */
13403 delete_str_ref(mp->mpx_name[mp->in_open]);
13408 if ( iindex!=mp->in_open ) mp_confusion(mp, "endinput");
13409 if ( name>max_spec_src ) {
13410 (mp->close_file)(mp,cur_file);
13411 delete_str_ref(name);
13415 pop_input; decr(mp->in_open);
13418 @ Here is a function that tries to resume input from an \.{MPX} file already
13419 associated with the current input file. It returns |false| if this doesn't
13422 @c boolean mp_begin_mpx_reading (MP mp) {
13423 if ( mp->in_open!=iindex+1 ) {
13426 if ( mp->mpx_name[mp->in_open]<=absent ) mp_confusion(mp, "mpx");
13427 @:this can't happen mpx}{\quad mpx@>
13428 if ( mp->first==mp->buf_size )
13429 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
13430 push_input; iindex=mp->in_open;
13432 name=mp->mpx_name[mp->in_open]; add_str_ref(name);
13433 @<Put an empty line in the input buffer@>;
13438 @ This procedure temporarily stops reading an \.{MPX} file.
13440 @c void mp_end_mpx_reading (MP mp) {
13441 if ( mp->in_open!=iindex ) mp_confusion(mp, "mpx");
13442 @:this can't happen mpx}{\quad mpx@>
13444 @<Complain that we are not at the end of a line in the \.{MPX} file@>;
13450 @ Here we enforce a restriction that simplifies the input stacks considerably.
13451 This should not inconvenience the user because \.{MPX} files are generated
13452 by an auxiliary program called \.{DVItoMP}.
13454 @ @<Complain that we are not at the end of a line in the \.{MPX} file@>=
13456 print_err("`mpxbreak' must be at the end of a line");
13457 help4("This file contains picture expressions for btex...etex")
13458 ("blocks. Such files are normally generated automatically")
13459 ("but this one seems to be messed up. I'm going to ignore")
13460 ("the rest of this line.");
13464 @ In order to keep the stack from overflowing during a long sequence of
13465 inserted `\.{show}' commands, the following routine removes completed
13466 error-inserted lines from memory.
13468 @c void mp_clear_for_error_prompt (MP mp) {
13469 while ( file_state && terminal_input &&
13470 (mp->input_ptr>0)&&(loc==limit) ) mp_end_file_reading(mp);
13471 mp_print_ln(mp); clear_terminal;
13474 @ To get \MP's whole input mechanism going, we perform the following
13477 @<Initialize the input routines@>=
13478 { mp->input_ptr=0; mp->max_in_stack=0;
13479 mp->in_open=0; mp->open_parens=0; mp->max_buf_stack=0;
13480 mp->param_ptr=0; mp->max_param_stack=0;
13482 start=1; iindex=0; line=0; name=is_term;
13483 mp->mpx_name[0]=absent;
13484 mp->force_eof=false;
13485 if ( ! mp_init_terminal(mp) ) mp_jump_out(mp);
13486 limit=mp->last; mp->first=mp->last+1;
13487 /* |init_terminal| has set |loc| and |last| */
13490 @* \[29] Getting the next token.
13491 The heart of \MP's input mechanism is the |get_next| procedure, which
13492 we shall develop in the next few sections of the program. Perhaps we
13493 shouldn't actually call it the ``heart,'' however; it really acts as \MP's
13494 eyes and mouth, reading the source files and gobbling them up. And it also
13495 helps \MP\ to regurgitate stored token lists that are to be processed again.
13497 The main duty of |get_next| is to input one token and to set |cur_cmd|
13498 and |cur_mod| to that token's command code and modifier. Furthermore, if
13499 the input token is a symbolic token, that token's |hash| address
13500 is stored in |cur_sym|; otherwise |cur_sym| is set to zero.
13502 Underlying this simple description is a certain amount of complexity
13503 because of all the cases that need to be handled.
13504 However, the inner loop of |get_next| is reasonably short and fast.
13506 @ Before getting into |get_next|, we need to consider a mechanism by which
13507 \MP\ helps keep errors from propagating too far. Whenever the program goes
13508 into a mode where it keeps calling |get_next| repeatedly until a certain
13509 condition is met, it sets |scanner_status| to some value other than |normal|.
13510 Then if an input file ends, or if an `\&{outer}' symbol appears,
13511 an appropriate error recovery will be possible.
13513 The global variable |warning_info| helps in this error recovery by providing
13514 additional information. For example, |warning_info| might indicate the
13515 name of a macro whose replacement text is being scanned.
13517 @d normal 0 /* |scanner_status| at ``quiet times'' */
13518 @d skipping 1 /* |scanner_status| when false conditional text is being skipped */
13519 @d flushing 2 /* |scanner_status| when junk after a statement is being ignored */
13520 @d absorbing 3 /* |scanner_status| when a \&{text} parameter is being scanned */
13521 @d var_defining 4 /* |scanner_status| when a \&{vardef} is being scanned */
13522 @d op_defining 5 /* |scanner_status| when a macro \&{def} is being scanned */
13523 @d loop_defining 6 /* |scanner_status| when a \&{for} loop is being scanned */
13524 @d tex_flushing 7 /* |scanner_status| when skipping \TeX\ material */
13527 integer scanner_status; /* are we scanning at high speed? */
13528 integer warning_info; /* if so, what else do we need to know,
13529 in case an error occurs? */
13531 @ @<Initialize the input routines@>=
13532 mp->scanner_status=normal;
13534 @ The following subroutine
13535 is called when an `\&{outer}' symbolic token has been scanned or
13536 when the end of a file has been reached. These two cases are distinguished
13537 by |cur_sym|, which is zero at the end of a file.
13539 @c boolean mp_check_outer_validity (MP mp) {
13540 pointer p; /* points to inserted token list */
13541 if ( mp->scanner_status==normal ) {
13543 } else if ( mp->scanner_status==tex_flushing ) {
13544 @<Check if the file has ended while flushing \TeX\ material and set the
13545 result value for |check_outer_validity|@>;
13547 mp->deletions_allowed=false;
13548 @<Back up an outer symbolic token so that it can be reread@>;
13549 if ( mp->scanner_status>skipping ) {
13550 @<Tell the user what has run away and try to recover@>;
13552 print_err("Incomplete if; all text was ignored after line ");
13553 @.Incomplete if...@>
13554 mp_print_int(mp, mp->warning_info);
13555 help3("A forbidden `outer' token occurred in skipped text.")
13556 ("This kind of error happens when you say `if...' and forget")
13557 ("the matching `fi'. I've inserted a `fi'; this might work.");
13558 if ( mp->cur_sym==0 )
13559 mp->help_line[2]="The file ended while I was skipping conditional text.";
13560 mp->cur_sym=frozen_fi; mp_ins_error(mp);
13562 mp->deletions_allowed=true;
13567 @ @<Check if the file has ended while flushing \TeX\ material and set...@>=
13568 if ( mp->cur_sym!=0 ) {
13571 mp->deletions_allowed=false;
13572 print_err("TeX mode didn't end; all text was ignored after line ");
13573 mp_print_int(mp, mp->warning_info);
13574 help2("The file ended while I was looking for the `etex' to")
13575 ("finish this TeX material. I've inserted `etex' now.");
13576 mp->cur_sym = frozen_etex;
13578 mp->deletions_allowed=true;
13582 @ @<Back up an outer symbolic token so that it can be reread@>=
13583 if ( mp->cur_sym!=0 ) {
13584 p=mp_get_avail(mp); info(p)=mp->cur_sym;
13585 back_list(p); /* prepare to read the symbolic token again */
13588 @ @<Tell the user what has run away...@>=
13590 mp_runaway(mp); /* print the definition-so-far */
13591 if ( mp->cur_sym==0 ) {
13592 print_err("File ended");
13593 @.File ended while scanning...@>
13595 print_err("Forbidden token found");
13596 @.Forbidden token found...@>
13598 mp_print(mp, " while scanning ");
13599 help4("I suspect you have forgotten an `enddef',")
13600 ("causing me to read past where you wanted me to stop.")
13601 ("I'll try to recover; but if the error is serious,")
13602 ("you'd better type `E' or `X' now and fix your file.");
13603 switch (mp->scanner_status) {
13604 @<Complete the error message,
13605 and set |cur_sym| to a token that might help recover from the error@>
13606 } /* there are no other cases */
13610 @ As we consider various kinds of errors, it is also appropriate to
13611 change the first line of the help message just given; |help_line[3]|
13612 points to the string that might be changed.
13614 @<Complete the error message,...@>=
13616 mp_print(mp, "to the end of the statement");
13617 mp->help_line[3]="A previous error seems to have propagated,";
13618 mp->cur_sym=frozen_semicolon;
13621 mp_print(mp, "a text argument");
13622 mp->help_line[3]="It seems that a right delimiter was left out,";
13623 if ( mp->warning_info==0 ) {
13624 mp->cur_sym=frozen_end_group;
13626 mp->cur_sym=frozen_right_delimiter;
13627 equiv(frozen_right_delimiter)=mp->warning_info;
13632 mp_print(mp, "the definition of ");
13633 if ( mp->scanner_status==op_defining )
13634 mp_print_text(mp->warning_info);
13636 mp_print_variable_name(mp, mp->warning_info);
13637 mp->cur_sym=frozen_end_def;
13639 case loop_defining:
13640 mp_print(mp, "the text of a ");
13641 mp_print_text(mp->warning_info);
13642 mp_print(mp, " loop");
13643 mp->help_line[3]="I suspect you have forgotten an `endfor',";
13644 mp->cur_sym=frozen_end_for;
13647 @ The |runaway| procedure displays the first part of the text that occurred
13648 when \MP\ began its special |scanner_status|, if that text has been saved.
13650 @<Declare the procedure called |runaway|@>=
13651 void mp_runaway (MP mp) {
13652 if ( mp->scanner_status>flushing ) {
13653 mp_print_nl(mp, "Runaway ");
13654 switch (mp->scanner_status) {
13655 case absorbing: mp_print(mp, "text?"); break;
13657 case op_defining: mp_print(mp,"definition?"); break;
13658 case loop_defining: mp_print(mp, "loop?"); break;
13659 } /* there are no other cases */
13661 mp_show_token_list(mp, link(hold_head),null,mp->error_line-10,0);
13665 @ We need to mention a procedure that may be called by |get_next|.
13668 void mp_firm_up_the_line (MP mp);
13670 @ And now we're ready to take the plunge into |get_next| itself.
13671 Note that the behavior depends on the |scanner_status| because percent signs
13672 and double quotes need to be passed over when skipping TeX material.
13675 void mp_get_next (MP mp) {
13676 /* sets |cur_cmd|, |cur_mod|, |cur_sym| to next token */
13678 /*restart*/ /* go here to get the next input token */
13679 /*exit*/ /* go here when the next input token has been got */
13680 /*|common_ending|*/ /* go here to finish getting a symbolic token */
13681 /*found*/ /* go here when the end of a symbolic token has been found */
13682 /*switch*/ /* go here to branch on the class of an input character */
13683 /*|start_numeric_token|,|start_decimal_token|,|fin_numeric_token|,|done|*/
13684 /* go here at crucial stages when scanning a number */
13685 int k; /* an index into |buffer| */
13686 ASCII_code c; /* the current character in the buffer */
13687 ASCII_code class; /* its class number */
13688 integer n,f; /* registers for decimal-to-binary conversion */
13691 if ( file_state ) {
13692 @<Input from external file; |goto restart| if no input found,
13693 or |return| if a non-symbolic token is found@>;
13695 @<Input from token list; |goto restart| if end of list or
13696 if a parameter needs to be expanded,
13697 or |return| if a non-symbolic token is found@>;
13700 @<Finish getting the symbolic token in |cur_sym|;
13701 |goto restart| if it is illegal@>;
13704 @ When a symbolic token is declared to be `\&{outer}', its command code
13705 is increased by |outer_tag|.
13708 @<Finish getting the symbolic token in |cur_sym|...@>=
13709 mp->cur_cmd=eq_type(mp->cur_sym); mp->cur_mod=equiv(mp->cur_sym);
13710 if ( mp->cur_cmd>=outer_tag ) {
13711 if ( mp_check_outer_validity(mp) )
13712 mp->cur_cmd=mp->cur_cmd-outer_tag;
13717 @ A percent sign appears in |buffer[limit]|; this makes it unnecessary
13718 to have a special test for end-of-line.
13721 @<Input from external file;...@>=
13724 c=mp->buffer[loc]; incr(loc); class=mp->char_class[c];
13726 case digit_class: goto START_NUMERIC_TOKEN; break;
13728 class=mp->char_class[mp->buffer[loc]];
13729 if ( class>period_class ) {
13731 } else if ( class<period_class ) { /* |class=digit_class| */
13732 n=0; goto START_DECIMAL_TOKEN;
13736 case space_class: goto SWITCH; break;
13737 case percent_class:
13738 if ( mp->scanner_status==tex_flushing ) {
13739 if ( loc<limit ) goto SWITCH;
13741 @<Move to next line of file, or |goto restart| if there is no next line@>;
13746 if ( mp->scanner_status==tex_flushing ) goto SWITCH;
13747 else @<Get a string token and |return|@>;
13749 case isolated_classes:
13750 k=loc-1; goto FOUND; break;
13751 case invalid_class:
13752 if ( mp->scanner_status==tex_flushing ) goto SWITCH;
13753 else @<Decry the invalid character and |goto restart|@>;
13755 default: break; /* letters, etc. */
13758 while ( mp->char_class[mp->buffer[loc]]==class ) incr(loc);
13760 START_NUMERIC_TOKEN:
13761 @<Get the integer part |n| of a numeric token;
13762 set |f:=0| and |goto fin_numeric_token| if there is no decimal point@>;
13763 START_DECIMAL_TOKEN:
13764 @<Get the fraction part |f| of a numeric token@>;
13766 @<Pack the numeric and fraction parts of a numeric token
13769 mp->cur_sym=mp_id_lookup(mp, k,loc-k);
13772 @ We go to |restart| instead of to |SWITCH|, because we might enter
13773 |token_state| after the error has been dealt with
13774 (cf.\ |clear_for_error_prompt|).
13776 @<Decry the invalid...@>=
13778 print_err("Text line contains an invalid character");
13779 @.Text line contains...@>
13780 help2("A funny symbol that I can\'t read has just been input.")
13781 ("Continue, and I'll forget that it ever happened.");
13782 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
13786 @ @<Get a string token and |return|@>=
13788 if ( mp->buffer[loc]=='"' ) {
13789 mp->cur_mod=rts("");
13791 k=loc; mp->buffer[limit+1]='"';
13794 } while (mp->buffer[loc]!='"');
13796 @<Decry the missing string delimiter and |goto restart|@>;
13799 mp->cur_mod=mp->buffer[k];
13803 append_char(mp->buffer[k]); incr(k);
13805 mp->cur_mod=mp_make_string(mp);
13808 incr(loc); mp->cur_cmd=string_token;
13812 @ We go to |restart| after this error message, not to |SWITCH|,
13813 because the |clear_for_error_prompt| routine might have reinstated
13814 |token_state| after |error| has finished.
13816 @<Decry the missing string delimiter and |goto restart|@>=
13818 loc=limit; /* the next character to be read on this line will be |"%"| */
13819 print_err("Incomplete string token has been flushed");
13820 @.Incomplete string token...@>
13821 help3("Strings should finish on the same line as they began.")
13822 ("I've deleted the partial string; you might want to")
13823 ("insert another by typing, e.g., `I\"new string\"'.");
13824 mp->deletions_allowed=false; mp_error(mp);
13825 mp->deletions_allowed=true;
13829 @ @<Get the integer part |n| of a numeric token...@>=
13831 while ( mp->char_class[mp->buffer[loc]]==digit_class ) {
13832 if ( n<32768 ) n=10*n+mp->buffer[loc]-'0';
13835 if ( mp->buffer[loc]=='.' )
13836 if ( mp->char_class[mp->buffer[loc+1]]==digit_class )
13839 goto FIN_NUMERIC_TOKEN;
13842 @ @<Get the fraction part |f| of a numeric token@>=
13845 if ( k<17 ) { /* digits for |k>=17| cannot affect the result */
13846 mp->dig[k]=mp->buffer[loc]-'0'; incr(k);
13849 } while (mp->char_class[mp->buffer[loc]]==digit_class);
13850 f=mp_round_decimals(mp, k);
13855 @ @<Pack the numeric and fraction parts of a numeric token and |return|@>=
13857 @<Set |cur_mod:=n*unity+f| and check if it is uncomfortably large@>;
13858 } else if ( mp->scanner_status!=tex_flushing ) {
13859 print_err("Enormous number has been reduced");
13860 @.Enormous number...@>
13861 help2("I can\'t handle numbers bigger than 32767.99998;")
13862 ("so I've changed your constant to that maximum amount.");
13863 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
13864 mp->cur_mod=el_gordo;
13866 mp->cur_cmd=numeric_token; return
13868 @ @<Set |cur_mod:=n*unity+f| and check if it is uncomfortably large@>=
13870 mp->cur_mod=n*unity+f;
13871 if ( mp->cur_mod>=fraction_one ) {
13872 if ( (mp->internal[mp_warning_check]>0) &&
13873 (mp->scanner_status!=tex_flushing) ) {
13874 print_err("Number is too large (");
13875 mp_print_scaled(mp, mp->cur_mod);
13876 mp_print_char(mp, ')');
13877 help3("It is at least 4096. Continue and I'll try to cope")
13878 ("with that big value; but it might be dangerous.")
13879 ("(Set warningcheck:=0 to suppress this message.)");
13885 @ Let's consider now what happens when |get_next| is looking at a token list.
13888 @<Input from token list;...@>=
13889 if ( loc>=mp->hi_mem_min ) { /* one-word token */
13890 mp->cur_sym=info(loc); loc=link(loc); /* move to next */
13891 if ( mp->cur_sym>=expr_base ) {
13892 if ( mp->cur_sym>=suffix_base ) {
13893 @<Insert a suffix or text parameter and |goto restart|@>;
13895 mp->cur_cmd=capsule_token;
13896 mp->cur_mod=mp->param_stack[param_start+mp->cur_sym-(expr_base)];
13897 mp->cur_sym=0; return;
13900 } else if ( loc>null ) {
13901 @<Get a stored numeric or string or capsule token and |return|@>
13902 } else { /* we are done with this token list */
13903 mp_end_token_list(mp); goto RESTART; /* resume previous level */
13906 @ @<Insert a suffix or text parameter...@>=
13908 if ( mp->cur_sym>=text_base ) mp->cur_sym=mp->cur_sym-mp->param_size;
13909 /* |param_size=text_base-suffix_base| */
13910 mp_begin_token_list(mp,
13911 mp->param_stack[param_start+mp->cur_sym-(suffix_base)],
13916 @ @<Get a stored numeric or string or capsule token...@>=
13918 if ( name_type(loc)==mp_token ) {
13919 mp->cur_mod=value(loc);
13920 if ( type(loc)==mp_known ) {
13921 mp->cur_cmd=numeric_token;
13923 mp->cur_cmd=string_token; add_str_ref(mp->cur_mod);
13926 mp->cur_mod=loc; mp->cur_cmd=capsule_token;
13928 loc=link(loc); return;
13931 @ All of the easy branches of |get_next| have now been taken care of.
13932 There is one more branch.
13934 @<Move to next line of file, or |goto restart|...@>=
13935 if ( name>max_spec_src) {
13936 @<Read next line of file into |buffer|, or
13937 |goto restart| if the file has ended@>;
13939 if ( mp->input_ptr>0 ) {
13940 /* text was inserted during error recovery or by \&{scantokens} */
13941 mp_end_file_reading(mp); goto RESTART; /* resume previous level */
13943 if (mp->job_name == NULL && ( mp->selector<log_only || mp->selector>=write_file))
13944 mp_open_log_file(mp);
13945 if ( mp->interaction>mp_nonstop_mode ) {
13946 if ( limit==start ) /* previous line was empty */
13947 mp_print_nl(mp, "(Please type a command or say `end')");
13949 mp_print_ln(mp); mp->first=start;
13950 prompt_input("*"); /* input on-line into |buffer| */
13952 limit=mp->last; mp->buffer[limit]='%';
13953 mp->first=limit+1; loc=start;
13955 mp_fatal_error(mp, "*** (job aborted, no legal end found)");
13957 /* nonstop mode, which is intended for overnight batch processing,
13958 never waits for on-line input */
13962 @ The global variable |force_eof| is normally |false|; it is set |true|
13963 by an \&{endinput} command.
13966 boolean force_eof; /* should the next \&{input} be aborted early? */
13968 @ We must decrement |loc| in order to leave the buffer in a valid state
13969 when an error condition causes us to |goto restart| without calling
13970 |end_file_reading|.
13972 @<Read next line of file into |buffer|, or
13973 |goto restart| if the file has ended@>=
13975 incr(line); mp->first=start;
13976 if ( ! mp->force_eof ) {
13977 if ( mp_input_ln(mp, cur_file ) ) /* not end of file */
13978 mp_firm_up_the_line(mp); /* this sets |limit| */
13980 mp->force_eof=true;
13982 if ( mp->force_eof ) {
13983 mp->force_eof=false;
13985 if ( mpx_reading ) {
13986 @<Complain that the \.{MPX} file ended unexpectly; then set
13987 |cur_sym:=frozen_mpx_break| and |goto comon_ending|@>;
13989 mp_print_char(mp, ')'); decr(mp->open_parens);
13990 update_terminal; /* show user that file has been read */
13991 mp_end_file_reading(mp); /* resume previous level */
13992 if ( mp_check_outer_validity(mp) ) goto RESTART;
13996 mp->buffer[limit]='%'; mp->first=limit+1; loc=start; /* ready to read */
13999 @ We should never actually come to the end of an \.{MPX} file because such
14000 files should have an \&{mpxbreak} after the translation of the last
14001 \&{btex}$\,\ldots\,$\&{etex} block.
14003 @<Complain that the \.{MPX} file ended unexpectly; then set...@>=
14005 mp->mpx_name[iindex]=mpx_finished;
14006 print_err("mpx file ended unexpectedly");
14007 help4("The file had too few picture expressions for btex...etex")
14008 ("blocks. Such files are normally generated automatically")
14009 ("but this one got messed up. You might want to insert a")
14010 ("picture expression now.");
14011 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
14012 mp->cur_sym=frozen_mpx_break; goto COMMON_ENDING;
14015 @ Sometimes we want to make it look as though we have just read a blank line
14016 without really doing so.
14018 @<Put an empty line in the input buffer@>=
14019 mp->last=mp->first; limit=mp->last; /* simulate |input_ln| and |firm_up_the_line| */
14020 mp->buffer[limit]='%'; mp->first=limit+1; loc=start
14022 @ If the user has set the |mp_pausing| parameter to some positive value,
14023 and if nonstop mode has not been selected, each line of input is displayed
14024 on the terminal and the transcript file, followed by `\.{=>}'.
14025 \MP\ waits for a response. If the response is null (i.e., if nothing is
14026 typed except perhaps a few blank spaces), the original
14027 line is accepted as it stands; otherwise the line typed is
14028 used instead of the line in the file.
14030 @c void mp_firm_up_the_line (MP mp) {
14031 size_t k; /* an index into |buffer| */
14033 if ((!mp->noninteractive)
14034 && (mp->internal[mp_pausing]>0 )
14035 && (mp->interaction>mp_nonstop_mode )) {
14036 wake_up_terminal; mp_print_ln(mp);
14037 if ( start<limit ) {
14038 for (k=(size_t)start;k<=(size_t)(limit-1);k++) {
14039 mp_print_str(mp, mp->buffer[k]);
14042 mp->first=limit; prompt_input("=>"); /* wait for user response */
14044 if ( mp->last>mp->first ) {
14045 for (k=mp->first;k<=mp->last-1;k++) { /* move line down in buffer */
14046 mp->buffer[k+start-mp->first]=mp->buffer[k];
14048 limit=start+mp->last-mp->first;
14053 @* \[30] Dealing with \TeX\ material.
14054 The \&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}$\,\ldots\,$\&{etex}
14055 features need to be implemented at a low level in the scanning process
14056 so that \MP\ can stay in synch with the a preprocessor that treats
14057 blocks of \TeX\ material as they occur in the input file without trying
14058 to expand \MP\ macros. Thus we need a special version of |get_next|
14059 that does not expand macros and such but does handle \&{btex},
14060 \&{verbatimtex}, etc.
14062 The special version of |get_next| is called |get_t_next|. It works by flushing
14063 \&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}\allowbreak
14064 $\,\ldots\,$\&{etex} blocks, switching to the \.{MPX} file when it sees
14065 \&{btex}, and switching back when it sees \&{mpxbreak}.
14071 mp_primitive(mp, "btex",start_tex,btex_code);
14072 @:btex_}{\&{btex} primitive@>
14073 mp_primitive(mp, "verbatimtex",start_tex,verbatim_code);
14074 @:verbatimtex_}{\&{verbatimtex} primitive@>
14075 mp_primitive(mp, "etex",etex_marker,0); mp->eqtb[frozen_etex]=mp->eqtb[mp->cur_sym];
14076 @:etex_}{\&{etex} primitive@>
14077 mp_primitive(mp, "mpxbreak",mpx_break,0); mp->eqtb[frozen_mpx_break]=mp->eqtb[mp->cur_sym];
14078 @:mpx_break_}{\&{mpxbreak} primitive@>
14080 @ @<Cases of |print_cmd...@>=
14081 case start_tex: if ( m==btex_code ) mp_print(mp, "btex");
14082 else mp_print(mp, "verbatimtex"); break;
14083 case etex_marker: mp_print(mp, "etex"); break;
14084 case mpx_break: mp_print(mp, "mpxbreak"); break;
14086 @ Actually, |get_t_next| is a macro that avoids procedure overhead except
14087 in the unusual case where \&{btex}, \&{verbatimtex}, \&{etex}, or \&{mpxbreak}
14090 @d get_t_next {mp_get_next(mp); if ( mp->cur_cmd<=max_pre_command ) mp_t_next(mp); }
14093 void mp_start_mpx_input (MP mp);
14096 void mp_t_next (MP mp) {
14097 int old_status; /* saves the |scanner_status| */
14098 integer old_info; /* saves the |warning_info| */
14099 while ( mp->cur_cmd<=max_pre_command ) {
14100 if ( mp->cur_cmd==mpx_break ) {
14101 if ( ! file_state || (mp->mpx_name[iindex]==absent) ) {
14102 @<Complain about a misplaced \&{mpxbreak}@>;
14104 mp_end_mpx_reading(mp);
14107 } else if ( mp->cur_cmd==start_tex ) {
14108 if ( token_state || (name<=max_spec_src) ) {
14109 @<Complain that we are not reading a file@>;
14110 } else if ( mpx_reading ) {
14111 @<Complain that \.{MPX} files cannot contain \TeX\ material@>;
14112 } else if ( (mp->cur_mod!=verbatim_code)&&
14113 (mp->mpx_name[iindex]!=mpx_finished) ) {
14114 if ( ! mp_begin_mpx_reading(mp) ) mp_start_mpx_input(mp);
14119 @<Complain about a misplaced \&{etex}@>;
14121 goto COMMON_ENDING;
14123 @<Flush the \TeX\ material@>;
14129 @ We could be in the middle of an operation such as skipping false conditional
14130 text when \TeX\ material is encountered, so we must be careful to save the
14133 @<Flush the \TeX\ material@>=
14134 old_status=mp->scanner_status;
14135 old_info=mp->warning_info;
14136 mp->scanner_status=tex_flushing;
14137 mp->warning_info=line;
14138 do { mp_get_next(mp); } while (mp->cur_cmd!=etex_marker);
14139 mp->scanner_status=old_status;
14140 mp->warning_info=old_info
14142 @ @<Complain that \.{MPX} files cannot contain \TeX\ material@>=
14143 { print_err("An mpx file cannot contain btex or verbatimtex blocks");
14144 help4("This file contains picture expressions for btex...etex")
14145 ("blocks. Such files are normally generated automatically")
14146 ("but this one seems to be messed up. I'll just keep going")
14147 ("and hope for the best.");
14151 @ @<Complain that we are not reading a file@>=
14152 { print_err("You can only use `btex' or `verbatimtex' in a file");
14153 help3("I'll have to ignore this preprocessor command because it")
14154 ("only works when there is a file to preprocess. You might")
14155 ("want to delete everything up to the next `etex`.");
14159 @ @<Complain about a misplaced \&{mpxbreak}@>=
14160 { print_err("Misplaced mpxbreak");
14161 help2("I'll ignore this preprocessor command because it")
14162 ("doesn't belong here");
14166 @ @<Complain about a misplaced \&{etex}@>=
14167 { print_err("Extra etex will be ignored");
14168 help1("There is no btex or verbatimtex for this to match");
14172 @* \[31] Scanning macro definitions.
14173 \MP\ has a variety of ways to tuck tokens away into token lists for later
14174 use: Macros can be defined with \&{def}, \&{vardef}, \&{primarydef}, etc.;
14175 repeatable code can be defined with \&{for}, \&{forever}, \&{forsuffixes}.
14176 All such operations are handled by the routines in this part of the program.
14178 The modifier part of each command code is zero for the ``ending delimiters''
14179 like \&{enddef} and \&{endfor}.
14181 @d start_def 1 /* command modifier for \&{def} */
14182 @d var_def 2 /* command modifier for \&{vardef} */
14183 @d end_def 0 /* command modifier for \&{enddef} */
14184 @d start_forever 1 /* command modifier for \&{forever} */
14185 @d end_for 0 /* command modifier for \&{endfor} */
14188 mp_primitive(mp, "def",macro_def,start_def);
14189 @:def_}{\&{def} primitive@>
14190 mp_primitive(mp, "vardef",macro_def,var_def);
14191 @:var_def_}{\&{vardef} primitive@>
14192 mp_primitive(mp, "primarydef",macro_def,secondary_primary_macro);
14193 @:primary_def_}{\&{primarydef} primitive@>
14194 mp_primitive(mp, "secondarydef",macro_def,tertiary_secondary_macro);
14195 @:secondary_def_}{\&{secondarydef} primitive@>
14196 mp_primitive(mp, "tertiarydef",macro_def,expression_tertiary_macro);
14197 @:tertiary_def_}{\&{tertiarydef} primitive@>
14198 mp_primitive(mp, "enddef",macro_def,end_def); mp->eqtb[frozen_end_def]=mp->eqtb[mp->cur_sym];
14199 @:end_def_}{\&{enddef} primitive@>
14201 mp_primitive(mp, "for",iteration,expr_base);
14202 @:for_}{\&{for} primitive@>
14203 mp_primitive(mp, "forsuffixes",iteration,suffix_base);
14204 @:for_suffixes_}{\&{forsuffixes} primitive@>
14205 mp_primitive(mp, "forever",iteration,start_forever);
14206 @:forever_}{\&{forever} primitive@>
14207 mp_primitive(mp, "endfor",iteration,end_for); mp->eqtb[frozen_end_for]=mp->eqtb[mp->cur_sym];
14208 @:end_for_}{\&{endfor} primitive@>
14210 @ @<Cases of |print_cmd...@>=
14212 if ( m<=var_def ) {
14213 if ( m==start_def ) mp_print(mp, "def");
14214 else if ( m<start_def ) mp_print(mp, "enddef");
14215 else mp_print(mp, "vardef");
14216 } else if ( m==secondary_primary_macro ) {
14217 mp_print(mp, "primarydef");
14218 } else if ( m==tertiary_secondary_macro ) {
14219 mp_print(mp, "secondarydef");
14221 mp_print(mp, "tertiarydef");
14225 if ( m<=start_forever ) {
14226 if ( m==start_forever ) mp_print(mp, "forever");
14227 else mp_print(mp, "endfor");
14228 } else if ( m==expr_base ) {
14229 mp_print(mp, "for");
14231 mp_print(mp, "forsuffixes");
14235 @ Different macro-absorbing operations have different syntaxes, but they
14236 also have a lot in common. There is a list of special symbols that are to
14237 be replaced by parameter tokens; there is a special command code that
14238 ends the definition; the quotation conventions are identical. Therefore
14239 it makes sense to have most of the work done by a single subroutine. That
14240 subroutine is called |scan_toks|.
14242 The first parameter to |scan_toks| is the command code that will
14243 terminate scanning (either |macro_def| or |iteration|).
14245 The second parameter, |subst_list|, points to a (possibly empty) list
14246 of two-word nodes whose |info| and |value| fields specify symbol tokens
14247 before and after replacement. The list will be returned to free storage
14250 The third parameter is simply appended to the token list that is built.
14251 And the final parameter tells how many of the special operations
14252 \.{\#\AT!}, \.{\AT!}, and \.{\AT!\#} are to be replaced by suffix parameters.
14253 When such parameters are present, they are called \.{(SUFFIX0)},
14254 \.{(SUFFIX1)}, and \.{(SUFFIX2)}.
14256 @c pointer mp_scan_toks (MP mp,command_code terminator, pointer
14257 subst_list, pointer tail_end, small_number suffix_count) {
14258 pointer p; /* tail of the token list being built */
14259 pointer q; /* temporary for link management */
14260 integer balance; /* left delimiters minus right delimiters */
14261 p=hold_head; balance=1; link(hold_head)=null;
14264 if ( mp->cur_sym>0 ) {
14265 @<Substitute for |cur_sym|, if it's on the |subst_list|@>;
14266 if ( mp->cur_cmd==terminator ) {
14267 @<Adjust the balance; |break| if it's zero@>;
14268 } else if ( mp->cur_cmd==macro_special ) {
14269 @<Handle quoted symbols, \.{\#\AT!}, \.{\AT!}, or \.{\AT!\#}@>;
14272 link(p)=mp_cur_tok(mp); p=link(p);
14274 link(p)=tail_end; mp_flush_node_list(mp, subst_list);
14275 return link(hold_head);
14278 @ @<Substitute for |cur_sym|...@>=
14281 while ( q!=null ) {
14282 if ( info(q)==mp->cur_sym ) {
14283 mp->cur_sym=value(q); mp->cur_cmd=relax; break;
14289 @ @<Adjust the balance; |break| if it's zero@>=
14290 if ( mp->cur_mod>0 ) {
14298 @ Four commands are intended to be used only within macro texts: \&{quote},
14299 \.{\#\AT!}, \.{\AT!}, and \.{\AT!\#}. They are variants of a single command
14300 code called |macro_special|.
14302 @d quote 0 /* |macro_special| modifier for \&{quote} */
14303 @d macro_prefix 1 /* |macro_special| modifier for \.{\#\AT!} */
14304 @d macro_at 2 /* |macro_special| modifier for \.{\AT!} */
14305 @d macro_suffix 3 /* |macro_special| modifier for \.{\AT!\#} */
14308 mp_primitive(mp, "quote",macro_special,quote);
14309 @:quote_}{\&{quote} primitive@>
14310 mp_primitive(mp, "#@@",macro_special,macro_prefix);
14311 @:]]]\#\AT!_}{\.{\#\AT!} primitive@>
14312 mp_primitive(mp, "@@",macro_special,macro_at);
14313 @:]]]\AT!_}{\.{\AT!} primitive@>
14314 mp_primitive(mp, "@@#",macro_special,macro_suffix);
14315 @:]]]\AT!\#_}{\.{\AT!\#} primitive@>
14317 @ @<Cases of |print_cmd...@>=
14318 case macro_special:
14320 case macro_prefix: mp_print(mp, "#@@"); break;
14321 case macro_at: mp_print_char(mp, '@@'); break;
14322 case macro_suffix: mp_print(mp, "@@#"); break;
14323 default: mp_print(mp, "quote"); break;
14327 @ @<Handle quoted...@>=
14329 if ( mp->cur_mod==quote ) { get_t_next; }
14330 else if ( mp->cur_mod<=suffix_count )
14331 mp->cur_sym=suffix_base-1+mp->cur_mod;
14334 @ Here is a routine that's used whenever a token will be redefined. If
14335 the user's token is unredefinable, the `|frozen_inaccessible|' token is
14336 substituted; the latter is redefinable but essentially impossible to use,
14337 hence \MP's tables won't get fouled up.
14339 @c void mp_get_symbol (MP mp) { /* sets |cur_sym| to a safe symbol */
14342 if ( (mp->cur_sym==0)||(mp->cur_sym>frozen_inaccessible) ) {
14343 print_err("Missing symbolic token inserted");
14344 @.Missing symbolic token...@>
14345 help3("Sorry: You can\'t redefine a number, string, or expr.")
14346 ("I've inserted an inaccessible symbol so that your")
14347 ("definition will be completed without mixing me up too badly.");
14348 if ( mp->cur_sym>0 )
14349 mp->help_line[2]="Sorry: You can\'t redefine my error-recovery tokens.";
14350 else if ( mp->cur_cmd==string_token )
14351 delete_str_ref(mp->cur_mod);
14352 mp->cur_sym=frozen_inaccessible; mp_ins_error(mp); goto RESTART;
14356 @ Before we actually redefine a symbolic token, we need to clear away its
14357 former value, if it was a variable. The following stronger version of
14358 |get_symbol| does that.
14360 @c void mp_get_clear_symbol (MP mp) {
14361 mp_get_symbol(mp); mp_clear_symbol(mp, mp->cur_sym,false);
14364 @ Here's another little subroutine; it checks that an equals sign
14365 or assignment sign comes along at the proper place in a macro definition.
14367 @c void mp_check_equals (MP mp) {
14368 if ( mp->cur_cmd!=equals ) if ( mp->cur_cmd!=assignment ) {
14369 mp_missing_err(mp, "=");
14371 help5("The next thing in this `def' should have been `=',")
14372 ("because I've already looked at the definition heading.")
14373 ("But don't worry; I'll pretend that an equals sign")
14374 ("was present. Everything from here to `enddef'")
14375 ("will be the replacement text of this macro.");
14380 @ A \&{primarydef}, \&{secondarydef}, or \&{tertiarydef} is rather easily
14381 handled now that we have |scan_toks|. In this case there are
14382 two parameters, which will be \.{EXPR0} and \.{EXPR1} (i.e.,
14383 |expr_base| and |expr_base+1|).
14385 @c void mp_make_op_def (MP mp) {
14386 command_code m; /* the type of definition */
14387 pointer p,q,r; /* for list manipulation */
14389 mp_get_symbol(mp); q=mp_get_node(mp, token_node_size);
14390 info(q)=mp->cur_sym; value(q)=expr_base;
14391 mp_get_clear_symbol(mp); mp->warning_info=mp->cur_sym;
14392 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
14393 info(p)=mp->cur_sym; value(p)=expr_base+1; link(p)=q;
14394 get_t_next; mp_check_equals(mp);
14395 mp->scanner_status=op_defining; q=mp_get_avail(mp); ref_count(q)=null;
14396 r=mp_get_avail(mp); link(q)=r; info(r)=general_macro;
14397 link(r)=mp_scan_toks(mp, macro_def,p,null,0);
14398 mp->scanner_status=normal; eq_type(mp->warning_info)=m;
14399 equiv(mp->warning_info)=q; mp_get_x_next(mp);
14402 @ Parameters to macros are introduced by the keywords \&{expr},
14403 \&{suffix}, \&{text}, \&{primary}, \&{secondary}, and \&{tertiary}.
14406 mp_primitive(mp, "expr",param_type,expr_base);
14407 @:expr_}{\&{expr} primitive@>
14408 mp_primitive(mp, "suffix",param_type,suffix_base);
14409 @:suffix_}{\&{suffix} primitive@>
14410 mp_primitive(mp, "text",param_type,text_base);
14411 @:text_}{\&{text} primitive@>
14412 mp_primitive(mp, "primary",param_type,primary_macro);
14413 @:primary_}{\&{primary} primitive@>
14414 mp_primitive(mp, "secondary",param_type,secondary_macro);
14415 @:secondary_}{\&{secondary} primitive@>
14416 mp_primitive(mp, "tertiary",param_type,tertiary_macro);
14417 @:tertiary_}{\&{tertiary} primitive@>
14419 @ @<Cases of |print_cmd...@>=
14421 if ( m>=expr_base ) {
14422 if ( m==expr_base ) mp_print(mp, "expr");
14423 else if ( m==suffix_base ) mp_print(mp, "suffix");
14424 else mp_print(mp, "text");
14425 } else if ( m<secondary_macro ) {
14426 mp_print(mp, "primary");
14427 } else if ( m==secondary_macro ) {
14428 mp_print(mp, "secondary");
14430 mp_print(mp, "tertiary");
14434 @ Let's turn next to the more complex processing associated with \&{def}
14435 and \&{vardef}. When the following procedure is called, |cur_mod|
14436 should be either |start_def| or |var_def|.
14438 @c @<Declare the procedure called |check_delimiter|@>
14439 @<Declare the function called |scan_declared_variable|@>
14440 void mp_scan_def (MP mp) {
14441 int m; /* the type of definition */
14442 int n; /* the number of special suffix parameters */
14443 int k; /* the total number of parameters */
14444 int c; /* the kind of macro we're defining */
14445 pointer r; /* parameter-substitution list */
14446 pointer q; /* tail of the macro token list */
14447 pointer p; /* temporary storage */
14448 halfword base; /* |expr_base|, |suffix_base|, or |text_base| */
14449 pointer l_delim,r_delim; /* matching delimiters */
14450 m=mp->cur_mod; c=general_macro; link(hold_head)=null;
14451 q=mp_get_avail(mp); ref_count(q)=null; r=null;
14452 @<Scan the token or variable to be defined;
14453 set |n|, |scanner_status|, and |warning_info|@>;
14455 if ( mp->cur_cmd==left_delimiter ) {
14456 @<Absorb delimited parameters, putting them into lists |q| and |r|@>;
14458 if ( mp->cur_cmd==param_type ) {
14459 @<Absorb undelimited parameters, putting them into list |r|@>;
14461 mp_check_equals(mp);
14462 p=mp_get_avail(mp); info(p)=c; link(q)=p;
14463 @<Attach the replacement text to the tail of node |p|@>;
14464 mp->scanner_status=normal; mp_get_x_next(mp);
14467 @ We don't put `|frozen_end_group|' into the replacement text of
14468 a \&{vardef}, because the user may want to redefine `\.{endgroup}'.
14470 @<Attach the replacement text to the tail of node |p|@>=
14471 if ( m==start_def ) {
14472 link(p)=mp_scan_toks(mp, macro_def,r,null,n);
14474 q=mp_get_avail(mp); info(q)=mp->bg_loc; link(p)=q;
14475 p=mp_get_avail(mp); info(p)=mp->eg_loc;
14476 link(q)=mp_scan_toks(mp, macro_def,r,p,n);
14478 if ( mp->warning_info==bad_vardef )
14479 mp_flush_token_list(mp, value(bad_vardef))
14483 int eg_loc; /* hash addresses of `\.{begingroup}' and `\.{endgroup}' */
14485 @ @<Scan the token or variable to be defined;...@>=
14486 if ( m==start_def ) {
14487 mp_get_clear_symbol(mp); mp->warning_info=mp->cur_sym; get_t_next;
14488 mp->scanner_status=op_defining; n=0;
14489 eq_type(mp->warning_info)=defined_macro; equiv(mp->warning_info)=q;
14491 p=mp_scan_declared_variable(mp);
14492 mp_flush_variable(mp, equiv(info(p)),link(p),true);
14493 mp->warning_info=mp_find_variable(mp, p); mp_flush_list(mp, p);
14494 if ( mp->warning_info==null ) @<Change to `\.{a bad variable}'@>;
14495 mp->scanner_status=var_defining; n=2;
14496 if ( mp->cur_cmd==macro_special ) if ( mp->cur_mod==macro_suffix ) {/* \.{\AT!\#} */
14499 type(mp->warning_info)=mp_unsuffixed_macro-2+n; value(mp->warning_info)=q;
14500 } /* |mp_suffixed_macro=mp_unsuffixed_macro+1| */
14502 @ @<Change to `\.{a bad variable}'@>=
14504 print_err("This variable already starts with a macro");
14505 @.This variable already...@>
14506 help2("After `vardef a' you can\'t say `vardef a.b'.")
14507 ("So I'll have to discard this definition.");
14508 mp_error(mp); mp->warning_info=bad_vardef;
14511 @ @<Initialize table entries...@>=
14512 name_type(bad_vardef)=mp_root; link(bad_vardef)=frozen_bad_vardef;
14513 equiv(frozen_bad_vardef)=bad_vardef; eq_type(frozen_bad_vardef)=tag_token;
14515 @ @<Absorb delimited parameters, putting them into lists |q| and |r|@>=
14517 l_delim=mp->cur_sym; r_delim=mp->cur_mod; get_t_next;
14518 if ( (mp->cur_cmd==param_type)&&(mp->cur_mod>=expr_base) ) {
14521 print_err("Missing parameter type; `expr' will be assumed");
14522 @.Missing parameter type@>
14523 help1("You should've had `expr' or `suffix' or `text' here.");
14524 mp_back_error(mp); base=expr_base;
14526 @<Absorb parameter tokens for type |base|@>;
14527 mp_check_delimiter(mp, l_delim,r_delim);
14529 } while (mp->cur_cmd==left_delimiter)
14531 @ @<Absorb parameter tokens for type |base|@>=
14533 link(q)=mp_get_avail(mp); q=link(q); info(q)=base+k;
14534 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
14535 value(p)=base+k; info(p)=mp->cur_sym;
14536 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14537 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
14538 incr(k); link(p)=r; r=p; get_t_next;
14539 } while (mp->cur_cmd==comma)
14541 @ @<Absorb undelimited parameters, putting them into list |r|@>=
14543 p=mp_get_node(mp, token_node_size);
14544 if ( mp->cur_mod<expr_base ) {
14545 c=mp->cur_mod; value(p)=expr_base+k;
14547 value(p)=mp->cur_mod+k;
14548 if ( mp->cur_mod==expr_base ) c=expr_macro;
14549 else if ( mp->cur_mod==suffix_base ) c=suffix_macro;
14552 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14553 incr(k); mp_get_symbol(mp); info(p)=mp->cur_sym; link(p)=r; r=p; get_t_next;
14554 if ( c==expr_macro ) if ( mp->cur_cmd==of_token ) {
14555 c=of_macro; p=mp_get_node(mp, token_node_size);
14556 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14557 value(p)=expr_base+k; mp_get_symbol(mp); info(p)=mp->cur_sym;
14558 link(p)=r; r=p; get_t_next;
14562 @* \[32] Expanding the next token.
14563 Only a few command codes |<min_command| can possibly be returned by
14564 |get_t_next|; in increasing order, they are
14565 |if_test|, |fi_or_else|, |input|, |iteration|, |repeat_loop|,
14566 |exit_test|, |relax|, |scan_tokens|, |expand_after|, and |defined_macro|.
14568 \MP\ usually gets the next token of input by saying |get_x_next|. This is
14569 like |get_t_next| except that it keeps getting more tokens until
14570 finding |cur_cmd>=min_command|. In other words, |get_x_next| expands
14571 macros and removes conditionals or iterations or input instructions that
14574 It follows that |get_x_next| might invoke itself recursively. In fact,
14575 there is massive recursion, since macro expansion can involve the
14576 scanning of arbitrarily complex expressions, which in turn involve
14577 macro expansion and conditionals, etc.
14580 Therefore it's necessary to declare a whole bunch of |forward|
14581 procedures at this point, and to insert some other procedures
14582 that will be invoked by |get_x_next|.
14585 void mp_scan_primary (MP mp);
14586 void mp_scan_secondary (MP mp);
14587 void mp_scan_tertiary (MP mp);
14588 void mp_scan_expression (MP mp);
14589 void mp_scan_suffix (MP mp);
14590 @<Declare the procedure called |macro_call|@>
14591 void mp_get_boolean (MP mp);
14592 void mp_pass_text (MP mp);
14593 void mp_conditional (MP mp);
14594 void mp_start_input (MP mp);
14595 void mp_begin_iteration (MP mp);
14596 void mp_resume_iteration (MP mp);
14597 void mp_stop_iteration (MP mp);
14599 @ An auxiliary subroutine called |expand| is used by |get_x_next|
14600 when it has to do exotic expansion commands.
14602 @c void mp_expand (MP mp) {
14603 pointer p; /* for list manipulation */
14604 size_t k; /* something that we hope is |<=buf_size| */
14605 pool_pointer j; /* index into |str_pool| */
14606 if ( mp->internal[mp_tracing_commands]>unity )
14607 if ( mp->cur_cmd!=defined_macro )
14609 switch (mp->cur_cmd) {
14611 mp_conditional(mp); /* this procedure is discussed in Part 36 below */
14614 @<Terminate the current conditional and skip to \&{fi}@>;
14617 @<Initiate or terminate input from a file@>;
14620 if ( mp->cur_mod==end_for ) {
14621 @<Scold the user for having an extra \&{endfor}@>;
14623 mp_begin_iteration(mp); /* this procedure is discussed in Part 37 below */
14630 @<Exit a loop if the proper time has come@>;
14635 @<Expand the token after the next token@>;
14638 @<Put a string into the input buffer@>;
14640 case defined_macro:
14641 mp_macro_call(mp, mp->cur_mod,null,mp->cur_sym);
14643 }; /* there are no other cases */
14646 @ @<Scold the user...@>=
14648 print_err("Extra `endfor'");
14650 help2("I'm not currently working on a for loop,")
14651 ("so I had better not try to end anything.");
14655 @ The processing of \&{input} involves the |start_input| subroutine,
14656 which will be declared later; the processing of \&{endinput} is trivial.
14659 mp_primitive(mp, "input",input,0);
14660 @:input_}{\&{input} primitive@>
14661 mp_primitive(mp, "endinput",input,1);
14662 @:end_input_}{\&{endinput} primitive@>
14664 @ @<Cases of |print_cmd_mod|...@>=
14666 if ( m==0 ) mp_print(mp, "input");
14667 else mp_print(mp, "endinput");
14670 @ @<Initiate or terminate input...@>=
14671 if ( mp->cur_mod>0 ) mp->force_eof=true;
14672 else mp_start_input(mp)
14674 @ We'll discuss the complicated parts of loop operations later. For now
14675 it suffices to know that there's a global variable called |loop_ptr|
14676 that will be |null| if no loop is in progress.
14679 { while ( token_state &&(loc==null) )
14680 mp_end_token_list(mp); /* conserve stack space */
14681 if ( mp->loop_ptr==null ) {
14682 print_err("Lost loop");
14684 help2("I'm confused; after exiting from a loop, I still seem")
14685 ("to want to repeat it. I'll try to forget the problem.");
14688 mp_resume_iteration(mp); /* this procedure is in Part 37 below */
14692 @ @<Exit a loop if the proper time has come@>=
14693 { mp_get_boolean(mp);
14694 if ( mp->internal[mp_tracing_commands]>unity )
14695 mp_show_cmd_mod(mp, nullary,mp->cur_exp);
14696 if ( mp->cur_exp==true_code ) {
14697 if ( mp->loop_ptr==null ) {
14698 print_err("No loop is in progress");
14699 @.No loop is in progress@>
14700 help1("Why say `exitif' when there's nothing to exit from?");
14701 if ( mp->cur_cmd==semicolon ) mp_error(mp); else mp_back_error(mp);
14703 @<Exit prematurely from an iteration@>;
14705 } else if ( mp->cur_cmd!=semicolon ) {
14706 mp_missing_err(mp, ";");
14708 help2("After `exitif <boolean exp>' I expect to see a semicolon.")
14709 ("I shall pretend that one was there."); mp_back_error(mp);
14713 @ Here we use the fact that |forever_text| is the only |token_type| that
14714 is less than |loop_text|.
14716 @<Exit prematurely...@>=
14719 if ( file_state ) {
14720 mp_end_file_reading(mp);
14722 if ( token_type<=loop_text ) p=start;
14723 mp_end_token_list(mp);
14726 if ( p!=info(mp->loop_ptr) ) mp_fatal_error(mp, "*** (loop confusion)");
14728 mp_stop_iteration(mp); /* this procedure is in Part 34 below */
14731 @ @<Expand the token after the next token@>=
14733 p=mp_cur_tok(mp); get_t_next;
14734 if ( mp->cur_cmd<min_command ) mp_expand(mp);
14735 else mp_back_input(mp);
14739 @ @<Put a string into the input buffer@>=
14740 { mp_get_x_next(mp); mp_scan_primary(mp);
14741 if ( mp->cur_type!=mp_string_type ) {
14742 mp_disp_err(mp, null,"Not a string");
14744 help2("I'm going to flush this expression, since")
14745 ("scantokens should be followed by a known string.");
14746 mp_put_get_flush_error(mp, 0);
14749 if ( length(mp->cur_exp)>0 )
14750 @<Pretend we're reading a new one-line file@>;
14754 @ @<Pretend we're reading a new one-line file@>=
14755 { mp_begin_file_reading(mp); name=is_scantok;
14756 k=mp->first+length(mp->cur_exp);
14757 if ( k>=mp->max_buf_stack ) {
14758 while ( k>=mp->buf_size ) {
14759 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
14761 mp->max_buf_stack=k+1;
14763 j=mp->str_start[mp->cur_exp]; limit=k;
14764 while ( mp->first<(size_t)limit ) {
14765 mp->buffer[mp->first]=mp->str_pool[j]; incr(j); incr(mp->first);
14767 mp->buffer[limit]='%'; mp->first=limit+1; loc=start;
14768 mp_flush_cur_exp(mp, 0);
14771 @ Here finally is |get_x_next|.
14773 The expression scanning routines to be considered later
14774 communicate via the global quantities |cur_type| and |cur_exp|;
14775 we must be very careful to save and restore these quantities while
14776 macros are being expanded.
14780 void mp_get_x_next (MP mp);
14782 @ @c void mp_get_x_next (MP mp) {
14783 pointer save_exp; /* a capsule to save |cur_type| and |cur_exp| */
14785 if ( mp->cur_cmd<min_command ) {
14786 save_exp=mp_stash_cur_exp(mp);
14788 if ( mp->cur_cmd==defined_macro )
14789 mp_macro_call(mp, mp->cur_mod,null,mp->cur_sym);
14793 } while (mp->cur_cmd<min_command);
14794 mp_unstash_cur_exp(mp, save_exp); /* that restores |cur_type| and |cur_exp| */
14798 @ Now let's consider the |macro_call| procedure, which is used to start up
14799 all user-defined macros. Since the arguments to a macro might be expressions,
14800 |macro_call| is recursive.
14803 The first parameter to |macro_call| points to the reference count of the
14804 token list that defines the macro. The second parameter contains any
14805 arguments that have already been parsed (see below). The third parameter
14806 points to the symbolic token that names the macro. If the third parameter
14807 is |null|, the macro was defined by \&{vardef}, so its name can be
14808 reconstructed from the prefix and ``at'' arguments found within the
14811 What is this second parameter? It's simply a linked list of one-word items,
14812 whose |info| fields point to the arguments. In other words, if |arg_list=null|,
14813 no arguments have been scanned yet; otherwise |info(arg_list)| points to
14814 the first scanned argument, and |link(arg_list)| points to the list of
14815 further arguments (if any).
14817 Arguments of type \&{expr} are so-called capsules, which we will
14818 discuss later when we concentrate on expressions; they can be
14819 recognized easily because their |link| field is |void|. Arguments of type
14820 \&{suffix} and \&{text} are token lists without reference counts.
14822 @ After argument scanning is complete, the arguments are moved to the
14823 |param_stack|. (They can't be put on that stack any sooner, because
14824 the stack is growing and shrinking in unpredictable ways as more arguments
14825 are being acquired.) Then the macro body is fed to the scanner; i.e.,
14826 the replacement text of the macro is placed at the top of the \MP's
14827 input stack, so that |get_t_next| will proceed to read it next.
14829 @<Declare the procedure called |macro_call|@>=
14830 @<Declare the procedure called |print_macro_name|@>
14831 @<Declare the procedure called |print_arg|@>
14832 @<Declare the procedure called |scan_text_arg|@>
14833 void mp_macro_call (MP mp,pointer def_ref, pointer arg_list,
14834 pointer macro_name) ;
14837 void mp_macro_call (MP mp,pointer def_ref, pointer arg_list,
14838 pointer macro_name) {
14839 /* invokes a user-defined control sequence */
14840 pointer r; /* current node in the macro's token list */
14841 pointer p,q; /* for list manipulation */
14842 integer n; /* the number of arguments */
14843 pointer tail = 0; /* tail of the argument list */
14844 pointer l_delim=0,r_delim=0; /* a delimiter pair */
14845 r=link(def_ref); add_mac_ref(def_ref);
14846 if ( arg_list==null ) {
14849 @<Determine the number |n| of arguments already supplied,
14850 and set |tail| to the tail of |arg_list|@>;
14852 if ( mp->internal[mp_tracing_macros]>0 ) {
14853 @<Show the text of the macro being expanded, and the existing arguments@>;
14855 @<Scan the remaining arguments, if any; set |r| to the first token
14856 of the replacement text@>;
14857 @<Feed the arguments and replacement text to the scanner@>;
14860 @ @<Show the text of the macro...@>=
14861 mp_begin_diagnostic(mp); mp_print_ln(mp);
14862 mp_print_macro_name(mp, arg_list,macro_name);
14863 if ( n==3 ) mp_print(mp, "@@#"); /* indicate a suffixed macro */
14864 mp_show_macro(mp, def_ref,null,100000);
14865 if ( arg_list!=null ) {
14869 mp_print_arg(mp, q,n,0);
14870 incr(n); p=link(p);
14873 mp_end_diagnostic(mp, false)
14876 @ @<Declare the procedure called |print_macro_name|@>=
14877 void mp_print_macro_name (MP mp,pointer a, pointer n);
14880 void mp_print_macro_name (MP mp,pointer a, pointer n) {
14881 pointer p,q; /* they traverse the first part of |a| */
14887 mp_print_text(info(info(link(a))));
14890 while ( link(q)!=null ) q=link(q);
14891 link(q)=info(link(a));
14892 mp_show_token_list(mp, p,null,1000,0);
14898 @ @<Declare the procedure called |print_arg|@>=
14899 void mp_print_arg (MP mp,pointer q, integer n, pointer b) ;
14902 void mp_print_arg (MP mp,pointer q, integer n, pointer b) {
14903 if ( link(q)==mp_void ) mp_print_nl(mp, "(EXPR");
14904 else if ( (b<text_base)&&(b!=text_macro) ) mp_print_nl(mp, "(SUFFIX");
14905 else mp_print_nl(mp, "(TEXT");
14906 mp_print_int(mp, n); mp_print(mp, ")<-");
14907 if ( link(q)==mp_void ) mp_print_exp(mp, q,1);
14908 else mp_show_token_list(mp, q,null,1000,0);
14911 @ @<Determine the number |n| of arguments already supplied...@>=
14913 n=1; tail=arg_list;
14914 while ( link(tail)!=null ) {
14915 incr(n); tail=link(tail);
14919 @ @<Scan the remaining arguments, if any; set |r|...@>=
14920 mp->cur_cmd=comma+1; /* anything |<>comma| will do */
14921 while ( info(r)>=expr_base ) {
14922 @<Scan the delimited argument represented by |info(r)|@>;
14925 if ( mp->cur_cmd==comma ) {
14926 print_err("Too many arguments to ");
14927 @.Too many arguments...@>
14928 mp_print_macro_name(mp, arg_list,macro_name); mp_print_char(mp, ';');
14929 mp_print_nl(mp, " Missing `"); mp_print_text(r_delim);
14931 mp_print(mp, "' has been inserted");
14932 help3("I'm going to assume that the comma I just read was a")
14933 ("right delimiter, and then I'll begin expanding the macro.")
14934 ("You might want to delete some tokens before continuing.");
14937 if ( info(r)!=general_macro ) {
14938 @<Scan undelimited argument(s)@>;
14942 @ At this point, the reader will find it advisable to review the explanation
14943 of token list format that was presented earlier, paying special attention to
14944 the conventions that apply only at the beginning of a macro's token list.
14946 On the other hand, the reader will have to take the expression-parsing
14947 aspects of the following program on faith; we will explain |cur_type|
14948 and |cur_exp| later. (Several things in this program depend on each other,
14949 and it's necessary to jump into the circle somewhere.)
14951 @<Scan the delimited argument represented by |info(r)|@>=
14952 if ( mp->cur_cmd!=comma ) {
14954 if ( mp->cur_cmd!=left_delimiter ) {
14955 print_err("Missing argument to ");
14956 @.Missing argument...@>
14957 mp_print_macro_name(mp, arg_list,macro_name);
14958 help3("That macro has more parameters than you thought.")
14959 ("I'll continue by pretending that each missing argument")
14960 ("is either zero or null.");
14961 if ( info(r)>=suffix_base ) {
14962 mp->cur_exp=null; mp->cur_type=mp_token_list;
14964 mp->cur_exp=0; mp->cur_type=mp_known;
14966 mp_back_error(mp); mp->cur_cmd=right_delimiter;
14969 l_delim=mp->cur_sym; r_delim=mp->cur_mod;
14971 @<Scan the argument represented by |info(r)|@>;
14972 if ( mp->cur_cmd!=comma )
14973 @<Check that the proper right delimiter was present@>;
14975 @<Append the current expression to |arg_list|@>
14977 @ @<Check that the proper right delim...@>=
14978 if ( (mp->cur_cmd!=right_delimiter)||(mp->cur_mod!=l_delim) ) {
14979 if ( info(link(r))>=expr_base ) {
14980 mp_missing_err(mp, ",");
14982 help3("I've finished reading a macro argument and am about to")
14983 ("read another; the arguments weren't delimited correctly.")
14984 ("You might want to delete some tokens before continuing.");
14985 mp_back_error(mp); mp->cur_cmd=comma;
14987 mp_missing_err(mp, str(text(r_delim)));
14989 help2("I've gotten to the end of the macro parameter list.")
14990 ("You might want to delete some tokens before continuing.");
14995 @ A \&{suffix} or \&{text} parameter will have been scanned as
14996 a token list pointed to by |cur_exp|, in which case we will have
14997 |cur_type=token_list|.
14999 @<Append the current expression to |arg_list|@>=
15001 p=mp_get_avail(mp);
15002 if ( mp->cur_type==mp_token_list ) info(p)=mp->cur_exp;
15003 else info(p)=mp_stash_cur_exp(mp);
15004 if ( mp->internal[mp_tracing_macros]>0 ) {
15005 mp_begin_diagnostic(mp); mp_print_arg(mp, info(p),n,info(r));
15006 mp_end_diagnostic(mp, false);
15008 if ( arg_list==null ) arg_list=p;
15013 @ @<Scan the argument represented by |info(r)|@>=
15014 if ( info(r)>=text_base ) {
15015 mp_scan_text_arg(mp, l_delim,r_delim);
15018 if ( info(r)>=suffix_base ) mp_scan_suffix(mp);
15019 else mp_scan_expression(mp);
15022 @ The parameters to |scan_text_arg| are either a pair of delimiters
15023 or zero; the latter case is for undelimited text arguments, which
15024 end with the first semicolon or \&{endgroup} or \&{end} that is not
15025 contained in a group.
15027 @<Declare the procedure called |scan_text_arg|@>=
15028 void mp_scan_text_arg (MP mp,pointer l_delim, pointer r_delim) ;
15031 void mp_scan_text_arg (MP mp,pointer l_delim, pointer r_delim) {
15032 integer balance; /* excess of |l_delim| over |r_delim| */
15033 pointer p; /* list tail */
15034 mp->warning_info=l_delim; mp->scanner_status=absorbing;
15035 p=hold_head; balance=1; link(hold_head)=null;
15038 if ( l_delim==0 ) {
15039 @<Adjust the balance for an undelimited argument; |break| if done@>;
15041 @<Adjust the balance for a delimited argument; |break| if done@>;
15043 link(p)=mp_cur_tok(mp); p=link(p);
15045 mp->cur_exp=link(hold_head); mp->cur_type=mp_token_list;
15046 mp->scanner_status=normal;
15049 @ @<Adjust the balance for a delimited argument...@>=
15050 if ( mp->cur_cmd==right_delimiter ) {
15051 if ( mp->cur_mod==l_delim ) {
15053 if ( balance==0 ) break;
15055 } else if ( mp->cur_cmd==left_delimiter ) {
15056 if ( mp->cur_mod==r_delim ) incr(balance);
15059 @ @<Adjust the balance for an undelimited...@>=
15060 if ( end_of_statement ) { /* |cur_cmd=semicolon|, |end_group|, or |stop| */
15061 if ( balance==1 ) { break; }
15062 else { if ( mp->cur_cmd==end_group ) decr(balance); }
15063 } else if ( mp->cur_cmd==begin_group ) {
15067 @ @<Scan undelimited argument(s)@>=
15069 if ( info(r)<text_macro ) {
15071 if ( info(r)!=suffix_macro ) {
15072 if ( (mp->cur_cmd==equals)||(mp->cur_cmd==assignment) ) mp_get_x_next(mp);
15076 case primary_macro:mp_scan_primary(mp); break;
15077 case secondary_macro:mp_scan_secondary(mp); break;
15078 case tertiary_macro:mp_scan_tertiary(mp); break;
15079 case expr_macro:mp_scan_expression(mp); break;
15081 @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>;
15084 @<Scan a suffix with optional delimiters@>;
15086 case text_macro:mp_scan_text_arg(mp, 0,0); break;
15087 } /* there are no other cases */
15089 @<Append the current expression to |arg_list|@>;
15092 @ @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>=
15094 mp_scan_expression(mp); p=mp_get_avail(mp); info(p)=mp_stash_cur_exp(mp);
15095 if ( mp->internal[mp_tracing_macros]>0 ) {
15096 mp_begin_diagnostic(mp); mp_print_arg(mp, info(p),n,0);
15097 mp_end_diagnostic(mp, false);
15099 if ( arg_list==null ) arg_list=p; else link(tail)=p;
15101 if ( mp->cur_cmd!=of_token ) {
15102 mp_missing_err(mp, "of"); mp_print(mp, " for ");
15104 mp_print_macro_name(mp, arg_list,macro_name);
15105 help1("I've got the first argument; will look now for the other.");
15108 mp_get_x_next(mp); mp_scan_primary(mp);
15111 @ @<Scan a suffix with optional delimiters@>=
15113 if ( mp->cur_cmd!=left_delimiter ) {
15116 l_delim=mp->cur_sym; r_delim=mp->cur_mod; mp_get_x_next(mp);
15118 mp_scan_suffix(mp);
15119 if ( l_delim!=null ) {
15120 if ((mp->cur_cmd!=right_delimiter)||(mp->cur_mod!=l_delim) ) {
15121 mp_missing_err(mp, str(text(r_delim)));
15123 help2("I've gotten to the end of the macro parameter list.")
15124 ("You might want to delete some tokens before continuing.");
15131 @ Before we put a new token list on the input stack, it is wise to clean off
15132 all token lists that have recently been depleted. Then a user macro that ends
15133 with a call to itself will not require unbounded stack space.
15135 @<Feed the arguments and replacement text to the scanner@>=
15136 while ( token_state &&(loc==null) ) mp_end_token_list(mp); /* conserve stack space */
15137 if ( mp->param_ptr+n>mp->max_param_stack ) {
15138 mp->max_param_stack=mp->param_ptr+n;
15139 if ( mp->max_param_stack>mp->param_size )
15140 mp_overflow(mp, "parameter stack size",mp->param_size);
15141 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
15143 mp_begin_token_list(mp, def_ref,macro); name=macro_name; loc=r;
15147 mp->param_stack[mp->param_ptr]=info(p); incr(mp->param_ptr); p=link(p);
15149 mp_flush_list(mp, arg_list);
15152 @ It's sometimes necessary to put a single argument onto |param_stack|.
15153 The |stack_argument| subroutine does this.
15155 @c void mp_stack_argument (MP mp,pointer p) {
15156 if ( mp->param_ptr==mp->max_param_stack ) {
15157 incr(mp->max_param_stack);
15158 if ( mp->max_param_stack>mp->param_size )
15159 mp_overflow(mp, "parameter stack size",mp->param_size);
15160 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
15162 mp->param_stack[mp->param_ptr]=p; incr(mp->param_ptr);
15165 @* \[33] Conditional processing.
15166 Let's consider now the way \&{if} commands are handled.
15168 Conditions can be inside conditions, and this nesting has a stack
15169 that is independent of other stacks.
15170 Four global variables represent the top of the condition stack:
15171 |cond_ptr| points to pushed-down entries, if~any; |cur_if| tells whether
15172 we are processing \&{if} or \&{elseif}; |if_limit| specifies
15173 the largest code of a |fi_or_else| command that is syntactically legal;
15174 and |if_line| is the line number at which the current conditional began.
15176 If no conditions are currently in progress, the condition stack has the
15177 special state |cond_ptr=null|, |if_limit=normal|, |cur_if=0|, |if_line=0|.
15178 Otherwise |cond_ptr| points to a two-word node; the |type|, |name_type|, and
15179 |link| fields of the first word contain |if_limit|, |cur_if|, and
15180 |cond_ptr| at the next level, and the second word contains the
15181 corresponding |if_line|.
15183 @d if_node_size 2 /* number of words in stack entry for conditionals */
15184 @d if_line_field(A) mp->mem[(A)+1].cint
15185 @d if_code 1 /* code for \&{if} being evaluated */
15186 @d fi_code 2 /* code for \&{fi} */
15187 @d else_code 3 /* code for \&{else} */
15188 @d else_if_code 4 /* code for \&{elseif} */
15191 pointer cond_ptr; /* top of the condition stack */
15192 integer if_limit; /* upper bound on |fi_or_else| codes */
15193 small_number cur_if; /* type of conditional being worked on */
15194 integer if_line; /* line where that conditional began */
15197 mp->cond_ptr=null; mp->if_limit=normal; mp->cur_if=0; mp->if_line=0;
15200 mp_primitive(mp, "if",if_test,if_code);
15201 @:if_}{\&{if} primitive@>
15202 mp_primitive(mp, "fi",fi_or_else,fi_code); mp->eqtb[frozen_fi]=mp->eqtb[mp->cur_sym];
15203 @:fi_}{\&{fi} primitive@>
15204 mp_primitive(mp, "else",fi_or_else,else_code);
15205 @:else_}{\&{else} primitive@>
15206 mp_primitive(mp, "elseif",fi_or_else,else_if_code);
15207 @:else_if_}{\&{elseif} primitive@>
15209 @ @<Cases of |print_cmd_mod|...@>=
15213 case if_code:mp_print(mp, "if"); break;
15214 case fi_code:mp_print(mp, "fi"); break;
15215 case else_code:mp_print(mp, "else"); break;
15216 default: mp_print(mp, "elseif"); break;
15220 @ Here is a procedure that ignores text until coming to an \&{elseif},
15221 \&{else}, or \&{fi} at level zero of $\&{if}\ldots\&{fi}$
15222 nesting. After it has acted, |cur_mod| will indicate the token that
15225 \MP's smallest two command codes are |if_test| and |fi_or_else|; this
15226 makes the skipping process a bit simpler.
15229 void mp_pass_text (MP mp) {
15231 mp->scanner_status=skipping;
15232 mp->warning_info=mp_true_line(mp);
15235 if ( mp->cur_cmd<=fi_or_else ) {
15236 if ( mp->cur_cmd<fi_or_else ) {
15240 if ( mp->cur_mod==fi_code ) decr(l);
15243 @<Decrease the string reference count,
15244 if the current token is a string@>;
15247 mp->scanner_status=normal;
15250 @ @<Decrease the string reference count...@>=
15251 if ( mp->cur_cmd==string_token ) { delete_str_ref(mp->cur_mod); }
15253 @ When we begin to process a new \&{if}, we set |if_limit:=if_code|; then
15254 if \&{elseif} or \&{else} or \&{fi} occurs before the current \&{if}
15255 condition has been evaluated, a colon will be inserted.
15256 A construction like `\.{if fi}' would otherwise get \MP\ confused.
15258 @<Push the condition stack@>=
15259 { p=mp_get_node(mp, if_node_size); link(p)=mp->cond_ptr; type(p)=mp->if_limit;
15260 name_type(p)=mp->cur_if; if_line_field(p)=mp->if_line;
15261 mp->cond_ptr=p; mp->if_limit=if_code; mp->if_line=mp_true_line(mp);
15262 mp->cur_if=if_code;
15265 @ @<Pop the condition stack@>=
15266 { p=mp->cond_ptr; mp->if_line=if_line_field(p);
15267 mp->cur_if=name_type(p); mp->if_limit=type(p); mp->cond_ptr=link(p);
15268 mp_free_node(mp, p,if_node_size);
15271 @ Here's a procedure that changes the |if_limit| code corresponding to
15272 a given value of |cond_ptr|.
15274 @c void mp_change_if_limit (MP mp,small_number l, pointer p) {
15276 if ( p==mp->cond_ptr ) {
15277 mp->if_limit=l; /* that's the easy case */
15281 if ( q==null ) mp_confusion(mp, "if");
15282 @:this can't happen if}{\quad if@>
15283 if ( link(q)==p ) {
15291 @ The user is supposed to put colons into the proper parts of conditional
15292 statements. Therefore, \MP\ has to check for their presence.
15295 void mp_check_colon (MP mp) {
15296 if ( mp->cur_cmd!=colon ) {
15297 mp_missing_err(mp, ":");
15299 help2("There should've been a colon after the condition.")
15300 ("I shall pretend that one was there.");;
15305 @ A condition is started when the |get_x_next| procedure encounters
15306 an |if_test| command; in that case |get_x_next| calls |conditional|,
15307 which is a recursive procedure.
15310 @c void mp_conditional (MP mp) {
15311 pointer save_cond_ptr; /* |cond_ptr| corresponding to this conditional */
15312 int new_if_limit; /* future value of |if_limit| */
15313 pointer p; /* temporary register */
15314 @<Push the condition stack@>;
15315 save_cond_ptr=mp->cond_ptr;
15317 mp_get_boolean(mp); new_if_limit=else_if_code;
15318 if ( mp->internal[mp_tracing_commands]>unity ) {
15319 @<Display the boolean value of |cur_exp|@>;
15322 mp_check_colon(mp);
15323 if ( mp->cur_exp==true_code ) {
15324 mp_change_if_limit(mp, new_if_limit,save_cond_ptr);
15325 return; /* wait for \&{elseif}, \&{else}, or \&{fi} */
15327 @<Skip to \&{elseif} or \&{else} or \&{fi}, then |goto done|@>;
15329 mp->cur_if=mp->cur_mod; mp->if_line=mp_true_line(mp);
15330 if ( mp->cur_mod==fi_code ) {
15331 @<Pop the condition stack@>
15332 } else if ( mp->cur_mod==else_if_code ) {
15335 mp->cur_exp=true_code; new_if_limit=fi_code; mp_get_x_next(mp);
15340 @ In a construction like `\&{if} \&{if} \&{true}: $0=1$: \\{foo}
15341 \&{else}: \\{bar} \&{fi}', the first \&{else}
15342 that we come to after learning that the \&{if} is false is not the
15343 \&{else} we're looking for. Hence the following curious logic is needed.
15345 @<Skip to \&{elseif}...@>=
15348 if ( mp->cond_ptr==save_cond_ptr ) goto DONE;
15349 else if ( mp->cur_mod==fi_code ) @<Pop the condition stack@>;
15353 @ @<Display the boolean value...@>=
15354 { mp_begin_diagnostic(mp);
15355 if ( mp->cur_exp==true_code ) mp_print(mp, "{true}");
15356 else mp_print(mp, "{false}");
15357 mp_end_diagnostic(mp, false);
15360 @ The processing of conditionals is complete except for the following
15361 code, which is actually part of |get_x_next|. It comes into play when
15362 \&{elseif}, \&{else}, or \&{fi} is scanned.
15364 @<Terminate the current conditional and skip to \&{fi}@>=
15365 if ( mp->cur_mod>mp->if_limit ) {
15366 if ( mp->if_limit==if_code ) { /* condition not yet evaluated */
15367 mp_missing_err(mp, ":");
15369 mp_back_input(mp); mp->cur_sym=frozen_colon; mp_ins_error(mp);
15371 print_err("Extra "); mp_print_cmd_mod(mp, fi_or_else,mp->cur_mod);
15375 help1("I'm ignoring this; it doesn't match any if.");
15379 while ( mp->cur_mod!=fi_code ) mp_pass_text(mp); /* skip to \&{fi} */
15380 @<Pop the condition stack@>;
15383 @* \[34] Iterations.
15384 To bring our treatment of |get_x_next| to a close, we need to consider what
15385 \MP\ does when it sees \&{for}, \&{forsuffixes}, and \&{forever}.
15387 There's a global variable |loop_ptr| that keeps track of the \&{for} loops
15388 that are currently active. If |loop_ptr=null|, no loops are in progress;
15389 otherwise |info(loop_ptr)| points to the iterative text of the current
15390 (innermost) loop, and |link(loop_ptr)| points to the data for any other
15391 loops that enclose the current one.
15393 A loop-control node also has two other fields, called |loop_type| and
15394 |loop_list|, whose contents depend on the type of loop:
15396 \yskip\indent|loop_type(loop_ptr)=null| means that |loop_list(loop_ptr)|
15397 points to a list of one-word nodes whose |info| fields point to the
15398 remaining argument values of a suffix list and expression list.
15400 \yskip\indent|loop_type(loop_ptr)=mp_void| means that the current loop is
15403 \yskip\indent|loop_type(loop_ptr)=progression_flag| means that
15404 |p=loop_list(loop_ptr)| points to a ``progression node'' and |value(p)|,
15405 |step_size(p)|, and |final_value(p)| contain the data for an arithmetic
15408 \yskip\indent|loop_type(loop_ptr)=p>mp_void| means that |p| points to an edge
15409 header and |loop_list(loop_ptr)| points into the graphical object list for
15412 \yskip\noindent In the case of a progression node, the first word is not used
15413 because the link field of words in the dynamic memory area cannot be arbitrary.
15415 @d loop_list_loc(A) ((A)+1) /* where the |loop_list| field resides */
15416 @d loop_type(A) info(loop_list_loc((A))) /* the type of \&{for} loop */
15417 @d loop_list(A) link(loop_list_loc((A))) /* the remaining list elements */
15418 @d loop_node_size 2 /* the number of words in a loop control node */
15419 @d progression_node_size 4 /* the number of words in a progression node */
15420 @d step_size(A) mp->mem[(A)+2].sc /* the step size in an arithmetic progression */
15421 @d final_value(A) mp->mem[(A)+3].sc /* the final value in an arithmetic progression */
15422 @d progression_flag (null+2)
15423 /* |loop_type| value when |loop_list| points to a progression node */
15426 pointer loop_ptr; /* top of the loop-control-node stack */
15431 @ If the expressions that define an arithmetic progression in
15432 a \&{for} loop don't have known numeric values, the |bad_for|
15433 subroutine screams at the user.
15435 @c void mp_bad_for (MP mp, const char * s) {
15436 mp_disp_err(mp, null,"Improper "); /* show the bad expression above the message */
15437 @.Improper...replaced by 0@>
15438 mp_print(mp, s); mp_print(mp, " has been replaced by 0");
15439 help4("When you say `for x=a step b until c',")
15440 ("the initial value `a' and the step size `b'")
15441 ("and the final value `c' must have known numeric values.")
15442 ("I'm zeroing this one. Proceed, with fingers crossed.");
15443 mp_put_get_flush_error(mp, 0);
15446 @ Here's what \MP\ does when \&{for}, \&{forsuffixes}, or \&{forever}
15447 has just been scanned. (This code requires slight familiarity with
15448 expression-parsing routines that we have not yet discussed; but it seems
15449 to belong in the present part of the program, even though the original author
15450 didn't write it until later. The reader may wish to come back to it.)
15452 @c void mp_begin_iteration (MP mp) {
15453 halfword m; /* |expr_base| (\&{for}) or |suffix_base| (\&{forsuffixes}) */
15454 halfword n; /* hash address of the current symbol */
15455 pointer s; /* the new loop-control node */
15456 pointer p; /* substitution list for |scan_toks| */
15457 pointer q; /* link manipulation register */
15458 pointer pp; /* a new progression node */
15459 m=mp->cur_mod; n=mp->cur_sym; s=mp_get_node(mp, loop_node_size);
15460 if ( m==start_forever ){
15461 loop_type(s)=mp_void; p=null; mp_get_x_next(mp);
15463 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
15464 info(p)=mp->cur_sym; value(p)=m;
15466 if ( mp->cur_cmd==within_token ) {
15467 @<Set up a picture iteration@>;
15469 @<Check for the |"="| or |":="| in a loop header@>;
15470 @<Scan the values to be used in the loop@>;
15473 @<Check for the presence of a colon@>;
15474 @<Scan the loop text and put it on the loop control stack@>;
15475 mp_resume_iteration(mp);
15478 @ @<Check for the |"="| or |":="| in a loop header@>=
15479 if ( (mp->cur_cmd!=equals)&&(mp->cur_cmd!=assignment) ) {
15480 mp_missing_err(mp, "=");
15482 help3("The next thing in this loop should have been `=' or `:='.")
15483 ("But don't worry; I'll pretend that an equals sign")
15484 ("was present, and I'll look for the values next.");
15488 @ @<Check for the presence of a colon@>=
15489 if ( mp->cur_cmd!=colon ) {
15490 mp_missing_err(mp, ":");
15492 help3("The next thing in this loop should have been a `:'.")
15493 ("So I'll pretend that a colon was present;")
15494 ("everything from here to `endfor' will be iterated.");
15498 @ We append a special |frozen_repeat_loop| token in place of the
15499 `\&{endfor}' at the end of the loop. This will come through \MP's scanner
15500 at the proper time to cause the loop to be repeated.
15502 (If the user tries some shenanigan like `\&{for} $\ldots$ \&{let} \&{endfor}',
15503 he will be foiled by the |get_symbol| routine, which keeps frozen
15504 tokens unchanged. Furthermore the |frozen_repeat_loop| is an \&{outer}
15505 token, so it won't be lost accidentally.)
15507 @ @<Scan the loop text...@>=
15508 q=mp_get_avail(mp); info(q)=frozen_repeat_loop;
15509 mp->scanner_status=loop_defining; mp->warning_info=n;
15510 info(s)=mp_scan_toks(mp, iteration,p,q,0); mp->scanner_status=normal;
15511 link(s)=mp->loop_ptr; mp->loop_ptr=s
15513 @ @<Initialize table...@>=
15514 eq_type(frozen_repeat_loop)=repeat_loop+outer_tag;
15515 text(frozen_repeat_loop)=intern(" ENDFOR");
15517 @ The loop text is inserted into \MP's scanning apparatus by the
15518 |resume_iteration| routine.
15520 @c void mp_resume_iteration (MP mp) {
15521 pointer p,q; /* link registers */
15522 p=loop_type(mp->loop_ptr);
15523 if ( p==progression_flag ) {
15524 p=loop_list(mp->loop_ptr); /* now |p| points to a progression node */
15525 mp->cur_exp=value(p);
15526 if ( @<The arithmetic progression has ended@> ) {
15527 mp_stop_iteration(mp);
15530 mp->cur_type=mp_known; q=mp_stash_cur_exp(mp); /* make |q| an \&{expr} argument */
15531 value(p)=mp->cur_exp+step_size(p); /* set |value(p)| for the next iteration */
15532 } else if ( p==null ) {
15533 p=loop_list(mp->loop_ptr);
15535 mp_stop_iteration(mp);
15538 loop_list(mp->loop_ptr)=link(p); q=info(p); free_avail(p);
15539 } else if ( p==mp_void ) {
15540 mp_begin_token_list(mp, info(mp->loop_ptr),forever_text); return;
15542 @<Make |q| a capsule containing the next picture component from
15543 |loop_list(loop_ptr)| or |goto not_found|@>;
15545 mp_begin_token_list(mp, info(mp->loop_ptr),loop_text);
15546 mp_stack_argument(mp, q);
15547 if ( mp->internal[mp_tracing_commands]>unity ) {
15548 @<Trace the start of a loop@>;
15552 mp_stop_iteration(mp);
15555 @ @<The arithmetic progression has ended@>=
15556 ((step_size(p)>0)&&(mp->cur_exp>final_value(p)))||
15557 ((step_size(p)<0)&&(mp->cur_exp<final_value(p)))
15559 @ @<Trace the start of a loop@>=
15561 mp_begin_diagnostic(mp); mp_print_nl(mp, "{loop value=");
15563 if ( (q!=null)&&(link(q)==mp_void) ) mp_print_exp(mp, q,1);
15564 else mp_show_token_list(mp, q,null,50,0);
15565 mp_print_char(mp, '}'); mp_end_diagnostic(mp, false);
15568 @ @<Make |q| a capsule containing the next picture component from...@>=
15569 { q=loop_list(mp->loop_ptr);
15570 if ( q==null ) goto NOT_FOUND;
15571 skip_component(q) goto NOT_FOUND;
15572 mp->cur_exp=mp_copy_objects(mp, loop_list(mp->loop_ptr),q);
15573 mp_init_bbox(mp, mp->cur_exp);
15574 mp->cur_type=mp_picture_type;
15575 loop_list(mp->loop_ptr)=q;
15576 q=mp_stash_cur_exp(mp);
15579 @ A level of loop control disappears when |resume_iteration| has decided
15580 not to resume, or when an \&{exitif} construction has removed the loop text
15581 from the input stack.
15583 @c void mp_stop_iteration (MP mp) {
15584 pointer p,q; /* the usual */
15585 p=loop_type(mp->loop_ptr);
15586 if ( p==progression_flag ) {
15587 mp_free_node(mp, loop_list(mp->loop_ptr),progression_node_size);
15588 } else if ( p==null ){
15589 q=loop_list(mp->loop_ptr);
15590 while ( q!=null ) {
15593 if ( link(p)==mp_void ) { /* it's an \&{expr} parameter */
15594 mp_recycle_value(mp, p); mp_free_node(mp, p,value_node_size);
15596 mp_flush_token_list(mp, p); /* it's a \&{suffix} or \&{text} parameter */
15599 p=q; q=link(q); free_avail(p);
15601 } else if ( p>progression_flag ) {
15602 delete_edge_ref(p);
15604 p=mp->loop_ptr; mp->loop_ptr=link(p); mp_flush_token_list(mp, info(p));
15605 mp_free_node(mp, p,loop_node_size);
15608 @ Now that we know all about loop control, we can finish up
15609 the missing portion of |begin_iteration| and we'll be done.
15611 The following code is performed after the `\.=' has been scanned in
15612 a \&{for} construction (if |m=expr_base|) or a \&{forsuffixes} construction
15613 (if |m=suffix_base|).
15615 @<Scan the values to be used in the loop@>=
15616 loop_type(s)=null; q=loop_list_loc(s); link(q)=null; /* |link(q)=loop_list(s)| */
15619 if ( m!=expr_base ) {
15620 mp_scan_suffix(mp);
15622 if ( mp->cur_cmd>=colon ) if ( mp->cur_cmd<=comma )
15624 mp_scan_expression(mp);
15625 if ( mp->cur_cmd==step_token ) if ( q==loop_list_loc(s) ) {
15626 @<Prepare for step-until construction and |break|@>;
15628 mp->cur_exp=mp_stash_cur_exp(mp);
15630 link(q)=mp_get_avail(mp); q=link(q);
15631 info(q)=mp->cur_exp; mp->cur_type=mp_vacuous;
15634 } while (mp->cur_cmd==comma)
15636 @ @<Prepare for step-until construction and |break|@>=
15638 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "initial value");
15639 pp=mp_get_node(mp, progression_node_size); value(pp)=mp->cur_exp;
15640 mp_get_x_next(mp); mp_scan_expression(mp);
15641 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "step size");
15642 step_size(pp)=mp->cur_exp;
15643 if ( mp->cur_cmd!=until_token ) {
15644 mp_missing_err(mp, "until");
15645 @.Missing `until'@>
15646 help2("I assume you meant to say `until' after `step'.")
15647 ("So I'll look for the final value and colon next.");
15650 mp_get_x_next(mp); mp_scan_expression(mp);
15651 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "final value");
15652 final_value(pp)=mp->cur_exp; loop_list(s)=pp;
15653 loop_type(s)=progression_flag;
15657 @ The last case is when we have just seen ``\&{within}'', and we need to
15658 parse a picture expression and prepare to iterate over it.
15660 @<Set up a picture iteration@>=
15661 { mp_get_x_next(mp);
15662 mp_scan_expression(mp);
15663 @<Make sure the current expression is a known picture@>;
15664 loop_type(s)=mp->cur_exp; mp->cur_type=mp_vacuous;
15665 q=link(dummy_loc(mp->cur_exp));
15667 if ( is_start_or_stop(q) )
15668 if ( mp_skip_1component(mp, q)==null ) q=link(q);
15672 @ @<Make sure the current expression is a known picture@>=
15673 if ( mp->cur_type!=mp_picture_type ) {
15674 mp_disp_err(mp, null,"Improper iteration spec has been replaced by nullpicture");
15675 help1("When you say `for x in p', p must be a known picture.");
15676 mp_put_get_flush_error(mp, mp_get_node(mp, edge_header_size));
15677 mp_init_edges(mp, mp->cur_exp); mp->cur_type=mp_picture_type;
15680 @* \[35] File names.
15681 It's time now to fret about file names. Besides the fact that different
15682 operating systems treat files in different ways, we must cope with the
15683 fact that completely different naming conventions are used by different
15684 groups of people. The following programs show what is required for one
15685 particular operating system; similar routines for other systems are not
15686 difficult to devise.
15687 @^system dependencies@>
15689 \MP\ assumes that a file name has three parts: the name proper; its
15690 ``extension''; and a ``file area'' where it is found in an external file
15691 system. The extension of an input file is assumed to be
15692 `\.{.mp}' unless otherwise specified; it is `\.{.log}' on the
15693 transcript file that records each run of \MP; it is `\.{.tfm}' on the font
15694 metric files that describe characters in any fonts created by \MP; it is
15695 `\.{.ps}' or `.{\it nnn}' for some number {\it nnn} on the \ps\ output files;
15696 and it is `\.{.mem}' on the mem files written by \.{INIMP} to initialize \MP.
15697 The file area can be arbitrary on input files, but files are usually
15698 output to the user's current area. If an input file cannot be
15699 found on the specified area, \MP\ will look for it on a special system
15700 area; this special area is intended for commonly used input files.
15702 Simple uses of \MP\ refer only to file names that have no explicit
15703 extension or area. For example, a person usually says `\.{input} \.{cmr10}'
15704 instead of `\.{input} \.{cmr10.new}'. Simple file
15705 names are best, because they make the \MP\ source files portable;
15706 whenever a file name consists entirely of letters and digits, it should be
15707 treated in the same way by all implementations of \MP. However, users
15708 need the ability to refer to other files in their environment, especially
15709 when responding to error messages concerning unopenable files; therefore
15710 we want to let them use the syntax that appears in their favorite
15713 @ \MP\ uses the same conventions that have proved to be satisfactory for
15714 \TeX\ and \MF. In order to isolate the system-dependent aspects of file names,
15715 @^system dependencies@>
15716 the system-independent parts of \MP\ are expressed in terms
15717 of three system-dependent
15718 procedures called |begin_name|, |more_name|, and |end_name|. In
15719 essence, if the user-specified characters of the file name are $c_1\ldots c_n$,
15720 the system-independent driver program does the operations
15721 $$|begin_name|;\,|more_name|(c_1);\,\ldots\,;\,|more_name|(c_n);
15723 These three procedures communicate with each other via global variables.
15724 Afterwards the file name will appear in the string pool as three strings
15725 called |cur_name|\penalty10000\hskip-.05em,
15726 |cur_area|, and |cur_ext|; the latter two are null (i.e.,
15727 |""|), unless they were explicitly specified by the user.
15729 Actually the situation is slightly more complicated, because \MP\ needs
15730 to know when the file name ends. The |more_name| routine is a function
15731 (with side effects) that returns |true| on the calls |more_name|$(c_1)$,
15732 \dots, |more_name|$(c_{n-1})$. The final call |more_name|$(c_n)$
15733 returns |false|; or, it returns |true| and $c_n$ is the last character
15734 on the current input line. In other words,
15735 |more_name| is supposed to return |true| unless it is sure that the
15736 file name has been completely scanned; and |end_name| is supposed to be able
15737 to finish the assembly of |cur_name|, |cur_area|, and |cur_ext| regardless of
15738 whether $|more_name|(c_n)$ returned |true| or |false|.
15741 char * cur_name; /* name of file just scanned */
15742 char * cur_area; /* file area just scanned, or \.{""} */
15743 char * cur_ext; /* file extension just scanned, or \.{""} */
15745 @ It is easier to maintain reference counts if we assign initial values.
15748 mp->cur_name=xstrdup("");
15749 mp->cur_area=xstrdup("");
15750 mp->cur_ext=xstrdup("");
15752 @ @<Dealloc variables@>=
15753 xfree(mp->cur_area);
15754 xfree(mp->cur_name);
15755 xfree(mp->cur_ext);
15757 @ The file names we shall deal with for illustrative purposes have the
15758 following structure: If the name contains `\.>' or `\.:', the file area
15759 consists of all characters up to and including the final such character;
15760 otherwise the file area is null. If the remaining file name contains
15761 `\..', the file extension consists of all such characters from the first
15762 remaining `\..' to the end, otherwise the file extension is null.
15763 @^system dependencies@>
15765 We can scan such file names easily by using two global variables that keep track
15766 of the occurrences of area and extension delimiters. Note that these variables
15767 cannot be of type |pool_pointer| because a string pool compaction could occur
15768 while scanning a file name.
15771 integer area_delimiter;
15772 /* most recent `\.>' or `\.:' relative to |str_start[str_ptr]| */
15773 integer ext_delimiter; /* the relevant `\..', if any */
15775 @ Here now is the first of the system-dependent routines for file name scanning.
15776 @^system dependencies@>
15778 The file name length is limited to |file_name_size|. That is good, because
15779 in the current configuration we cannot call |mp_do_compaction| while a name
15780 is being scanned, |mp->area_delimiter| and |mp->ext_delimiter| are direct
15781 offsets into |mp->str_pool|. I am not in a great hurry to fix this, because
15782 calling |str_room()| just once is more efficient anyway. TODO.
15784 @<Declare subroutines for parsing file names@>=
15785 void mp_begin_name (MP mp) {
15786 xfree(mp->cur_name);
15787 xfree(mp->cur_area);
15788 xfree(mp->cur_ext);
15789 mp->area_delimiter=-1;
15790 mp->ext_delimiter=-1;
15791 str_room(file_name_size);
15794 @ And here's the second.
15795 @^system dependencies@>
15797 @<Declare subroutines for parsing file names@>=
15798 boolean mp_more_name (MP mp, ASCII_code c) {
15802 if ( (c=='>')||(c==':') ) {
15803 mp->area_delimiter=mp->pool_ptr;
15804 mp->ext_delimiter=-1;
15805 } else if ( (c=='.')&&(mp->ext_delimiter<0) ) {
15806 mp->ext_delimiter=mp->pool_ptr;
15808 append_char(c); /* contribute |c| to the current string */
15814 @^system dependencies@>
15816 @d copy_pool_segment(A,B,C) {
15817 A = xmalloc(C+1,sizeof(char));
15818 strncpy(A,(char *)(mp->str_pool+B),C);
15821 @<Declare subroutines for parsing file names@>=
15822 void mp_end_name (MP mp) {
15823 pool_pointer s; /* length of area, name, and extension */
15826 s = mp->str_start[mp->str_ptr];
15827 if ( mp->area_delimiter<0 ) {
15828 mp->cur_area=xstrdup("");
15830 len = mp->area_delimiter-s;
15831 copy_pool_segment(mp->cur_area,s,len);
15834 if ( mp->ext_delimiter<0 ) {
15835 mp->cur_ext=xstrdup("");
15836 len = mp->pool_ptr-s;
15838 copy_pool_segment(mp->cur_ext,mp->ext_delimiter,(mp->pool_ptr-mp->ext_delimiter));
15839 len = mp->ext_delimiter-s;
15841 copy_pool_segment(mp->cur_name,s,len);
15842 mp->pool_ptr=s; /* don't need this partial string */
15845 @ Conversely, here is a routine that takes three strings and prints a file
15846 name that might have produced them. (The routine is system dependent, because
15847 some operating systems put the file area last instead of first.)
15848 @^system dependencies@>
15850 @<Basic printing...@>=
15851 void mp_print_file_name (MP mp, char * n, char * a, char * e) {
15852 mp_print(mp, a); mp_print(mp, n); mp_print(mp, e);
15855 @ Another system-dependent routine is needed to convert three internal
15857 to the |name_of_file| value that is used to open files. The present code
15858 allows both lowercase and uppercase letters in the file name.
15859 @^system dependencies@>
15861 @d append_to_name(A) { c=(A);
15862 if ( k<file_name_size ) {
15863 mp->name_of_file[k]=xchr(c);
15868 @<Declare subroutines for parsing file names@>=
15869 void mp_pack_file_name (MP mp, const char *n, const char *a, const char *e) {
15870 integer k; /* number of positions filled in |name_of_file| */
15871 ASCII_code c; /* character being packed */
15872 const char *j; /* a character index */
15876 for (j=a;*j;j++) { append_to_name(*j); }
15878 for (j=n;*j;j++) { append_to_name(*j); }
15880 for (j=e;*j;j++) { append_to_name(*j); }
15882 mp->name_of_file[k]=0;
15886 @ @<Internal library declarations@>=
15887 void mp_pack_file_name (MP mp, const char *n, const char *a, const char *e) ;
15889 @ @<Option variables@>=
15890 char *mem_name; /* for commandline */
15892 @ @<Find constant sizes@>=
15893 mp->mem_name = xstrdup(opt->mem_name);
15894 if (mp->mem_name) {
15895 int l = strlen(mp->mem_name);
15897 char *test = strstr(mp->mem_name,".mem");
15898 if (test == mp->mem_name+l-4) {
15905 @ @<Dealloc variables@>=
15906 xfree(mp->mem_name);
15908 @ This part of the program becomes active when a ``virgin'' \MP\ is
15909 trying to get going, just after the preliminary initialization, or
15910 when the user is substituting another mem file by typing `\.\&' after
15911 the initial `\.{**}' prompt. The buffer contains the first line of
15912 input in |buffer[loc..(last-1)]|, where |loc<last| and |buffer[loc]<>""|.
15915 boolean mp_open_mem_name (MP mp) ;
15916 boolean mp_open_mem_file (MP mp) ;
15919 boolean mp_open_mem_name (MP mp) {
15920 if (mp->mem_name!=NULL) {
15921 int l = strlen(mp->mem_name);
15922 char *s = xstrdup (mp->mem_name);
15924 char *test = strstr(s,".mem");
15925 if (test == NULL || test != s+l-4) {
15926 s = xrealloc (s, l+5, 1);
15927 strcat (s, ".mem");
15930 s = xrealloc (s, l+5, 1);
15931 strcat (s, ".mem");
15933 mp->mem_file = (mp->open_file)(mp,s, "r", mp_filetype_memfile);
15935 if ( mp->mem_file ) return true;
15939 boolean mp_open_mem_file (MP mp) {
15940 if (mp->mem_file != NULL)
15942 if (mp_open_mem_name(mp))
15944 if (mp_xstrcmp(mp->mem_name, "plain")) {
15946 wterm_ln("Sorry, I can\'t find that mem file; will try PLAIN.");
15947 @.Sorry, I can't find...@>
15949 /* now pull out all the stops: try for the system \.{plain} file */
15950 xfree(mp->mem_name);
15951 mp->mem_name = xstrdup("plain");
15952 if (mp_open_mem_name(mp))
15956 wterm_ln("I can\'t find the PLAIN mem file!");
15957 @.I can't find PLAIN...@>
15962 @ Operating systems often make it possible to determine the exact name (and
15963 possible version number) of a file that has been opened. The following routine,
15964 which simply makes a \MP\ string from the value of |name_of_file|, should
15965 ideally be changed to deduce the full name of file~|f|, which is the file
15966 most recently opened, if it is possible to do this.
15967 @^system dependencies@>
15970 #define mp_a_make_name_string(A,B) mp_make_name_string(A)
15971 #define mp_b_make_name_string(A,B) mp_make_name_string(A)
15972 #define mp_w_make_name_string(A,B) mp_make_name_string(A)
15975 str_number mp_make_name_string (MP mp) {
15976 int k; /* index into |name_of_file| */
15977 str_room(mp->name_length);
15978 for (k=0;k<mp->name_length;k++) {
15979 append_char(xord((int)mp->name_of_file[k]));
15981 return mp_make_string(mp);
15984 @ Now let's consider the ``driver''
15985 routines by which \MP\ deals with file names
15986 in a system-independent manner. First comes a procedure that looks for a
15987 file name in the input by taking the information from the input buffer.
15988 (We can't use |get_next|, because the conversion to tokens would
15989 destroy necessary information.)
15991 This procedure doesn't allow semicolons or percent signs to be part of
15992 file names, because of other conventions of \MP.
15993 {\sl The {\logos METAFONT\/}book} doesn't
15994 use semicolons or percents immediately after file names, but some users
15995 no doubt will find it natural to do so; therefore system-dependent
15996 changes to allow such characters in file names should probably
15997 be made with reluctance, and only when an entire file name that
15998 includes special characters is ``quoted'' somehow.
15999 @^system dependencies@>
16001 @c void mp_scan_file_name (MP mp) {
16003 while ( mp->buffer[loc]==' ' ) incr(loc);
16005 if ( (mp->buffer[loc]==';')||(mp->buffer[loc]=='%') ) break;
16006 if ( ! mp_more_name(mp, mp->buffer[loc]) ) break;
16012 @ Here is another version that takes its input from a string.
16014 @<Declare subroutines for parsing file names@>=
16015 void mp_str_scan_file (MP mp, str_number s) {
16016 pool_pointer p,q; /* current position and stopping point */
16018 p=mp->str_start[s]; q=str_stop(s);
16020 if ( ! mp_more_name(mp, mp->str_pool[p]) ) break;
16026 @ And one that reads from a |char*|.
16028 @<Declare subroutines for parsing file names@>=
16029 void mp_ptr_scan_file (MP mp, char *s) {
16030 char *p, *q; /* current position and stopping point */
16032 p=s; q=p+strlen(s);
16034 if ( ! mp_more_name(mp, *p)) break;
16041 @ The global variable |job_name| contains the file name that was first
16042 \&{input} by the user. This name is extended by `\.{.log}' and `\.{ps}' and
16043 `\.{.mem}' and `\.{.tfm}' in order to make the names of \MP's output files.
16046 boolean log_opened; /* has the transcript file been opened? */
16047 char *log_name; /* full name of the log file */
16049 @ @<Option variables@>=
16050 char *job_name; /* principal file name */
16052 @ Initially |job_name=NULL|; it becomes nonzero as soon as the true name is known.
16053 We have |job_name=NULL| if and only if the `\.{log}' file has not been opened,
16054 except of course for a short time just after |job_name| has become nonzero.
16056 @<Allocate or ...@>=
16057 mp->job_name=mp_xstrdup(mp, opt->job_name);
16058 if (opt->noninteractive && opt->ini_version) {
16059 if (mp->job_name == NULL)
16060 mp->job_name=mp_xstrdup(mp,mp->mem_name);
16061 if (mp->job_name != NULL) {
16062 int l = strlen(mp->job_name);
16064 char *test = strstr(mp->job_name,".mem");
16065 if (test == mp->job_name+l-4)
16070 mp->log_opened=false;
16072 @ @<Dealloc variables@>=
16073 xfree(mp->job_name);
16075 @ Here is a routine that manufactures the output file names, assuming that
16076 |job_name<>0|. It ignores and changes the current settings of |cur_area|
16079 @d pack_cur_name mp_pack_file_name(mp, mp->cur_name,mp->cur_area,mp->cur_ext)
16082 void mp_pack_job_name (MP mp, const char *s) ;
16085 void mp_pack_job_name (MP mp, const char *s) { /* |s = ".log"|, |".mem"|, |".ps"|, or .\\{nnn} */
16086 xfree(mp->cur_name); mp->cur_name=xstrdup(mp->job_name);
16087 xfree(mp->cur_area); mp->cur_area=xstrdup("");
16088 xfree(mp->cur_ext); mp->cur_ext=xstrdup(s);
16092 @ If some trouble arises when \MP\ tries to open a file, the following
16093 routine calls upon the user to supply another file name. Parameter~|s|
16094 is used in the error message to identify the type of file; parameter~|e|
16095 is the default extension if none is given. Upon exit from the routine,
16096 variables |cur_name|, |cur_area|, |cur_ext|, and |name_of_file| are
16097 ready for another attempt at file opening.
16100 void mp_prompt_file_name (MP mp, const char * s, const char * e) ;
16102 @ @c void mp_prompt_file_name (MP mp, const char * s, const char * e) {
16103 size_t k; /* index into |buffer| */
16104 char * saved_cur_name;
16105 if ( mp->interaction==mp_scroll_mode )
16107 if (strcmp(s,"input file name")==0) {
16108 print_err("I can\'t find file `");
16109 @.I can't find file x@>
16111 print_err("I can\'t write on file `");
16112 @.I can't write on file x@>
16114 mp_print_file_name(mp, mp->cur_name,mp->cur_area,mp->cur_ext);
16115 mp_print(mp, "'.");
16116 if (strcmp(e,"")==0)
16117 mp_show_context(mp);
16118 mp_print_nl(mp, "Please type another "); mp_print(mp, s);
16120 if (mp->noninteractive || mp->interaction<mp_scroll_mode )
16121 mp_fatal_error(mp, "*** (job aborted, file error in nonstop mode)");
16122 @.job aborted, file error...@>
16123 saved_cur_name = xstrdup(mp->cur_name);
16124 clear_terminal; prompt_input(": "); @<Scan file name in the buffer@>;
16125 if (strcmp(mp->cur_ext,"")==0)
16126 mp->cur_ext=xstrdup(e);
16127 if (strlen(mp->cur_name)==0) {
16128 mp->cur_name=saved_cur_name;
16130 xfree(saved_cur_name);
16135 @ @<Scan file name in the buffer@>=
16137 mp_begin_name(mp); k=mp->first;
16138 while ( (mp->buffer[k]==' ')&&(k<mp->last) ) incr(k);
16140 if ( k==mp->last ) break;
16141 if ( ! mp_more_name(mp, mp->buffer[k]) ) break;
16147 @ The |open_log_file| routine is used to open the transcript file and to help
16148 it catch up to what has previously been printed on the terminal.
16150 @c void mp_open_log_file (MP mp) {
16151 int old_setting; /* previous |selector| setting */
16152 int k; /* index into |months| and |buffer| */
16153 int l; /* end of first input line */
16154 integer m; /* the current month */
16155 const char *months="JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC";
16156 /* abbreviations of month names */
16157 old_setting=mp->selector;
16158 if ( mp->job_name==NULL ) {
16159 mp->job_name=xstrdup("mpout");
16161 mp_pack_job_name(mp,".log");
16162 while ( ! mp_a_open_out(mp, &mp->log_file, mp_filetype_log) ) {
16163 @<Try to get a different log file name@>;
16165 mp->log_name=xstrdup(mp->name_of_file);
16166 mp->selector=log_only; mp->log_opened=true;
16167 @<Print the banner line, including the date and time@>;
16168 mp->input_stack[mp->input_ptr]=mp->cur_input;
16169 /* make sure bottom level is in memory */
16170 if (!mp->noninteractive) {
16171 mp_print_nl(mp, "**");
16173 l=mp->input_stack[0].limit_field-1; /* last position of first line */
16174 for (k=0;k<=l;k++) mp_print_str(mp, mp->buffer[k]);
16175 mp_print_ln(mp); /* now the transcript file contains the first line of input */
16177 mp->selector=old_setting+2; /* |log_only| or |term_and_log| */
16180 @ @<Dealloc variables@>=
16181 xfree(mp->log_name);
16183 @ Sometimes |open_log_file| is called at awkward moments when \MP\ is
16184 unable to print error messages or even to |show_context|.
16185 The |prompt_file_name| routine can result in a |fatal_error|, but the |error|
16186 routine will not be invoked because |log_opened| will be false.
16188 The normal idea of |mp_batch_mode| is that nothing at all should be written
16189 on the terminal. However, in the unusual case that
16190 no log file could be opened, we make an exception and allow
16191 an explanatory message to be seen.
16193 Incidentally, the program always refers to the log file as a `\.{transcript
16194 file}', because some systems cannot use the extension `\.{.log}' for
16197 @<Try to get a different log file name@>=
16199 mp->selector=term_only;
16200 mp_prompt_file_name(mp, "transcript file name",".log");
16203 @ @<Print the banner...@>=
16206 mp_print(mp, mp->mem_ident); mp_print(mp, " ");
16207 mp_print_int(mp, mp_round_unscaled(mp, mp->internal[mp_day]));
16208 mp_print_char(mp, ' ');
16209 m=mp_round_unscaled(mp, mp->internal[mp_month]);
16210 for (k=3*m-3;k<3*m;k++) { wlog_chr(months[k]); }
16211 mp_print_char(mp, ' ');
16212 mp_print_int(mp, mp_round_unscaled(mp, mp->internal[mp_year]));
16213 mp_print_char(mp, ' ');
16214 m=mp_round_unscaled(mp, mp->internal[mp_time]);
16215 mp_print_dd(mp, m / 60); mp_print_char(mp, ':'); mp_print_dd(mp, m % 60);
16218 @ The |try_extension| function tries to open an input file determined by
16219 |cur_name|, |cur_area|, and the argument |ext|. It returns |false| if it
16220 can't find the file in |cur_area| or the appropriate system area.
16222 @c boolean mp_try_extension (MP mp, const char *ext) {
16223 mp_pack_file_name(mp, mp->cur_name,mp->cur_area, ext);
16224 in_name=xstrdup(mp->cur_name);
16225 in_area=xstrdup(mp->cur_area);
16226 if ( mp_a_open_in(mp, &cur_file, mp_filetype_program) ) {
16229 mp_pack_file_name(mp, mp->cur_name,NULL,ext);
16230 return mp_a_open_in(mp, &cur_file, mp_filetype_program);
16234 @ Let's turn now to the procedure that is used to initiate file reading
16235 when an `\.{input}' command is being processed.
16237 @c void mp_start_input (MP mp) { /* \MP\ will \.{input} something */
16238 char *fname = NULL;
16239 @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>;
16241 mp_begin_file_reading(mp); /* set up |cur_file| and new level of input */
16242 if ( strlen(mp->cur_ext)==0 ) {
16243 if ( mp_try_extension(mp, ".mp") ) break;
16244 else if ( mp_try_extension(mp, "") ) break;
16245 else if ( mp_try_extension(mp, ".mf") ) break;
16246 /* |else do_nothing; | */
16247 } else if ( mp_try_extension(mp, mp->cur_ext) ) {
16250 mp_end_file_reading(mp); /* remove the level that didn't work */
16251 mp_prompt_file_name(mp, "input file name","");
16253 name=mp_a_make_name_string(mp, cur_file);
16254 fname = xstrdup(mp->name_of_file);
16255 if ( mp->job_name==NULL ) {
16256 mp->job_name=xstrdup(mp->cur_name);
16257 mp_open_log_file(mp);
16258 } /* |open_log_file| doesn't |show_context|, so |limit|
16259 and |loc| needn't be set to meaningful values yet */
16260 if ( ((int)mp->term_offset+(int)strlen(fname)) > (mp->max_print_line-2)) mp_print_ln(mp);
16261 else if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_char(mp, ' ');
16262 mp_print_char(mp, '('); incr(mp->open_parens); mp_print(mp, fname);
16265 @<Flush |name| and replace it with |cur_name| if it won't be needed@>;
16266 @<Read the first line of the new file@>;
16269 @ This code should be omitted if |a_make_name_string| returns something other
16270 than just a copy of its argument and the full file name is needed for opening
16271 \.{MPX} files or implementing the switch-to-editor option.
16272 @^system dependencies@>
16274 @<Flush |name| and replace it with |cur_name| if it won't be needed@>=
16275 mp_flush_string(mp, name); name=rts(mp->cur_name); xfree(mp->cur_name)
16277 @ If the file is empty, it is considered to contain a single blank line,
16278 so there is no need to test the return value.
16280 @<Read the first line...@>=
16283 (void)mp_input_ln(mp, cur_file );
16284 mp_firm_up_the_line(mp);
16285 mp->buffer[limit]='%'; mp->first=limit+1; loc=start;
16288 @ @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>=
16289 while ( token_state &&(loc==null) ) mp_end_token_list(mp);
16290 if ( token_state ) {
16291 print_err("File names can't appear within macros");
16292 @.File names can't...@>
16293 help3("Sorry...I've converted what follows to tokens,")
16294 ("possibly garbaging the name you gave.")
16295 ("Please delete the tokens and insert the name again.");
16298 if ( file_state ) {
16299 mp_scan_file_name(mp);
16301 xfree(mp->cur_name); mp->cur_name=xstrdup("");
16302 xfree(mp->cur_ext); mp->cur_ext =xstrdup("");
16303 xfree(mp->cur_area); mp->cur_area=xstrdup("");
16306 @ The following simple routine starts reading the \.{MPX} file associated
16307 with the current input file.
16309 @c void mp_start_mpx_input (MP mp) {
16310 char *origname = NULL; /* a copy of nameoffile */
16311 mp_pack_file_name(mp, in_name, in_area, ".mpx");
16312 @<Try to make sure |name_of_file| refers to a valid \.{MPX} file and
16313 |goto not_found| if there is a problem@>;
16314 mp_begin_file_reading(mp);
16315 if ( ! mp_a_open_in(mp, &cur_file, mp_filetype_program) ) {
16316 mp_end_file_reading(mp);
16319 name=mp_a_make_name_string(mp, cur_file);
16320 mp->mpx_name[iindex]=name; add_str_ref(name);
16321 @<Read the first line of the new file@>;
16325 @<Explain that the \.{MPX} file can't be read and |succumb|@>;
16329 @ This should ideally be changed to do whatever is necessary to create the
16330 \.{MPX} file given by |name_of_file| if it does not exist or if it is out
16331 of date. This requires invoking \.{MPtoTeX} on the |origname| and passing
16332 the results through \TeX\ and \.{DVItoMP}. (It is possible to use a
16333 completely different typesetting program if suitable postprocessor is
16334 available to perform the function of \.{DVItoMP}.)
16335 @^system dependencies@>
16337 @ @<Exported types@>=
16338 typedef int (*mp_run_make_mpx_command)(MP mp, char *origname, char *mtxname);
16340 @ @<Option variables@>=
16341 mp_run_make_mpx_command run_make_mpx;
16343 @ @<Allocate or initialize ...@>=
16344 set_callback_option(run_make_mpx);
16346 @ @<Internal library declarations@>=
16347 int mp_run_make_mpx (MP mp, char *origname, char *mtxname);
16349 @ The default does nothing.
16351 int mp_run_make_mpx (MP mp, char *origname, char *mtxname) {
16358 @ @<Try to make sure |name_of_file| refers to a valid \.{MPX} file and
16359 |goto not_found| if there is a problem@>=
16360 origname = mp_xstrdup(mp,mp->name_of_file);
16361 *(origname+strlen(origname)-1)=0; /* drop the x */
16362 if (!(mp->run_make_mpx)(mp, origname, mp->name_of_file))
16365 @ @<Explain that the \.{MPX} file can't be read and |succumb|@>=
16366 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
16367 mp_print_nl(mp, ">> ");
16368 mp_print(mp, origname);
16369 mp_print_nl(mp, ">> ");
16370 mp_print(mp, mp->name_of_file);
16371 mp_print_nl(mp, "! Unable to make mpx file");
16372 help4("The two files given above are one of your source files")
16373 ("and an auxiliary file I need to read to find out what your")
16374 ("btex..etex blocks mean. If you don't know why I had trouble,")
16375 ("try running it manually through MPtoTeX, TeX, and DVItoMP");
16378 @ The last file-opening commands are for files accessed via the \&{readfrom}
16379 @:read_from_}{\&{readfrom} primitive@>
16380 operator and the \&{write} command. Such files are stored in separate arrays.
16381 @:write_}{\&{write} primitive@>
16383 @<Types in the outer block@>=
16384 typedef unsigned int readf_index; /* |0..max_read_files| */
16385 typedef unsigned int write_index; /* |0..max_write_files| */
16388 readf_index max_read_files; /* maximum number of simultaneously open \&{readfrom} files */
16389 void ** rd_file; /* \&{readfrom} files */
16390 char ** rd_fname; /* corresponding file name or 0 if file not open */
16391 readf_index read_files; /* number of valid entries in the above arrays */
16392 write_index max_write_files; /* maximum number of simultaneously open \&{write} */
16393 void ** wr_file; /* \&{write} files */
16394 char ** wr_fname; /* corresponding file name or 0 if file not open */
16395 write_index write_files; /* number of valid entries in the above arrays */
16397 @ @<Allocate or initialize ...@>=
16398 mp->max_read_files=8;
16399 mp->rd_file = xmalloc((mp->max_read_files+1),sizeof(void *));
16400 mp->rd_fname = xmalloc((mp->max_read_files+1),sizeof(char *));
16401 memset(mp->rd_fname, 0, sizeof(char *)*(mp->max_read_files+1));
16402 mp->max_write_files=8;
16403 mp->wr_file = xmalloc((mp->max_write_files+1),sizeof(void *));
16404 mp->wr_fname = xmalloc((mp->max_write_files+1),sizeof(char *));
16405 memset(mp->wr_fname, 0, sizeof(char *)*(mp->max_write_files+1));
16408 @ This routine starts reading the file named by string~|s| without setting
16409 |loc|, |limit|, or |name|. It returns |false| if the file is empty or cannot
16410 be opened. Otherwise it updates |rd_file[n]| and |rd_fname[n]|.
16412 @c boolean mp_start_read_input (MP mp,char *s, readf_index n) {
16413 mp_ptr_scan_file(mp, s);
16415 mp_begin_file_reading(mp);
16416 if ( ! mp_a_open_in(mp, &mp->rd_file[n], (mp_filetype_text+n)) )
16418 if ( ! mp_input_ln(mp, mp->rd_file[n] ) ) {
16419 (mp->close_file)(mp,mp->rd_file[n]);
16422 mp->rd_fname[n]=xstrdup(s);
16425 mp_end_file_reading(mp);
16429 @ Open |wr_file[n]| using file name~|s| and update |wr_fname[n]|.
16432 void mp_open_write_file (MP mp, char *s, readf_index n) ;
16434 @ @c void mp_open_write_file (MP mp,char *s, readf_index n) {
16435 mp_ptr_scan_file(mp, s);
16437 while ( ! mp_a_open_out(mp, &mp->wr_file[n], (mp_filetype_text+n)) )
16438 mp_prompt_file_name(mp, "file name for write output","");
16439 mp->wr_fname[n]=xstrdup(s);
16443 @* \[36] Introduction to the parsing routines.
16444 We come now to the central nervous system that sparks many of \MP's activities.
16445 By evaluating expressions, from their primary constituents to ever larger
16446 subexpressions, \MP\ builds the structures that ultimately define complete
16447 pictures or fonts of type.
16449 Four mutually recursive subroutines are involved in this process: We call them
16450 $$\hbox{|scan_primary|, |scan_secondary|, |scan_tertiary|,
16451 and |scan_expression|.}$$
16453 Each of them is parameterless and begins with the first token to be scanned
16454 already represented in |cur_cmd|, |cur_mod|, and |cur_sym|. After execution,
16455 the value of the primary or secondary or tertiary or expression that was
16456 found will appear in the global variables |cur_type| and |cur_exp|. The
16457 token following the expression will be represented in |cur_cmd|, |cur_mod|,
16460 Technically speaking, the parsing algorithms are ``LL(1),'' more or less;
16461 backup mechanisms have been added in order to provide reasonable error
16465 small_number cur_type; /* the type of the expression just found */
16466 integer cur_exp; /* the value of the expression just found */
16471 @ Many different kinds of expressions are possible, so it is wise to have
16472 precise descriptions of what |cur_type| and |cur_exp| mean in all cases:
16475 |cur_type=mp_vacuous| means that this expression didn't turn out to have a
16476 value at all, because it arose from a \&{begingroup}$\,\ldots\,$\&{endgroup}
16477 construction in which there was no expression before the \&{endgroup}.
16478 In this case |cur_exp| has some irrelevant value.
16481 |cur_type=mp_boolean_type| means that |cur_exp| is either |true_code|
16485 |cur_type=mp_unknown_boolean| means that |cur_exp| points to a capsule
16487 a ring of equivalent booleans whose value has not yet been defined.
16490 |cur_type=mp_string_type| means that |cur_exp| is a string number (i.e., an
16491 integer in the range |0<=cur_exp<str_ptr|). That string's reference count
16492 includes this particular reference.
16495 |cur_type=mp_unknown_string| means that |cur_exp| points to a capsule
16497 a ring of equivalent strings whose value has not yet been defined.
16500 |cur_type=mp_pen_type| means that |cur_exp| points to a node in a pen. Nobody
16501 else points to any of the nodes in this pen. The pen may be polygonal or
16505 |cur_type=mp_unknown_pen| means that |cur_exp| points to a capsule
16507 a ring of equivalent pens whose value has not yet been defined.
16510 |cur_type=mp_path_type| means that |cur_exp| points to a the first node of
16511 a path; nobody else points to this particular path. The control points of
16512 the path will have been chosen.
16515 |cur_type=mp_unknown_path| means that |cur_exp| points to a capsule
16517 a ring of equivalent paths whose value has not yet been defined.
16520 |cur_type=mp_picture_type| means that |cur_exp| points to an edge header node.
16521 There may be other pointers to this particular set of edges. The header node
16522 contains a reference count that includes this particular reference.
16525 |cur_type=mp_unknown_picture| means that |cur_exp| points to a capsule
16527 a ring of equivalent pictures whose value has not yet been defined.
16530 |cur_type=mp_transform_type| means that |cur_exp| points to a |mp_transform_type|
16531 capsule node. The |value| part of this capsule
16532 points to a transform node that contains six numeric values,
16533 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16536 |cur_type=mp_color_type| means that |cur_exp| points to a |color_type|
16537 capsule node. The |value| part of this capsule
16538 points to a color node that contains three numeric values,
16539 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16542 |cur_type=mp_cmykcolor_type| means that |cur_exp| points to a |mp_cmykcolor_type|
16543 capsule node. The |value| part of this capsule
16544 points to a color node that contains four numeric values,
16545 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16548 |cur_type=mp_pair_type| means that |cur_exp| points to a capsule
16549 node whose type is |mp_pair_type|. The |value| part of this capsule
16550 points to a pair node that contains two numeric values,
16551 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16554 |cur_type=mp_known| means that |cur_exp| is a |scaled| value.
16557 |cur_type=mp_dependent| means that |cur_exp| points to a capsule node whose type
16558 is |dependent|. The |dep_list| field in this capsule points to the associated
16562 |cur_type=mp_proto_dependent| means that |cur_exp| points to a |mp_proto_dependent|
16563 capsule node. The |dep_list| field in this capsule
16564 points to the associated dependency list.
16567 |cur_type=independent| means that |cur_exp| points to a capsule node
16568 whose type is |independent|. This somewhat unusual case can arise, for
16569 example, in the expression
16570 `$x+\&{begingroup}\penalty0\,\&{string}\,x; 0\,\&{endgroup}$'.
16573 |cur_type=mp_token_list| means that |cur_exp| points to a linked list of
16576 \smallskip\noindent
16577 The possible settings of |cur_type| have been listed here in increasing
16578 numerical order. Notice that |cur_type| will never be |mp_numeric_type| or
16579 |suffixed_macro| or |mp_unsuffixed_macro|, although variables of those types
16580 are allowed. Conversely, \MP\ has no variables of type |mp_vacuous| or
16583 @ Capsules are two-word nodes that have a similar meaning
16584 to |cur_type| and |cur_exp|. Such nodes have |name_type=capsule|,
16585 and their |type| field is one of the possibilities for |cur_type| listed above.
16586 Also |link<=void| in capsules that aren't part of a token list.
16588 The |value| field of a capsule is, in most cases, the value that
16589 corresponds to its |type|, as |cur_exp| corresponds to |cur_type|.
16590 However, when |cur_exp| would point to a capsule,
16591 no extra layer of indirection is present; the |value|
16592 field is what would have been called |value(cur_exp)| if it had not been
16593 encapsulated. Furthermore, if the type is |dependent| or
16594 |mp_proto_dependent|, the |value| field of a capsule is replaced by
16595 |dep_list| and |prev_dep| fields, since dependency lists in capsules are
16596 always part of the general |dep_list| structure.
16598 The |get_x_next| routine is careful not to change the values of |cur_type|
16599 and |cur_exp| when it gets an expanded token. However, |get_x_next| might
16600 call a macro, which might parse an expression, which might execute lots of
16601 commands in a group; hence it's possible that |cur_type| might change
16602 from, say, |mp_unknown_boolean| to |mp_boolean_type|, or from |dependent| to
16603 |known| or |independent|, during the time |get_x_next| is called. The
16604 programs below are careful to stash sensitive intermediate results in
16605 capsules, so that \MP's generality doesn't cause trouble.
16607 Here's a procedure that illustrates these conventions. It takes
16608 the contents of $(|cur_type|\kern-.3pt,|cur_exp|\kern-.3pt)$
16609 and stashes them away in a
16610 capsule. It is not used when |cur_type=mp_token_list|.
16611 After the operation, |cur_type=mp_vacuous|; hence there is no need to
16612 copy path lists or to update reference counts, etc.
16614 The special link |mp_void| is put on the capsule returned by
16615 |stash_cur_exp|, because this procedure is used to store macro parameters
16616 that must be easily distinguishable from token lists.
16618 @<Declare the stashing/unstashing routines@>=
16619 pointer mp_stash_cur_exp (MP mp) {
16620 pointer p; /* the capsule that will be returned */
16621 switch (mp->cur_type) {
16622 case unknown_types:
16623 case mp_transform_type:
16624 case mp_color_type:
16627 case mp_proto_dependent:
16628 case mp_independent:
16629 case mp_cmykcolor_type:
16633 p=mp_get_node(mp, value_node_size); name_type(p)=mp_capsule;
16634 type(p)=mp->cur_type; value(p)=mp->cur_exp;
16637 mp->cur_type=mp_vacuous; link(p)=mp_void;
16641 @ The inverse of |stash_cur_exp| is the following procedure, which
16642 deletes an unnecessary capsule and puts its contents into |cur_type|
16645 The program steps of \MP\ can be divided into two categories: those in
16646 which |cur_type| and |cur_exp| are ``alive'' and those in which they are
16647 ``dead,'' in the sense that |cur_type| and |cur_exp| contain relevant
16648 information or not. It's important not to ignore them when they're alive,
16649 and it's important not to pay attention to them when they're dead.
16651 There's also an intermediate category: If |cur_type=mp_vacuous|, then
16652 |cur_exp| is irrelevant, hence we can proceed without caring if |cur_type|
16653 and |cur_exp| are alive or dead. In such cases we say that |cur_type|
16654 and |cur_exp| are {\sl dormant}. It is permissible to call |get_x_next|
16655 only when they are alive or dormant.
16657 The \\{stash} procedure above assumes that |cur_type| and |cur_exp|
16658 are alive or dormant. The \\{unstash} procedure assumes that they are
16659 dead or dormant; it resuscitates them.
16661 @<Declare the stashing/unstashing...@>=
16662 void mp_unstash_cur_exp (MP mp,pointer p) ;
16665 void mp_unstash_cur_exp (MP mp,pointer p) {
16666 mp->cur_type=type(p);
16667 switch (mp->cur_type) {
16668 case unknown_types:
16669 case mp_transform_type:
16670 case mp_color_type:
16673 case mp_proto_dependent:
16674 case mp_independent:
16675 case mp_cmykcolor_type:
16679 mp->cur_exp=value(p);
16680 mp_free_node(mp, p,value_node_size);
16685 @ The following procedure prints the values of expressions in an
16686 abbreviated format. If its first parameter |p| is null, the value of
16687 |(cur_type,cur_exp)| is displayed; otherwise |p| should be a capsule
16688 containing the desired value. The second parameter controls the amount of
16689 output. If it is~0, dependency lists will be abbreviated to
16690 `\.{linearform}' unless they consist of a single term. If it is greater
16691 than~1, complicated structures (pens, pictures, and paths) will be displayed
16695 @<Declare subroutines for printing expressions@>=
16696 @<Declare the procedure called |print_dp|@>
16697 @<Declare the stashing/unstashing routines@>
16698 void mp_print_exp (MP mp,pointer p, small_number verbosity) {
16699 boolean restore_cur_exp; /* should |cur_exp| be restored? */
16700 small_number t; /* the type of the expression */
16701 pointer q; /* a big node being displayed */
16702 integer v=0; /* the value of the expression */
16704 restore_cur_exp=false;
16706 p=mp_stash_cur_exp(mp); restore_cur_exp=true;
16709 if ( t<mp_dependent ) v=value(p); else if ( t<mp_independent ) v=dep_list(p);
16710 @<Print an abbreviated value of |v| with format depending on |t|@>;
16711 if ( restore_cur_exp ) mp_unstash_cur_exp(mp, p);
16714 @ @<Print an abbreviated value of |v| with format depending on |t|@>=
16716 case mp_vacuous:mp_print(mp, "mp_vacuous"); break;
16717 case mp_boolean_type:
16718 if ( v==true_code ) mp_print(mp, "true"); else mp_print(mp, "false");
16720 case unknown_types: case mp_numeric_type:
16721 @<Display a variable that's been declared but not defined@>;
16723 case mp_string_type:
16724 mp_print_char(mp, '"'); mp_print_str(mp, v); mp_print_char(mp, '"');
16726 case mp_pen_type: case mp_path_type: case mp_picture_type:
16727 @<Display a complex type@>;
16729 case mp_transform_type: case mp_color_type: case mp_pair_type: case mp_cmykcolor_type:
16730 if ( v==null ) mp_print_type(mp, t);
16731 else @<Display a big node@>;
16733 case mp_known:mp_print_scaled(mp, v); break;
16734 case mp_dependent: case mp_proto_dependent:
16735 mp_print_dp(mp, t,v,verbosity);
16737 case mp_independent:mp_print_variable_name(mp, p); break;
16738 default: mp_confusion(mp, "exp"); break;
16739 @:this can't happen exp}{\quad exp@>
16742 @ @<Display a big node@>=
16744 mp_print_char(mp, '('); q=v+mp->big_node_size[t];
16746 if ( type(v)==mp_known ) mp_print_scaled(mp, value(v));
16747 else if ( type(v)==mp_independent ) mp_print_variable_name(mp, v);
16748 else mp_print_dp(mp, type(v),dep_list(v),verbosity);
16750 if ( v!=q ) mp_print_char(mp, ',');
16752 mp_print_char(mp, ')');
16755 @ Values of type \&{picture}, \&{path}, and \&{pen} are displayed verbosely
16756 in the log file only, unless the user has given a positive value to
16759 @<Display a complex type@>=
16760 if ( verbosity<=1 ) {
16761 mp_print_type(mp, t);
16763 if ( mp->selector==term_and_log )
16764 if ( mp->internal[mp_tracing_online]<=0 ) {
16765 mp->selector=term_only;
16766 mp_print_type(mp, t); mp_print(mp, " (see the transcript file)");
16767 mp->selector=term_and_log;
16770 case mp_pen_type:mp_print_pen(mp, v,"",false); break;
16771 case mp_path_type:mp_print_path(mp, v,"",false); break;
16772 case mp_picture_type:mp_print_edges(mp, v,"",false); break;
16773 } /* there are no other cases */
16776 @ @<Declare the procedure called |print_dp|@>=
16777 void mp_print_dp (MP mp,small_number t, pointer p,
16778 small_number verbosity) {
16779 pointer q; /* the node following |p| */
16781 if ( (info(q)==null) || (verbosity>0) ) mp_print_dependency(mp, p,t);
16782 else mp_print(mp, "linearform");
16785 @ The displayed name of a variable in a ring will not be a capsule unless
16786 the ring consists entirely of capsules.
16788 @<Display a variable that's been declared but not defined@>=
16789 { mp_print_type(mp, t);
16791 { mp_print_char(mp, ' ');
16792 while ( (name_type(v)==mp_capsule) && (v!=p) ) v=value(v);
16793 mp_print_variable_name(mp, v);
16797 @ When errors are detected during parsing, it is often helpful to
16798 display an expression just above the error message, using |exp_err|
16799 or |disp_err| instead of |print_err|.
16801 @d exp_err(A) mp_disp_err(mp, null,(A)) /* displays the current expression */
16803 @<Declare subroutines for printing expressions@>=
16804 void mp_disp_err (MP mp,pointer p, const char *s) {
16805 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
16806 mp_print_nl(mp, ">> ");
16808 mp_print_exp(mp, p,1); /* ``medium verbose'' printing of the expression */
16810 mp_print_nl(mp, "! "); mp_print(mp, s);
16815 @ If |cur_type| and |cur_exp| contain relevant information that should
16816 be recycled, we will use the following procedure, which changes |cur_type|
16817 to |known| and stores a given value in |cur_exp|. We can think of |cur_type|
16818 and |cur_exp| as either alive or dormant after this has been done,
16819 because |cur_exp| will not contain a pointer value.
16821 @ @c void mp_flush_cur_exp (MP mp,scaled v) {
16822 switch (mp->cur_type) {
16823 case unknown_types: case mp_transform_type: case mp_color_type: case mp_pair_type:
16824 case mp_dependent: case mp_proto_dependent: case mp_independent: case mp_cmykcolor_type:
16825 mp_recycle_value(mp, mp->cur_exp);
16826 mp_free_node(mp, mp->cur_exp,value_node_size);
16828 case mp_string_type:
16829 delete_str_ref(mp->cur_exp); break;
16830 case mp_pen_type: case mp_path_type:
16831 mp_toss_knot_list(mp, mp->cur_exp); break;
16832 case mp_picture_type:
16833 delete_edge_ref(mp->cur_exp); break;
16837 mp->cur_type=mp_known; mp->cur_exp=v;
16840 @ There's a much more general procedure that is capable of releasing
16841 the storage associated with any two-word value packet.
16843 @<Declare the recycling subroutines@>=
16844 void mp_recycle_value (MP mp,pointer p) ;
16846 @ @c void mp_recycle_value (MP mp,pointer p) {
16847 small_number t; /* a type code */
16848 integer vv; /* another value */
16849 pointer q,r,s,pp; /* link manipulation registers */
16850 integer v=0; /* a value */
16852 if ( t<mp_dependent ) v=value(p);
16854 case undefined: case mp_vacuous: case mp_boolean_type: case mp_known:
16855 case mp_numeric_type:
16857 case unknown_types:
16858 mp_ring_delete(mp, p); break;
16859 case mp_string_type:
16860 delete_str_ref(v); break;
16861 case mp_path_type: case mp_pen_type:
16862 mp_toss_knot_list(mp, v); break;
16863 case mp_picture_type:
16864 delete_edge_ref(v); break;
16865 case mp_cmykcolor_type: case mp_pair_type: case mp_color_type:
16866 case mp_transform_type:
16867 @<Recycle a big node@>; break;
16868 case mp_dependent: case mp_proto_dependent:
16869 @<Recycle a dependency list@>; break;
16870 case mp_independent:
16871 @<Recycle an independent variable@>; break;
16872 case mp_token_list: case mp_structured:
16873 mp_confusion(mp, "recycle"); break;
16874 @:this can't happen recycle}{\quad recycle@>
16875 case mp_unsuffixed_macro: case mp_suffixed_macro:
16876 mp_delete_mac_ref(mp, value(p)); break;
16877 } /* there are no other cases */
16881 @ @<Recycle a big node@>=
16883 q=v+mp->big_node_size[t];
16885 q=q-2; mp_recycle_value(mp, q);
16887 mp_free_node(mp, v,mp->big_node_size[t]);
16890 @ @<Recycle a dependency list@>=
16893 while ( info(q)!=null ) q=link(q);
16894 link(prev_dep(p))=link(q);
16895 prev_dep(link(q))=prev_dep(p);
16896 link(q)=null; mp_flush_node_list(mp, dep_list(p));
16899 @ When an independent variable disappears, it simply fades away, unless
16900 something depends on it. In the latter case, a dependent variable whose
16901 coefficient of dependence is maximal will take its place.
16902 The relevant algorithm is due to Ignacio~A. Zabala, who implemented it
16903 as part of his Ph.D. thesis (Stanford University, December 1982).
16904 @^Zabala Salelles, Ignacio Andr\'es@>
16906 For example, suppose that variable $x$ is being recycled, and that the
16907 only variables depending on~$x$ are $y=2x+a$ and $z=x+b$. In this case
16908 we want to make $y$ independent and $z=.5y-.5a+b$; no other variables
16909 will depend on~$y$. If $\\{tracingequations}>0$ in this situation,
16910 we will print `\.{\#\#\# -2x=-y+a}'.
16912 There's a slight complication, however: An independent variable $x$
16913 can occur both in dependency lists and in proto-dependency lists.
16914 This makes it necessary to be careful when deciding which coefficient
16917 Furthermore, this complication is not so slight when
16918 a proto-dependent variable is chosen to become independent. For example,
16919 suppose that $y=2x+100a$ is proto-dependent while $z=x+b$ is dependent;
16920 then we must change $z=.5y-50a+b$ to a proto-dependency, because of the
16921 large coefficient `50'.
16923 In order to deal with these complications without wasting too much time,
16924 we shall link together the occurrences of~$x$ among all the linear
16925 dependencies, maintaining separate lists for the dependent and
16926 proto-dependent cases.
16928 @<Recycle an independent variable@>=
16930 mp->max_c[mp_dependent]=0; mp->max_c[mp_proto_dependent]=0;
16931 mp->max_link[mp_dependent]=null; mp->max_link[mp_proto_dependent]=null;
16933 while ( q!=dep_head ) {
16934 s=value_loc(q); /* now |link(s)=dep_list(q)| */
16937 if ( info(r)==null ) break;
16938 if ( info(r)!=p ) {
16941 t=type(q); link(s)=link(r); info(r)=q;
16942 if ( abs(value(r))>mp->max_c[t] ) {
16943 @<Record a new maximum coefficient of type |t|@>;
16945 link(r)=mp->max_link[t]; mp->max_link[t]=r;
16951 if ( (mp->max_c[mp_dependent]>0)||(mp->max_c[mp_proto_dependent]>0) ) {
16952 @<Choose a dependent variable to take the place of the disappearing
16953 independent variable, and change all remaining dependencies
16958 @ The code for independency removal makes use of three two-word arrays.
16961 integer max_c[mp_proto_dependent+1]; /* max coefficient magnitude */
16962 pointer max_ptr[mp_proto_dependent+1]; /* where |p| occurs with |max_c| */
16963 pointer max_link[mp_proto_dependent+1]; /* other occurrences of |p| */
16965 @ @<Record a new maximum coefficient...@>=
16967 if ( mp->max_c[t]>0 ) {
16968 link(mp->max_ptr[t])=mp->max_link[t]; mp->max_link[t]=mp->max_ptr[t];
16970 mp->max_c[t]=abs(value(r)); mp->max_ptr[t]=r;
16973 @ @<Choose a dependent...@>=
16975 if ( (mp->max_c[mp_dependent] / 010000) >= mp->max_c[mp_proto_dependent] )
16978 t=mp_proto_dependent;
16979 @<Determine the dependency list |s| to substitute for the independent
16981 t=mp_dependent+mp_proto_dependent-t; /* complement |t| */
16982 if ( mp->max_c[t]>0 ) { /* we need to pick up an unchosen dependency */
16983 link(mp->max_ptr[t])=mp->max_link[t]; mp->max_link[t]=mp->max_ptr[t];
16985 if ( t!=mp_dependent ) { @<Substitute new dependencies in place of |p|@>; }
16986 else { @<Substitute new proto-dependencies in place of |p|@>;}
16987 mp_flush_node_list(mp, s);
16988 if ( mp->fix_needed ) mp_fix_dependencies(mp);
16992 @ Let |s=max_ptr[t]|. At this point we have $|value|(s)=\pm|max_c|[t]$,
16993 and |info(s)| points to the dependent variable~|pp| of type~|t| from
16994 whose dependency list we have removed node~|s|. We must reinsert
16995 node~|s| into the dependency list, with coefficient $-1.0$, and with
16996 |pp| as the new independent variable. Since |pp| will have a larger serial
16997 number than any other variable, we can put node |s| at the head of the
17000 @<Determine the dep...@>=
17001 s=mp->max_ptr[t]; pp=info(s); v=value(s);
17002 if ( t==mp_dependent ) value(s)=-fraction_one; else value(s)=-unity;
17003 r=dep_list(pp); link(s)=r;
17004 while ( info(r)!=null ) r=link(r);
17005 q=link(r); link(r)=null;
17006 prev_dep(q)=prev_dep(pp); link(prev_dep(pp))=q;
17008 if ( mp->cur_exp==pp ) if ( mp->cur_type==t ) mp->cur_type=mp_independent;
17009 if ( mp->internal[mp_tracing_equations]>0 ) {
17010 @<Show the transformed dependency@>;
17013 @ Now $(-v)$ times the formerly independent variable~|p| is being replaced
17014 by the dependency list~|s|.
17016 @<Show the transformed...@>=
17017 if ( mp_interesting(mp, p) ) {
17018 mp_begin_diagnostic(mp); mp_print_nl(mp, "### ");
17019 @:]]]\#\#\#_}{\.{\#\#\#}@>
17020 if ( v>0 ) mp_print_char(mp, '-');
17021 if ( t==mp_dependent ) vv=mp_round_fraction(mp, mp->max_c[mp_dependent]);
17022 else vv=mp->max_c[mp_proto_dependent];
17023 if ( vv!=unity ) mp_print_scaled(mp, vv);
17024 mp_print_variable_name(mp, p);
17025 while ( value(p) % s_scale>0 ) {
17026 mp_print(mp, "*4"); value(p)=value(p)-2;
17028 if ( t==mp_dependent ) mp_print_char(mp, '='); else mp_print(mp, " = ");
17029 mp_print_dependency(mp, s,t);
17030 mp_end_diagnostic(mp, false);
17033 @ Finally, there are dependent and proto-dependent variables whose
17034 dependency lists must be brought up to date.
17036 @<Substitute new dependencies...@>=
17037 for (t=mp_dependent;t<=mp_proto_dependent;t++){
17039 while ( r!=null ) {
17041 dep_list(q)=mp_p_plus_fq(mp, dep_list(q),
17042 mp_make_fraction(mp, value(r),-v),s,t,mp_dependent);
17043 if ( dep_list(q)==mp->dep_final ) mp_make_known(mp, q,mp->dep_final);
17044 q=r; r=link(r); mp_free_node(mp, q,dep_node_size);
17048 @ @<Substitute new proto...@>=
17049 for (t=mp_dependent;t<=mp_proto_dependent;t++) {
17051 while ( r!=null ) {
17053 if ( t==mp_dependent ) { /* for safety's sake, we change |q| to |mp_proto_dependent| */
17054 if ( mp->cur_exp==q ) if ( mp->cur_type==mp_dependent )
17055 mp->cur_type=mp_proto_dependent;
17056 dep_list(q)=mp_p_over_v(mp, dep_list(q),unity,
17057 mp_dependent,mp_proto_dependent);
17058 type(q)=mp_proto_dependent;
17059 value(r)=mp_round_fraction(mp, value(r));
17061 dep_list(q)=mp_p_plus_fq(mp, dep_list(q),
17062 mp_make_scaled(mp, value(r),-v),s,
17063 mp_proto_dependent,mp_proto_dependent);
17064 if ( dep_list(q)==mp->dep_final )
17065 mp_make_known(mp, q,mp->dep_final);
17066 q=r; r=link(r); mp_free_node(mp, q,dep_node_size);
17070 @ Here are some routines that provide handy combinations of actions
17071 that are often needed during error recovery. For example,
17072 `|flush_error|' flushes the current expression, replaces it by
17073 a given value, and calls |error|.
17075 Errors often are detected after an extra token has already been scanned.
17076 The `\\{put\_get}' routines put that token back before calling |error|;
17077 then they get it back again. (Or perhaps they get another token, if
17078 the user has changed things.)
17081 void mp_flush_error (MP mp,scaled v);
17082 void mp_put_get_error (MP mp);
17083 void mp_put_get_flush_error (MP mp,scaled v) ;
17086 void mp_flush_error (MP mp,scaled v) {
17087 mp_error(mp); mp_flush_cur_exp(mp, v);
17089 void mp_put_get_error (MP mp) {
17090 mp_back_error(mp); mp_get_x_next(mp);
17092 void mp_put_get_flush_error (MP mp,scaled v) {
17093 mp_put_get_error(mp);
17094 mp_flush_cur_exp(mp, v);
17097 @ A global variable |var_flag| is set to a special command code
17098 just before \MP\ calls |scan_expression|, if the expression should be
17099 treated as a variable when this command code immediately follows. For
17100 example, |var_flag| is set to |assignment| at the beginning of a
17101 statement, because we want to know the {\sl location\/} of a variable at
17102 the left of `\.{:=}', not the {\sl value\/} of that variable.
17104 The |scan_expression| subroutine calls |scan_tertiary|,
17105 which calls |scan_secondary|, which calls |scan_primary|, which sets
17106 |var_flag:=0|. In this way each of the scanning routines ``knows''
17107 when it has been called with a special |var_flag|, but |var_flag| is
17110 A variable preceding a command that equals |var_flag| is converted to a
17111 token list rather than a value. Furthermore, an `\.{=}' sign following an
17112 expression with |var_flag=assignment| is not considered to be a relation
17113 that produces boolean expressions.
17117 int var_flag; /* command that wants a variable */
17122 @* \[37] Parsing primary expressions.
17123 The first parsing routine, |scan_primary|, is also the most complicated one,
17124 since it involves so many different cases. But each case---with one
17125 exception---is fairly simple by itself.
17127 When |scan_primary| begins, the first token of the primary to be scanned
17128 should already appear in |cur_cmd|, |cur_mod|, and |cur_sym|. The values
17129 of |cur_type| and |cur_exp| should be either dead or dormant, as explained
17130 earlier. If |cur_cmd| is not between |min_primary_command| and
17131 |max_primary_command|, inclusive, a syntax error will be signaled.
17133 @<Declare the basic parsing subroutines@>=
17134 void mp_scan_primary (MP mp) {
17135 pointer p,q,r; /* for list manipulation */
17136 quarterword c; /* a primitive operation code */
17137 int my_var_flag; /* initial value of |my_var_flag| */
17138 pointer l_delim,r_delim; /* hash addresses of a delimiter pair */
17139 @<Other local variables for |scan_primary|@>;
17140 my_var_flag=mp->var_flag; mp->var_flag=0;
17143 @<Supply diagnostic information, if requested@>;
17144 switch (mp->cur_cmd) {
17145 case left_delimiter:
17146 @<Scan a delimited primary@>; break;
17148 @<Scan a grouped primary@>; break;
17150 @<Scan a string constant@>; break;
17151 case numeric_token:
17152 @<Scan a primary that starts with a numeric token@>; break;
17154 @<Scan a nullary operation@>; break;
17155 case unary: case type_name: case cycle: case plus_or_minus:
17156 @<Scan a unary operation@>; break;
17157 case primary_binary:
17158 @<Scan a binary operation with `\&{of}' between its operands@>; break;
17160 @<Convert a suffix to a string@>; break;
17161 case internal_quantity:
17162 @<Scan an internal numeric quantity@>; break;
17163 case capsule_token:
17164 mp_make_exp_copy(mp, mp->cur_mod); break;
17166 @<Scan a variable primary; |goto restart| if it turns out to be a macro@>; break;
17168 mp_bad_exp(mp, "A primary"); goto RESTART; break;
17169 @.A primary expression...@>
17171 mp_get_x_next(mp); /* the routines |goto done| if they don't want this */
17173 if ( mp->cur_cmd==left_bracket ) {
17174 if ( mp->cur_type>=mp_known ) {
17175 @<Scan a mediation construction@>;
17182 @ Errors at the beginning of expressions are flagged by |bad_exp|.
17184 @c void mp_bad_exp (MP mp, const char * s) {
17186 print_err(s); mp_print(mp, " expression can't begin with `");
17187 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod);
17188 mp_print_char(mp, '\'');
17189 help4("I'm afraid I need some sort of value in order to continue,")
17190 ("so I've tentatively inserted `0'. You may want to")
17191 ("delete this zero and insert something else;")
17192 ("see Chapter 27 of The METAFONTbook for an example.");
17193 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
17194 mp_back_input(mp); mp->cur_sym=0; mp->cur_cmd=numeric_token;
17195 mp->cur_mod=0; mp_ins_error(mp);
17196 save_flag=mp->var_flag; mp->var_flag=0; mp_get_x_next(mp);
17197 mp->var_flag=save_flag;
17200 @ @<Supply diagnostic information, if requested@>=
17202 if ( mp->panicking ) mp_check_mem(mp, false);
17204 if ( mp->interrupt!=0 ) if ( mp->OK_to_interrupt ) {
17205 mp_back_input(mp); check_interrupt; mp_get_x_next(mp);
17208 @ @<Scan a delimited primary@>=
17210 l_delim=mp->cur_sym; r_delim=mp->cur_mod;
17211 mp_get_x_next(mp); mp_scan_expression(mp);
17212 if ( (mp->cur_cmd==comma) && (mp->cur_type>=mp_known) ) {
17213 @<Scan the rest of a delimited set of numerics@>;
17215 mp_check_delimiter(mp, l_delim,r_delim);
17219 @ The |stash_in| subroutine puts the current (numeric) expression into a field
17220 within a ``big node.''
17222 @c void mp_stash_in (MP mp,pointer p) {
17223 pointer q; /* temporary register */
17224 type(p)=mp->cur_type;
17225 if ( mp->cur_type==mp_known ) {
17226 value(p)=mp->cur_exp;
17228 if ( mp->cur_type==mp_independent ) {
17229 @<Stash an independent |cur_exp| into a big node@>;
17231 mp->mem[value_loc(p)]=mp->mem[value_loc(mp->cur_exp)];
17232 /* |dep_list(p):=dep_list(cur_exp)| and |prev_dep(p):=prev_dep(cur_exp)| */
17233 link(prev_dep(p))=p;
17235 mp_free_node(mp, mp->cur_exp,value_node_size);
17237 mp->cur_type=mp_vacuous;
17240 @ In rare cases the current expression can become |independent|. There
17241 may be many dependency lists pointing to such an independent capsule,
17242 so we can't simply move it into place within a big node. Instead,
17243 we copy it, then recycle it.
17245 @ @<Stash an independent |cur_exp|...@>=
17247 q=mp_single_dependency(mp, mp->cur_exp);
17248 if ( q==mp->dep_final ){
17249 type(p)=mp_known; value(p)=0; mp_free_node(mp, q,dep_node_size);
17251 type(p)=mp_dependent; mp_new_dep(mp, p,q);
17253 mp_recycle_value(mp, mp->cur_exp);
17256 @ This code uses the fact that |red_part_loc| and |green_part_loc|
17257 are synonymous with |x_part_loc| and |y_part_loc|.
17259 @<Scan the rest of a delimited set of numerics@>=
17261 p=mp_stash_cur_exp(mp);
17262 mp_get_x_next(mp); mp_scan_expression(mp);
17263 @<Make sure the second part of a pair or color has a numeric type@>;
17264 q=mp_get_node(mp, value_node_size); name_type(q)=mp_capsule;
17265 if ( mp->cur_cmd==comma ) type(q)=mp_color_type;
17266 else type(q)=mp_pair_type;
17267 mp_init_big_node(mp, q); r=value(q);
17268 mp_stash_in(mp, y_part_loc(r));
17269 mp_unstash_cur_exp(mp, p);
17270 mp_stash_in(mp, x_part_loc(r));
17271 if ( mp->cur_cmd==comma ) {
17272 @<Scan the last of a triplet of numerics@>;
17274 if ( mp->cur_cmd==comma ) {
17275 type(q)=mp_cmykcolor_type;
17276 mp_init_big_node(mp, q); t=value(q);
17277 mp->mem[cyan_part_loc(t)]=mp->mem[red_part_loc(r)];
17278 value(cyan_part_loc(t))=value(red_part_loc(r));
17279 mp->mem[magenta_part_loc(t)]=mp->mem[green_part_loc(r)];
17280 value(magenta_part_loc(t))=value(green_part_loc(r));
17281 mp->mem[yellow_part_loc(t)]=mp->mem[blue_part_loc(r)];
17282 value(yellow_part_loc(t))=value(blue_part_loc(r));
17283 mp_recycle_value(mp, r);
17285 @<Scan the last of a quartet of numerics@>;
17287 mp_check_delimiter(mp, l_delim,r_delim);
17288 mp->cur_type=type(q);
17292 @ @<Make sure the second part of a pair or color has a numeric type@>=
17293 if ( mp->cur_type<mp_known ) {
17294 exp_err("Nonnumeric ypart has been replaced by 0");
17295 @.Nonnumeric...replaced by 0@>
17296 help4("I've started to scan a pair `(a,b)' or a color `(a,b,c)';")
17297 ("but after finding a nice `a' I found a `b' that isn't")
17298 ("of numeric type. So I've changed that part to zero.")
17299 ("(The b that I didn't like appears above the error message.)");
17300 mp_put_get_flush_error(mp, 0);
17303 @ @<Scan the last of a triplet of numerics@>=
17305 mp_get_x_next(mp); mp_scan_expression(mp);
17306 if ( mp->cur_type<mp_known ) {
17307 exp_err("Nonnumeric third part has been replaced by 0");
17308 @.Nonnumeric...replaced by 0@>
17309 help3("I've just scanned a color `(a,b,c)' or cmykcolor(a,b,c,d); but the `c'")
17310 ("isn't of numeric type. So I've changed that part to zero.")
17311 ("(The c that I didn't like appears above the error message.)");
17312 mp_put_get_flush_error(mp, 0);
17314 mp_stash_in(mp, blue_part_loc(r));
17317 @ @<Scan the last of a quartet of numerics@>=
17319 mp_get_x_next(mp); mp_scan_expression(mp);
17320 if ( mp->cur_type<mp_known ) {
17321 exp_err("Nonnumeric blackpart has been replaced by 0");
17322 @.Nonnumeric...replaced by 0@>
17323 help3("I've just scanned a cmykcolor `(c,m,y,k)'; but the `k' isn't")
17324 ("of numeric type. So I've changed that part to zero.")
17325 ("(The k that I didn't like appears above the error message.)");
17326 mp_put_get_flush_error(mp, 0);
17328 mp_stash_in(mp, black_part_loc(r));
17331 @ The local variable |group_line| keeps track of the line
17332 where a \&{begingroup} command occurred; this will be useful
17333 in an error message if the group doesn't actually end.
17335 @<Other local variables for |scan_primary|@>=
17336 integer group_line; /* where a group began */
17338 @ @<Scan a grouped primary@>=
17340 group_line=mp_true_line(mp);
17341 if ( mp->internal[mp_tracing_commands]>0 ) show_cur_cmd_mod;
17342 save_boundary_item(p);
17344 mp_do_statement(mp); /* ends with |cur_cmd>=semicolon| */
17345 } while (mp->cur_cmd==semicolon);
17346 if ( mp->cur_cmd!=end_group ) {
17347 print_err("A group begun on line ");
17348 @.A group...never ended@>
17349 mp_print_int(mp, group_line);
17350 mp_print(mp, " never ended");
17351 help2("I saw a `begingroup' back there that hasn't been matched")
17352 ("by `endgroup'. So I've inserted `endgroup' now.");
17353 mp_back_error(mp); mp->cur_cmd=end_group;
17356 /* this might change |cur_type|, if independent variables are recycled */
17357 if ( mp->internal[mp_tracing_commands]>0 ) show_cur_cmd_mod;
17360 @ @<Scan a string constant@>=
17362 mp->cur_type=mp_string_type; mp->cur_exp=mp->cur_mod;
17365 @ Later we'll come to procedures that perform actual operations like
17366 addition, square root, and so on; our purpose now is to do the parsing.
17367 But we might as well mention those future procedures now, so that the
17368 suspense won't be too bad:
17371 |do_nullary(c)| does primitive operations that have no operands (e.g.,
17372 `\&{true}' or `\&{pencircle}');
17375 |do_unary(c)| applies a primitive operation to the current expression;
17378 |do_binary(p,c)| applies a primitive operation to the capsule~|p|
17379 and the current expression.
17381 @<Scan a nullary operation@>=mp_do_nullary(mp, mp->cur_mod)
17383 @ @<Scan a unary operation@>=
17385 c=mp->cur_mod; mp_get_x_next(mp); mp_scan_primary(mp);
17386 mp_do_unary(mp, c); goto DONE;
17389 @ A numeric token might be a primary by itself, or it might be the
17390 numerator of a fraction composed solely of numeric tokens, or it might
17391 multiply the primary that follows (provided that the primary doesn't begin
17392 with a plus sign or a minus sign). The code here uses the facts that
17393 |max_primary_command=plus_or_minus| and
17394 |max_primary_command-1=numeric_token|. If a fraction is found that is less
17395 than unity, we try to retain higher precision when we use it in scalar
17398 @<Other local variables for |scan_primary|@>=
17399 scaled num,denom; /* for primaries that are fractions, like `1/2' */
17401 @ @<Scan a primary that starts with a numeric token@>=
17403 mp->cur_exp=mp->cur_mod; mp->cur_type=mp_known; mp_get_x_next(mp);
17404 if ( mp->cur_cmd!=slash ) {
17408 if ( mp->cur_cmd!=numeric_token ) {
17410 mp->cur_cmd=slash; mp->cur_mod=over; mp->cur_sym=frozen_slash;
17413 num=mp->cur_exp; denom=mp->cur_mod;
17414 if ( denom==0 ) { @<Protest division by zero@>; }
17415 else { mp->cur_exp=mp_make_scaled(mp, num,denom); }
17416 check_arith; mp_get_x_next(mp);
17418 if ( mp->cur_cmd>=min_primary_command ) {
17419 if ( mp->cur_cmd<numeric_token ) { /* in particular, |cur_cmd<>plus_or_minus| */
17420 p=mp_stash_cur_exp(mp); mp_scan_primary(mp);
17421 if ( (abs(num)>=abs(denom))||(mp->cur_type<mp_color_type) ) {
17422 mp_do_binary(mp, p,times);
17424 mp_frac_mult(mp, num,denom);
17425 mp_free_node(mp, p,value_node_size);
17432 @ @<Protest division...@>=
17434 print_err("Division by zero");
17435 @.Division by zero@>
17436 help1("I'll pretend that you meant to divide by 1."); mp_error(mp);
17439 @ @<Scan a binary operation with `\&{of}' between its operands@>=
17441 c=mp->cur_mod; mp_get_x_next(mp); mp_scan_expression(mp);
17442 if ( mp->cur_cmd!=of_token ) {
17443 mp_missing_err(mp, "of"); mp_print(mp, " for ");
17444 mp_print_cmd_mod(mp, primary_binary,c);
17446 help1("I've got the first argument; will look now for the other.");
17449 p=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_primary(mp);
17450 mp_do_binary(mp, p,c); goto DONE;
17453 @ @<Convert a suffix to a string@>=
17455 mp_get_x_next(mp); mp_scan_suffix(mp);
17456 mp->old_setting=mp->selector; mp->selector=new_string;
17457 mp_show_token_list(mp, mp->cur_exp,null,100000,0);
17458 mp_flush_token_list(mp, mp->cur_exp);
17459 mp->cur_exp=mp_make_string(mp); mp->selector=mp->old_setting;
17460 mp->cur_type=mp_string_type;
17464 @ If an internal quantity appears all by itself on the left of an
17465 assignment, we return a token list of length one, containing the address
17466 of the internal quantity plus |hash_end|. (This accords with the conventions
17467 of the save stack, as described earlier.)
17469 @<Scan an internal...@>=
17472 if ( my_var_flag==assignment ) {
17474 if ( mp->cur_cmd==assignment ) {
17475 mp->cur_exp=mp_get_avail(mp);
17476 info(mp->cur_exp)=q+hash_end; mp->cur_type=mp_token_list;
17481 mp->cur_type=mp_known; mp->cur_exp=mp->internal[q];
17484 @ The most difficult part of |scan_primary| has been saved for last, since
17485 it was necessary to build up some confidence first. We can now face the task
17486 of scanning a variable.
17488 As we scan a variable, we build a token list containing the relevant
17489 names and subscript values, simultaneously following along in the
17490 ``collective'' structure to see if we are actually dealing with a macro
17491 instead of a value.
17493 The local variables |pre_head| and |post_head| will point to the beginning
17494 of the prefix and suffix lists; |tail| will point to the end of the list
17495 that is currently growing.
17497 Another local variable, |tt|, contains partial information about the
17498 declared type of the variable-so-far. If |tt>=mp_unsuffixed_macro|, the
17499 relation |tt=type(q)| will always hold. If |tt=undefined|, the routine
17500 doesn't bother to update its information about type. And if
17501 |undefined<tt<mp_unsuffixed_macro|, the precise value of |tt| isn't critical.
17503 @ @<Other local variables for |scan_primary|@>=
17504 pointer pre_head,post_head,tail;
17505 /* prefix and suffix list variables */
17506 small_number tt; /* approximation to the type of the variable-so-far */
17507 pointer t; /* a token */
17508 pointer macro_ref = 0; /* reference count for a suffixed macro */
17510 @ @<Scan a variable primary...@>=
17512 fast_get_avail(pre_head); tail=pre_head; post_head=null; tt=mp_vacuous;
17514 t=mp_cur_tok(mp); link(tail)=t;
17515 if ( tt!=undefined ) {
17516 @<Find the approximate type |tt| and corresponding~|q|@>;
17517 if ( tt>=mp_unsuffixed_macro ) {
17518 @<Either begin an unsuffixed macro call or
17519 prepare for a suffixed one@>;
17522 mp_get_x_next(mp); tail=t;
17523 if ( mp->cur_cmd==left_bracket ) {
17524 @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>;
17526 if ( mp->cur_cmd>max_suffix_token ) break;
17527 if ( mp->cur_cmd<min_suffix_token ) break;
17528 } /* now |cur_cmd| is |internal_quantity|, |tag_token|, or |numeric_token| */
17529 @<Handle unusual cases that masquerade as variables, and |goto restart|
17530 or |goto done| if appropriate;
17531 otherwise make a copy of the variable and |goto done|@>;
17534 @ @<Either begin an unsuffixed macro call or...@>=
17537 if ( tt>mp_unsuffixed_macro ) { /* |tt=mp_suffixed_macro| */
17538 post_head=mp_get_avail(mp); tail=post_head; link(tail)=t;
17539 tt=undefined; macro_ref=value(q); add_mac_ref(macro_ref);
17541 @<Set up unsuffixed macro call and |goto restart|@>;
17545 @ @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>=
17547 mp_get_x_next(mp); mp_scan_expression(mp);
17548 if ( mp->cur_cmd!=right_bracket ) {
17549 @<Put the left bracket and the expression back to be rescanned@>;
17551 if ( mp->cur_type!=mp_known ) mp_bad_subscript(mp);
17552 mp->cur_cmd=numeric_token; mp->cur_mod=mp->cur_exp; mp->cur_sym=0;
17556 @ The left bracket that we thought was introducing a subscript might have
17557 actually been the left bracket in a mediation construction like `\.{x[a,b]}'.
17558 So we don't issue an error message at this point; but we do want to back up
17559 so as to avoid any embarrassment about our incorrect assumption.
17561 @<Put the left bracket and the expression back to be rescanned@>=
17563 mp_back_input(mp); /* that was the token following the current expression */
17564 mp_back_expr(mp); mp->cur_cmd=left_bracket;
17565 mp->cur_mod=0; mp->cur_sym=frozen_left_bracket;
17568 @ Here's a routine that puts the current expression back to be read again.
17570 @c void mp_back_expr (MP mp) {
17571 pointer p; /* capsule token */
17572 p=mp_stash_cur_exp(mp); link(p)=null; back_list(p);
17575 @ Unknown subscripts lead to the following error message.
17577 @c void mp_bad_subscript (MP mp) {
17578 exp_err("Improper subscript has been replaced by zero");
17579 @.Improper subscript...@>
17580 help3("A bracketed subscript must have a known numeric value;")
17581 ("unfortunately, what I found was the value that appears just")
17582 ("above this error message. So I'll try a zero subscript.");
17583 mp_flush_error(mp, 0);
17586 @ Every time we call |get_x_next|, there's a chance that the variable we've
17587 been looking at will disappear. Thus, we cannot safely keep |q| pointing
17588 into the variable structure; we need to start searching from the root each time.
17590 @<Find the approximate type |tt| and corresponding~|q|@>=
17593 p=link(pre_head); q=info(p); tt=undefined;
17594 if ( eq_type(q) % outer_tag==tag_token ) {
17596 if ( q==null ) goto DONE2;
17600 tt=type(q); goto DONE2;
17602 if ( type(q)!=mp_structured ) goto DONE2;
17603 q=link(attr_head(q)); /* the |collective_subscript| attribute */
17604 if ( p>=mp->hi_mem_min ) { /* it's not a subscript */
17605 do { q=link(q); } while (! (attr_loc(q)>=info(p)));
17606 if ( attr_loc(q)>info(p) ) goto DONE2;
17614 @ How do things stand now? Well, we have scanned an entire variable name,
17615 including possible subscripts and/or attributes; |cur_cmd|, |cur_mod|, and
17616 |cur_sym| represent the token that follows. If |post_head=null|, a
17617 token list for this variable name starts at |link(pre_head)|, with all
17618 subscripts evaluated. But if |post_head<>null|, the variable turned out
17619 to be a suffixed macro; |pre_head| is the head of the prefix list, while
17620 |post_head| is the head of a token list containing both `\.{\AT!}' and
17623 Our immediate problem is to see if this variable still exists. (Variable
17624 structures can change drastically whenever we call |get_x_next|; users
17625 aren't supposed to do this, but the fact that it is possible means that
17626 we must be cautious.)
17628 The following procedure prints an error message when a variable
17629 unexpectedly disappears. Its help message isn't quite right for
17630 our present purposes, but we'll be able to fix that up.
17633 void mp_obliterated (MP mp,pointer q) {
17634 print_err("Variable "); mp_show_token_list(mp, q,null,1000,0);
17635 mp_print(mp, " has been obliterated");
17636 @.Variable...obliterated@>
17637 help5("It seems you did a nasty thing---probably by accident,")
17638 ("but nevertheless you nearly hornswoggled me...")
17639 ("While I was evaluating the right-hand side of this")
17640 ("command, something happened, and the left-hand side")
17641 ("is no longer a variable! So I won't change anything.");
17644 @ If the variable does exist, we also need to check
17645 for a few other special cases before deciding that a plain old ordinary
17646 variable has, indeed, been scanned.
17648 @<Handle unusual cases that masquerade as variables...@>=
17649 if ( post_head!=null ) {
17650 @<Set up suffixed macro call and |goto restart|@>;
17652 q=link(pre_head); free_avail(pre_head);
17653 if ( mp->cur_cmd==my_var_flag ) {
17654 mp->cur_type=mp_token_list; mp->cur_exp=q; goto DONE;
17656 p=mp_find_variable(mp, q);
17658 mp_make_exp_copy(mp, p);
17660 mp_obliterated(mp, q);
17661 mp->help_line[2]="While I was evaluating the suffix of this variable,";
17662 mp->help_line[1]="something was redefined, and it's no longer a variable!";
17663 mp->help_line[0]="In order to get back on my feet, I've inserted `0' instead.";
17664 mp_put_get_flush_error(mp, 0);
17666 mp_flush_node_list(mp, q);
17669 @ The only complication associated with macro calling is that the prefix
17670 and ``at'' parameters must be packaged in an appropriate list of lists.
17672 @<Set up unsuffixed macro call and |goto restart|@>=
17674 p=mp_get_avail(mp); info(pre_head)=link(pre_head); link(pre_head)=p;
17675 info(p)=t; mp_macro_call(mp, value(q),pre_head,null);
17680 @ If the ``variable'' that turned out to be a suffixed macro no longer exists,
17681 we don't care, because we have reserved a pointer (|macro_ref|) to its
17684 @<Set up suffixed macro call and |goto restart|@>=
17686 mp_back_input(mp); p=mp_get_avail(mp); q=link(post_head);
17687 info(pre_head)=link(pre_head); link(pre_head)=post_head;
17688 info(post_head)=q; link(post_head)=p; info(p)=link(q); link(q)=null;
17689 mp_macro_call(mp, macro_ref,pre_head,null); decr(ref_count(macro_ref));
17690 mp_get_x_next(mp); goto RESTART;
17693 @ Our remaining job is simply to make a copy of the value that has been
17694 found. Some cases are harder than others, but complexity arises solely
17695 because of the multiplicity of possible cases.
17697 @<Declare the procedure called |make_exp_copy|@>=
17698 @<Declare subroutines needed by |make_exp_copy|@>
17699 void mp_make_exp_copy (MP mp,pointer p) {
17700 pointer q,r,t; /* registers for list manipulation */
17702 mp->cur_type=type(p);
17703 switch (mp->cur_type) {
17704 case mp_vacuous: case mp_boolean_type: case mp_known:
17705 mp->cur_exp=value(p); break;
17706 case unknown_types:
17707 mp->cur_exp=mp_new_ring_entry(mp, p);
17709 case mp_string_type:
17710 mp->cur_exp=value(p); add_str_ref(mp->cur_exp);
17712 case mp_picture_type:
17713 mp->cur_exp=value(p);add_edge_ref(mp->cur_exp);
17716 mp->cur_exp=copy_pen(value(p));
17719 mp->cur_exp=mp_copy_path(mp, value(p));
17721 case mp_transform_type: case mp_color_type:
17722 case mp_cmykcolor_type: case mp_pair_type:
17723 @<Copy the big node |p|@>;
17725 case mp_dependent: case mp_proto_dependent:
17726 mp_encapsulate(mp, mp_copy_dep_list(mp, dep_list(p)));
17728 case mp_numeric_type:
17729 new_indep(p); goto RESTART;
17731 case mp_independent:
17732 q=mp_single_dependency(mp, p);
17733 if ( q==mp->dep_final ){
17734 mp->cur_type=mp_known; mp->cur_exp=0; mp_free_node(mp, q,dep_node_size);
17736 mp->cur_type=mp_dependent; mp_encapsulate(mp, q);
17740 mp_confusion(mp, "copy");
17741 @:this can't happen copy}{\quad copy@>
17746 @ The |encapsulate| subroutine assumes that |dep_final| is the
17747 tail of dependency list~|p|.
17749 @<Declare subroutines needed by |make_exp_copy|@>=
17750 void mp_encapsulate (MP mp,pointer p) {
17751 mp->cur_exp=mp_get_node(mp, value_node_size); type(mp->cur_exp)=mp->cur_type;
17752 name_type(mp->cur_exp)=mp_capsule; mp_new_dep(mp, mp->cur_exp,p);
17755 @ The most tedious case arises when the user refers to a
17756 \&{pair}, \&{color}, or \&{transform} variable; we must copy several fields,
17757 each of which can be |independent|, |dependent|, |mp_proto_dependent|,
17760 @<Copy the big node |p|@>=
17762 if ( value(p)==null )
17763 mp_init_big_node(mp, p);
17764 t=mp_get_node(mp, value_node_size); name_type(t)=mp_capsule; type(t)=mp->cur_type;
17765 mp_init_big_node(mp, t);
17766 q=value(p)+mp->big_node_size[mp->cur_type];
17767 r=value(t)+mp->big_node_size[mp->cur_type];
17769 q=q-2; r=r-2; mp_install(mp, r,q);
17770 } while (q!=value(p));
17774 @ The |install| procedure copies a numeric field~|q| into field~|r| of
17775 a big node that will be part of a capsule.
17777 @<Declare subroutines needed by |make_exp_copy|@>=
17778 void mp_install (MP mp,pointer r, pointer q) {
17779 pointer p; /* temporary register */
17780 if ( type(q)==mp_known ){
17781 value(r)=value(q); type(r)=mp_known;
17782 } else if ( type(q)==mp_independent ) {
17783 p=mp_single_dependency(mp, q);
17784 if ( p==mp->dep_final ) {
17785 type(r)=mp_known; value(r)=0; mp_free_node(mp, p,dep_node_size);
17787 type(r)=mp_dependent; mp_new_dep(mp, r,p);
17790 type(r)=type(q); mp_new_dep(mp, r,mp_copy_dep_list(mp, dep_list(q)));
17794 @ Expressions of the form `\.{a[b,c]}' are converted into
17795 `\.{b+a*(c-b)}', without checking the types of \.b~or~\.c,
17796 provided that \.a is numeric.
17798 @<Scan a mediation...@>=
17800 p=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_expression(mp);
17801 if ( mp->cur_cmd!=comma ) {
17802 @<Put the left bracket and the expression back...@>;
17803 mp_unstash_cur_exp(mp, p);
17805 q=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_expression(mp);
17806 if ( mp->cur_cmd!=right_bracket ) {
17807 mp_missing_err(mp, "]");
17809 help3("I've scanned an expression of the form `a[b,c',")
17810 ("so a right bracket should have come next.")
17811 ("I shall pretend that one was there.");
17814 r=mp_stash_cur_exp(mp); mp_make_exp_copy(mp, q);
17815 mp_do_binary(mp, r,minus); mp_do_binary(mp, p,times);
17816 mp_do_binary(mp, q,plus); mp_get_x_next(mp);
17820 @ Here is a comparatively simple routine that is used to scan the
17821 \&{suffix} parameters of a macro.
17823 @<Declare the basic parsing subroutines@>=
17824 void mp_scan_suffix (MP mp) {
17825 pointer h,t; /* head and tail of the list being built */
17826 pointer p; /* temporary register */
17827 h=mp_get_avail(mp); t=h;
17829 if ( mp->cur_cmd==left_bracket ) {
17830 @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>;
17832 if ( mp->cur_cmd==numeric_token ) {
17833 p=mp_new_num_tok(mp, mp->cur_mod);
17834 } else if ((mp->cur_cmd==tag_token)||(mp->cur_cmd==internal_quantity) ) {
17835 p=mp_get_avail(mp); info(p)=mp->cur_sym;
17839 link(t)=p; t=p; mp_get_x_next(mp);
17841 mp->cur_exp=link(h); free_avail(h); mp->cur_type=mp_token_list;
17844 @ @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>=
17846 mp_get_x_next(mp); mp_scan_expression(mp);
17847 if ( mp->cur_type!=mp_known ) mp_bad_subscript(mp);
17848 if ( mp->cur_cmd!=right_bracket ) {
17849 mp_missing_err(mp, "]");
17851 help3("I've seen a `[' and a subscript value, in a suffix,")
17852 ("so a right bracket should have come next.")
17853 ("I shall pretend that one was there.");
17856 mp->cur_cmd=numeric_token; mp->cur_mod=mp->cur_exp;
17859 @* \[38] Parsing secondary and higher expressions.
17861 After the intricacies of |scan_primary|\kern-1pt,
17862 the |scan_secondary| routine is
17863 refreshingly simple. It's not trivial, but the operations are relatively
17864 straightforward; the main difficulty is, again, that expressions and data
17865 structures might change drastically every time we call |get_x_next|, so a
17866 cautious approach is mandatory. For example, a macro defined by
17867 \&{primarydef} might have disappeared by the time its second argument has
17868 been scanned; we solve this by increasing the reference count of its token
17869 list, so that the macro can be called even after it has been clobbered.
17871 @<Declare the basic parsing subroutines@>=
17872 void mp_scan_secondary (MP mp) {
17873 pointer p; /* for list manipulation */
17874 halfword c,d; /* operation codes or modifiers */
17875 pointer mac_name; /* token defined with \&{primarydef} */
17877 if ((mp->cur_cmd<min_primary_command)||
17878 (mp->cur_cmd>max_primary_command) )
17879 mp_bad_exp(mp, "A secondary");
17880 @.A secondary expression...@>
17881 mp_scan_primary(mp);
17883 if ( mp->cur_cmd<=max_secondary_command &&
17884 mp->cur_cmd>=min_secondary_command ) {
17885 p=mp_stash_cur_exp(mp);
17886 c=mp->cur_mod; d=mp->cur_cmd;
17887 if ( d==secondary_primary_macro ) {
17888 mac_name=mp->cur_sym;
17892 mp_scan_primary(mp);
17893 if ( d!=secondary_primary_macro ) {
17894 mp_do_binary(mp, p,c);
17897 mp_binary_mac(mp, p,c,mac_name);
17898 decr(ref_count(c));
17906 @ The following procedure calls a macro that has two parameters,
17909 @c void mp_binary_mac (MP mp,pointer p, pointer c, pointer n) {
17910 pointer q,r; /* nodes in the parameter list */
17911 q=mp_get_avail(mp); r=mp_get_avail(mp); link(q)=r;
17912 info(q)=p; info(r)=mp_stash_cur_exp(mp);
17913 mp_macro_call(mp, c,q,n);
17916 @ The next procedure, |scan_tertiary|, is pretty much the same deal.
17918 @<Declare the basic parsing subroutines@>=
17919 void mp_scan_tertiary (MP mp) {
17920 pointer p; /* for list manipulation */
17921 halfword c,d; /* operation codes or modifiers */
17922 pointer mac_name; /* token defined with \&{secondarydef} */
17924 if ((mp->cur_cmd<min_primary_command)||
17925 (mp->cur_cmd>max_primary_command) )
17926 mp_bad_exp(mp, "A tertiary");
17927 @.A tertiary expression...@>
17928 mp_scan_secondary(mp);
17930 if ( mp->cur_cmd<=max_tertiary_command ) {
17931 if ( mp->cur_cmd>=min_tertiary_command ) {
17932 p=mp_stash_cur_exp(mp); c=mp->cur_mod; d=mp->cur_cmd;
17933 if ( d==tertiary_secondary_macro ) {
17934 mac_name=mp->cur_sym; add_mac_ref(c);
17936 mp_get_x_next(mp); mp_scan_secondary(mp);
17937 if ( d!=tertiary_secondary_macro ) {
17938 mp_do_binary(mp, p,c);
17940 mp_back_input(mp); mp_binary_mac(mp, p,c,mac_name);
17941 decr(ref_count(c)); mp_get_x_next(mp);
17949 @ Finally we reach the deepest level in our quartet of parsing routines.
17950 This one is much like the others; but it has an extra complication from
17951 paths, which materialize here.
17953 @d continue_path 25 /* a label inside of |scan_expression| */
17954 @d finish_path 26 /* another */
17956 @<Declare the basic parsing subroutines@>=
17957 void mp_scan_expression (MP mp) {
17958 pointer p,q,r,pp,qq; /* for list manipulation */
17959 halfword c,d; /* operation codes or modifiers */
17960 int my_var_flag; /* initial value of |var_flag| */
17961 pointer mac_name; /* token defined with \&{tertiarydef} */
17962 boolean cycle_hit; /* did a path expression just end with `\&{cycle}'? */
17963 scaled x,y; /* explicit coordinates or tension at a path join */
17964 int t; /* knot type following a path join */
17966 my_var_flag=mp->var_flag; mac_name=null;
17968 if ((mp->cur_cmd<min_primary_command)||
17969 (mp->cur_cmd>max_primary_command) )
17970 mp_bad_exp(mp, "An");
17971 @.An expression...@>
17972 mp_scan_tertiary(mp);
17974 if ( mp->cur_cmd<=max_expression_command )
17975 if ( mp->cur_cmd>=min_expression_command ) {
17976 if ( (mp->cur_cmd!=equals)||(my_var_flag!=assignment) ) {
17977 p=mp_stash_cur_exp(mp); c=mp->cur_mod; d=mp->cur_cmd;
17978 if ( d==expression_tertiary_macro ) {
17979 mac_name=mp->cur_sym; add_mac_ref(c);
17981 if ( (d<ampersand)||((d==ampersand)&&
17982 ((type(p)==mp_pair_type)||(type(p)==mp_path_type))) ) {
17983 @<Scan a path construction operation;
17984 but |return| if |p| has the wrong type@>;
17986 mp_get_x_next(mp); mp_scan_tertiary(mp);
17987 if ( d!=expression_tertiary_macro ) {
17988 mp_do_binary(mp, p,c);
17990 mp_back_input(mp); mp_binary_mac(mp, p,c,mac_name);
17991 decr(ref_count(c)); mp_get_x_next(mp);
18000 @ The reader should review the data structure conventions for paths before
18001 hoping to understand the next part of this code.
18003 @<Scan a path construction operation...@>=
18006 @<Convert the left operand, |p|, into a partial path ending at~|q|;
18007 but |return| if |p| doesn't have a suitable type@>;
18009 @<Determine the path join parameters;
18010 but |goto finish_path| if there's only a direction specifier@>;
18011 if ( mp->cur_cmd==cycle ) {
18012 @<Get ready to close a cycle@>;
18014 mp_scan_tertiary(mp);
18015 @<Convert the right operand, |cur_exp|,
18016 into a partial path from |pp| to~|qq|@>;
18018 @<Join the partial paths and reset |p| and |q| to the head and tail
18020 if ( mp->cur_cmd>=min_expression_command )
18021 if ( mp->cur_cmd<=ampersand ) if ( ! cycle_hit ) goto CONTINUE_PATH;
18023 @<Choose control points for the path and put the result into |cur_exp|@>;
18026 @ @<Convert the left operand, |p|, into a partial path ending at~|q|...@>=
18028 mp_unstash_cur_exp(mp, p);
18029 if ( mp->cur_type==mp_pair_type ) p=mp_new_knot(mp);
18030 else if ( mp->cur_type==mp_path_type ) p=mp->cur_exp;
18033 while ( link(q)!=p ) q=link(q);
18034 if ( left_type(p)!=mp_endpoint ) { /* open up a cycle */
18035 r=mp_copy_knot(mp, p); link(q)=r; q=r;
18037 left_type(p)=mp_open; right_type(q)=mp_open;
18040 @ A pair of numeric values is changed into a knot node for a one-point path
18041 when \MP\ discovers that the pair is part of a path.
18043 @c @<Declare the procedure called |known_pair|@>
18044 pointer mp_new_knot (MP mp) { /* convert a pair to a knot with two endpoints */
18045 pointer q; /* the new node */
18046 q=mp_get_node(mp, knot_node_size); left_type(q)=mp_endpoint;
18047 right_type(q)=mp_endpoint; originator(q)=mp_metapost_user; link(q)=q;
18048 mp_known_pair(mp); x_coord(q)=mp->cur_x; y_coord(q)=mp->cur_y;
18052 @ The |known_pair| subroutine sets |cur_x| and |cur_y| to the components
18053 of the current expression, assuming that the current expression is a
18054 pair of known numerics. Unknown components are zeroed, and the
18055 current expression is flushed.
18057 @<Declare the procedure called |known_pair|@>=
18058 void mp_known_pair (MP mp) {
18059 pointer p; /* the pair node */
18060 if ( mp->cur_type!=mp_pair_type ) {
18061 exp_err("Undefined coordinates have been replaced by (0,0)");
18062 @.Undefined coordinates...@>
18063 help5("I need x and y numbers for this part of the path.")
18064 ("The value I found (see above) was no good;")
18065 ("so I'll try to keep going by using zero instead.")
18066 ("(Chapter 27 of The METAFONTbook explains that")
18067 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18068 ("you might want to type `I ??" "?' now.)");
18069 mp_put_get_flush_error(mp, 0); mp->cur_x=0; mp->cur_y=0;
18071 p=value(mp->cur_exp);
18072 @<Make sure that both |x| and |y| parts of |p| are known;
18073 copy them into |cur_x| and |cur_y|@>;
18074 mp_flush_cur_exp(mp, 0);
18078 @ @<Make sure that both |x| and |y| parts of |p| are known...@>=
18079 if ( type(x_part_loc(p))==mp_known ) {
18080 mp->cur_x=value(x_part_loc(p));
18082 mp_disp_err(mp, x_part_loc(p),
18083 "Undefined x coordinate has been replaced by 0");
18084 @.Undefined coordinates...@>
18085 help5("I need a `known' x value for this part of the path.")
18086 ("The value I found (see above) was no good;")
18087 ("so I'll try to keep going by using zero instead.")
18088 ("(Chapter 27 of The METAFONTbook explains that")
18089 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18090 ("you might want to type `I ??" "?' now.)");
18091 mp_put_get_error(mp); mp_recycle_value(mp, x_part_loc(p)); mp->cur_x=0;
18093 if ( type(y_part_loc(p))==mp_known ) {
18094 mp->cur_y=value(y_part_loc(p));
18096 mp_disp_err(mp, y_part_loc(p),
18097 "Undefined y coordinate has been replaced by 0");
18098 help5("I need a `known' y value for this part of the path.")
18099 ("The value I found (see above) was no good;")
18100 ("so I'll try to keep going by using zero instead.")
18101 ("(Chapter 27 of The METAFONTbook explains that")
18102 ("you might want to type `I ??" "?' now.)");
18103 mp_put_get_error(mp); mp_recycle_value(mp, y_part_loc(p)); mp->cur_y=0;
18106 @ At this point |cur_cmd| is either |ampersand|, |left_brace|, or |path_join|.
18108 @<Determine the path join parameters...@>=
18109 if ( mp->cur_cmd==left_brace ) {
18110 @<Put the pre-join direction information into node |q|@>;
18113 if ( d==path_join ) {
18114 @<Determine the tension and/or control points@>;
18115 } else if ( d!=ampersand ) {
18119 if ( mp->cur_cmd==left_brace ) {
18120 @<Put the post-join direction information into |x| and |t|@>;
18121 } else if ( right_type(q)!=mp_explicit ) {
18125 @ The |scan_direction| subroutine looks at the directional information
18126 that is enclosed in braces, and also scans ahead to the following character.
18127 A type code is returned, either |open| (if the direction was $(0,0)$),
18128 or |curl| (if the direction was a curl of known value |cur_exp|), or
18129 |given| (if the direction is given by the |angle| value that now
18130 appears in |cur_exp|).
18132 There's nothing difficult about this subroutine, but the program is rather
18133 lengthy because a variety of potential errors need to be nipped in the bud.
18135 @c small_number mp_scan_direction (MP mp) {
18136 int t; /* the type of information found */
18137 scaled x; /* an |x| coordinate */
18139 if ( mp->cur_cmd==curl_command ) {
18140 @<Scan a curl specification@>;
18142 @<Scan a given direction@>;
18144 if ( mp->cur_cmd!=right_brace ) {
18145 mp_missing_err(mp, "}");
18146 @.Missing `\char`\}'@>
18147 help3("I've scanned a direction spec for part of a path,")
18148 ("so a right brace should have come next.")
18149 ("I shall pretend that one was there.");
18156 @ @<Scan a curl specification@>=
18157 { mp_get_x_next(mp); mp_scan_expression(mp);
18158 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<0) ){
18159 exp_err("Improper curl has been replaced by 1");
18161 help1("A curl must be a known, nonnegative number.");
18162 mp_put_get_flush_error(mp, unity);
18167 @ @<Scan a given direction@>=
18168 { mp_scan_expression(mp);
18169 if ( mp->cur_type>mp_pair_type ) {
18170 @<Get given directions separated by commas@>;
18174 if ( (mp->cur_x==0)&&(mp->cur_y==0) ) t=mp_open;
18175 else { t=mp_given; mp->cur_exp=mp_n_arg(mp, mp->cur_x,mp->cur_y);}
18178 @ @<Get given directions separated by commas@>=
18180 if ( mp->cur_type!=mp_known ) {
18181 exp_err("Undefined x coordinate has been replaced by 0");
18182 @.Undefined coordinates...@>
18183 help5("I need a `known' x value for this part of the path.")
18184 ("The value I found (see above) was no good;")
18185 ("so I'll try to keep going by using zero instead.")
18186 ("(Chapter 27 of The METAFONTbook explains that")
18187 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18188 ("you might want to type `I ??" "?' now.)");
18189 mp_put_get_flush_error(mp, 0);
18192 if ( mp->cur_cmd!=comma ) {
18193 mp_missing_err(mp, ",");
18195 help2("I've got the x coordinate of a path direction;")
18196 ("will look for the y coordinate next.");
18199 mp_get_x_next(mp); mp_scan_expression(mp);
18200 if ( mp->cur_type!=mp_known ) {
18201 exp_err("Undefined y coordinate has been replaced by 0");
18202 help5("I need a `known' y value for this part of the path.")
18203 ("The value I found (see above) was no good;")
18204 ("so I'll try to keep going by using zero instead.")
18205 ("(Chapter 27 of The METAFONTbook explains that")
18206 ("you might want to type `I ??" "?' now.)");
18207 mp_put_get_flush_error(mp, 0);
18209 mp->cur_y=mp->cur_exp; mp->cur_x=x;
18212 @ At this point |right_type(q)| is usually |open|, but it may have been
18213 set to some other value by a previous operation. We must maintain
18214 the value of |right_type(q)| in cases such as
18215 `\.{..\{curl2\}z\{0,0\}..}'.
18217 @<Put the pre-join...@>=
18219 t=mp_scan_direction(mp);
18220 if ( t!=mp_open ) {
18221 right_type(q)=t; right_given(q)=mp->cur_exp;
18222 if ( left_type(q)==mp_open ) {
18223 left_type(q)=t; left_given(q)=mp->cur_exp;
18224 } /* note that |left_given(q)=left_curl(q)| */
18228 @ Since |left_tension| and |left_y| share the same position in knot nodes,
18229 and since |left_given| is similarly equivalent to |left_x|, we use
18230 |x| and |y| to hold the given direction and tension information when
18231 there are no explicit control points.
18233 @<Put the post-join...@>=
18235 t=mp_scan_direction(mp);
18236 if ( right_type(q)!=mp_explicit ) x=mp->cur_exp;
18237 else t=mp_explicit; /* the direction information is superfluous */
18240 @ @<Determine the tension and/or...@>=
18243 if ( mp->cur_cmd==tension ) {
18244 @<Set explicit tensions@>;
18245 } else if ( mp->cur_cmd==controls ) {
18246 @<Set explicit control points@>;
18248 right_tension(q)=unity; y=unity; mp_back_input(mp); /* default tension */
18251 if ( mp->cur_cmd!=path_join ) {
18252 mp_missing_err(mp, "..");
18254 help1("A path join command should end with two dots.");
18261 @ @<Set explicit tensions@>=
18263 mp_get_x_next(mp); y=mp->cur_cmd;
18264 if ( mp->cur_cmd==at_least ) mp_get_x_next(mp);
18265 mp_scan_primary(mp);
18266 @<Make sure that the current expression is a valid tension setting@>;
18267 if ( y==at_least ) negate(mp->cur_exp);
18268 right_tension(q)=mp->cur_exp;
18269 if ( mp->cur_cmd==and_command ) {
18270 mp_get_x_next(mp); y=mp->cur_cmd;
18271 if ( mp->cur_cmd==at_least ) mp_get_x_next(mp);
18272 mp_scan_primary(mp);
18273 @<Make sure that the current expression is a valid tension setting@>;
18274 if ( y==at_least ) negate(mp->cur_exp);
18279 @ @d min_tension three_quarter_unit
18281 @<Make sure that the current expression is a valid tension setting@>=
18282 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<min_tension) ) {
18283 exp_err("Improper tension has been set to 1");
18284 @.Improper tension@>
18285 help1("The expression above should have been a number >=3/4.");
18286 mp_put_get_flush_error(mp, unity);
18289 @ @<Set explicit control points@>=
18291 right_type(q)=mp_explicit; t=mp_explicit; mp_get_x_next(mp); mp_scan_primary(mp);
18292 mp_known_pair(mp); right_x(q)=mp->cur_x; right_y(q)=mp->cur_y;
18293 if ( mp->cur_cmd!=and_command ) {
18294 x=right_x(q); y=right_y(q);
18296 mp_get_x_next(mp); mp_scan_primary(mp);
18297 mp_known_pair(mp); x=mp->cur_x; y=mp->cur_y;
18301 @ @<Convert the right operand, |cur_exp|, into a partial path...@>=
18303 if ( mp->cur_type!=mp_path_type ) pp=mp_new_knot(mp);
18304 else pp=mp->cur_exp;
18306 while ( link(qq)!=pp ) qq=link(qq);
18307 if ( left_type(pp)!=mp_endpoint ) { /* open up a cycle */
18308 r=mp_copy_knot(mp, pp); link(qq)=r; qq=r;
18310 left_type(pp)=mp_open; right_type(qq)=mp_open;
18313 @ If a person tries to define an entire path by saying `\.{(x,y)\&cycle}',
18314 we silently change the specification to `\.{(x,y)..cycle}', since a cycle
18315 shouldn't have length zero.
18317 @<Get ready to close a cycle@>=
18319 cycle_hit=true; mp_get_x_next(mp); pp=p; qq=p;
18320 if ( d==ampersand ) if ( p==q ) {
18321 d=path_join; right_tension(q)=unity; y=unity;
18325 @ @<Join the partial paths and reset |p| and |q|...@>=
18327 if ( d==ampersand ) {
18328 if ( (x_coord(q)!=x_coord(pp))||(y_coord(q)!=y_coord(pp)) ) {
18329 print_err("Paths don't touch; `&' will be changed to `..'");
18330 @.Paths don't touch@>
18331 help3("When you join paths `p&q', the ending point of p")
18332 ("must be exactly equal to the starting point of q.")
18333 ("So I'm going to pretend that you said `p..q' instead.");
18334 mp_put_get_error(mp); d=path_join; right_tension(q)=unity; y=unity;
18337 @<Plug an opening in |right_type(pp)|, if possible@>;
18338 if ( d==ampersand ) {
18339 @<Splice independent paths together@>;
18341 @<Plug an opening in |right_type(q)|, if possible@>;
18342 link(q)=pp; left_y(pp)=y;
18343 if ( t!=mp_open ) { left_x(pp)=x; left_type(pp)=t; };
18348 @ @<Plug an opening in |right_type(q)|...@>=
18349 if ( right_type(q)==mp_open ) {
18350 if ( (left_type(q)==mp_curl)||(left_type(q)==mp_given) ) {
18351 right_type(q)=left_type(q); right_given(q)=left_given(q);
18355 @ @<Plug an opening in |right_type(pp)|...@>=
18356 if ( right_type(pp)==mp_open ) {
18357 if ( (t==mp_curl)||(t==mp_given) ) {
18358 right_type(pp)=t; right_given(pp)=x;
18362 @ @<Splice independent paths together@>=
18364 if ( left_type(q)==mp_open ) if ( right_type(q)==mp_open ) {
18365 left_type(q)=mp_curl; left_curl(q)=unity;
18367 if ( right_type(pp)==mp_open ) if ( t==mp_open ) {
18368 right_type(pp)=mp_curl; right_curl(pp)=unity;
18370 right_type(q)=right_type(pp); link(q)=link(pp);
18371 right_x(q)=right_x(pp); right_y(q)=right_y(pp);
18372 mp_free_node(mp, pp,knot_node_size);
18373 if ( qq==pp ) qq=q;
18376 @ @<Choose control points for the path...@>=
18378 if ( d==ampersand ) p=q;
18380 left_type(p)=mp_endpoint;
18381 if ( right_type(p)==mp_open ) {
18382 right_type(p)=mp_curl; right_curl(p)=unity;
18384 right_type(q)=mp_endpoint;
18385 if ( left_type(q)==mp_open ) {
18386 left_type(q)=mp_curl; left_curl(q)=unity;
18390 mp_make_choices(mp, p);
18391 mp->cur_type=mp_path_type; mp->cur_exp=p
18393 @ Finally, we sometimes need to scan an expression whose value is
18394 supposed to be either |true_code| or |false_code|.
18396 @<Declare the basic parsing subroutines@>=
18397 void mp_get_boolean (MP mp) {
18398 mp_get_x_next(mp); mp_scan_expression(mp);
18399 if ( mp->cur_type!=mp_boolean_type ) {
18400 exp_err("Undefined condition will be treated as `false'");
18401 @.Undefined condition...@>
18402 help2("The expression shown above should have had a definite")
18403 ("true-or-false value. I'm changing it to `false'.");
18404 mp_put_get_flush_error(mp, false_code); mp->cur_type=mp_boolean_type;
18408 @* \[39] Doing the operations.
18409 The purpose of parsing is primarily to permit people to avoid piles of
18410 parentheses. But the real work is done after the structure of an expression
18411 has been recognized; that's when new expressions are generated. We
18412 turn now to the guts of \MP, which handles individual operators that
18413 have come through the parsing mechanism.
18415 We'll start with the easy ones that take no operands, then work our way
18416 up to operators with one and ultimately two arguments. In other words,
18417 we will write the three procedures |do_nullary|, |do_unary|, and |do_binary|
18418 that are invoked periodically by the expression scanners.
18420 First let's make sure that all of the primitive operators are in the
18421 hash table. Although |scan_primary| and its relatives made use of the
18422 \\{cmd} code for these operators, the \\{do} routines base everything
18423 on the \\{mod} code. For example, |do_binary| doesn't care whether the
18424 operation it performs is a |primary_binary| or |secondary_binary|, etc.
18427 mp_primitive(mp, "true",nullary,true_code);
18428 @:true_}{\&{true} primitive@>
18429 mp_primitive(mp, "false",nullary,false_code);
18430 @:false_}{\&{false} primitive@>
18431 mp_primitive(mp, "nullpicture",nullary,null_picture_code);
18432 @:null_picture_}{\&{nullpicture} primitive@>
18433 mp_primitive(mp, "nullpen",nullary,null_pen_code);
18434 @:null_pen_}{\&{nullpen} primitive@>
18435 mp_primitive(mp, "jobname",nullary,job_name_op);
18436 @:job_name_}{\&{jobname} primitive@>
18437 mp_primitive(mp, "readstring",nullary,read_string_op);
18438 @:read_string_}{\&{readstring} primitive@>
18439 mp_primitive(mp, "pencircle",nullary,pen_circle);
18440 @:pen_circle_}{\&{pencircle} primitive@>
18441 mp_primitive(mp, "normaldeviate",nullary,normal_deviate);
18442 @:normal_deviate_}{\&{normaldeviate} primitive@>
18443 mp_primitive(mp, "readfrom",unary,read_from_op);
18444 @:read_from_}{\&{readfrom} primitive@>
18445 mp_primitive(mp, "closefrom",unary,close_from_op);
18446 @:close_from_}{\&{closefrom} primitive@>
18447 mp_primitive(mp, "odd",unary,odd_op);
18448 @:odd_}{\&{odd} primitive@>
18449 mp_primitive(mp, "known",unary,known_op);
18450 @:known_}{\&{known} primitive@>
18451 mp_primitive(mp, "unknown",unary,unknown_op);
18452 @:unknown_}{\&{unknown} primitive@>
18453 mp_primitive(mp, "not",unary,not_op);
18454 @:not_}{\&{not} primitive@>
18455 mp_primitive(mp, "decimal",unary,decimal);
18456 @:decimal_}{\&{decimal} primitive@>
18457 mp_primitive(mp, "reverse",unary,reverse);
18458 @:reverse_}{\&{reverse} primitive@>
18459 mp_primitive(mp, "makepath",unary,make_path_op);
18460 @:make_path_}{\&{makepath} primitive@>
18461 mp_primitive(mp, "makepen",unary,make_pen_op);
18462 @:make_pen_}{\&{makepen} primitive@>
18463 mp_primitive(mp, "oct",unary,oct_op);
18464 @:oct_}{\&{oct} primitive@>
18465 mp_primitive(mp, "hex",unary,hex_op);
18466 @:hex_}{\&{hex} primitive@>
18467 mp_primitive(mp, "ASCII",unary,ASCII_op);
18468 @:ASCII_}{\&{ASCII} primitive@>
18469 mp_primitive(mp, "char",unary,char_op);
18470 @:char_}{\&{char} primitive@>
18471 mp_primitive(mp, "length",unary,length_op);
18472 @:length_}{\&{length} primitive@>
18473 mp_primitive(mp, "turningnumber",unary,turning_op);
18474 @:turning_number_}{\&{turningnumber} primitive@>
18475 mp_primitive(mp, "xpart",unary,x_part);
18476 @:x_part_}{\&{xpart} primitive@>
18477 mp_primitive(mp, "ypart",unary,y_part);
18478 @:y_part_}{\&{ypart} primitive@>
18479 mp_primitive(mp, "xxpart",unary,xx_part);
18480 @:xx_part_}{\&{xxpart} primitive@>
18481 mp_primitive(mp, "xypart",unary,xy_part);
18482 @:xy_part_}{\&{xypart} primitive@>
18483 mp_primitive(mp, "yxpart",unary,yx_part);
18484 @:yx_part_}{\&{yxpart} primitive@>
18485 mp_primitive(mp, "yypart",unary,yy_part);
18486 @:yy_part_}{\&{yypart} primitive@>
18487 mp_primitive(mp, "redpart",unary,red_part);
18488 @:red_part_}{\&{redpart} primitive@>
18489 mp_primitive(mp, "greenpart",unary,green_part);
18490 @:green_part_}{\&{greenpart} primitive@>
18491 mp_primitive(mp, "bluepart",unary,blue_part);
18492 @:blue_part_}{\&{bluepart} primitive@>
18493 mp_primitive(mp, "cyanpart",unary,cyan_part);
18494 @:cyan_part_}{\&{cyanpart} primitive@>
18495 mp_primitive(mp, "magentapart",unary,magenta_part);
18496 @:magenta_part_}{\&{magentapart} primitive@>
18497 mp_primitive(mp, "yellowpart",unary,yellow_part);
18498 @:yellow_part_}{\&{yellowpart} primitive@>
18499 mp_primitive(mp, "blackpart",unary,black_part);
18500 @:black_part_}{\&{blackpart} primitive@>
18501 mp_primitive(mp, "greypart",unary,grey_part);
18502 @:grey_part_}{\&{greypart} primitive@>
18503 mp_primitive(mp, "colormodel",unary,color_model_part);
18504 @:color_model_part_}{\&{colormodel} primitive@>
18505 mp_primitive(mp, "fontpart",unary,font_part);
18506 @:font_part_}{\&{fontpart} primitive@>
18507 mp_primitive(mp, "textpart",unary,text_part);
18508 @:text_part_}{\&{textpart} primitive@>
18509 mp_primitive(mp, "pathpart",unary,path_part);
18510 @:path_part_}{\&{pathpart} primitive@>
18511 mp_primitive(mp, "penpart",unary,pen_part);
18512 @:pen_part_}{\&{penpart} primitive@>
18513 mp_primitive(mp, "dashpart",unary,dash_part);
18514 @:dash_part_}{\&{dashpart} primitive@>
18515 mp_primitive(mp, "sqrt",unary,sqrt_op);
18516 @:sqrt_}{\&{sqrt} primitive@>
18517 mp_primitive(mp, "mexp",unary,m_exp_op);
18518 @:m_exp_}{\&{mexp} primitive@>
18519 mp_primitive(mp, "mlog",unary,m_log_op);
18520 @:m_log_}{\&{mlog} primitive@>
18521 mp_primitive(mp, "sind",unary,sin_d_op);
18522 @:sin_d_}{\&{sind} primitive@>
18523 mp_primitive(mp, "cosd",unary,cos_d_op);
18524 @:cos_d_}{\&{cosd} primitive@>
18525 mp_primitive(mp, "floor",unary,floor_op);
18526 @:floor_}{\&{floor} primitive@>
18527 mp_primitive(mp, "uniformdeviate",unary,uniform_deviate);
18528 @:uniform_deviate_}{\&{uniformdeviate} primitive@>
18529 mp_primitive(mp, "charexists",unary,char_exists_op);
18530 @:char_exists_}{\&{charexists} primitive@>
18531 mp_primitive(mp, "fontsize",unary,font_size);
18532 @:font_size_}{\&{fontsize} primitive@>
18533 mp_primitive(mp, "llcorner",unary,ll_corner_op);
18534 @:ll_corner_}{\&{llcorner} primitive@>
18535 mp_primitive(mp, "lrcorner",unary,lr_corner_op);
18536 @:lr_corner_}{\&{lrcorner} primitive@>
18537 mp_primitive(mp, "ulcorner",unary,ul_corner_op);
18538 @:ul_corner_}{\&{ulcorner} primitive@>
18539 mp_primitive(mp, "urcorner",unary,ur_corner_op);
18540 @:ur_corner_}{\&{urcorner} primitive@>
18541 mp_primitive(mp, "arclength",unary,arc_length);
18542 @:arc_length_}{\&{arclength} primitive@>
18543 mp_primitive(mp, "angle",unary,angle_op);
18544 @:angle_}{\&{angle} primitive@>
18545 mp_primitive(mp, "cycle",cycle,cycle_op);
18546 @:cycle_}{\&{cycle} primitive@>
18547 mp_primitive(mp, "stroked",unary,stroked_op);
18548 @:stroked_}{\&{stroked} primitive@>
18549 mp_primitive(mp, "filled",unary,filled_op);
18550 @:filled_}{\&{filled} primitive@>
18551 mp_primitive(mp, "textual",unary,textual_op);
18552 @:textual_}{\&{textual} primitive@>
18553 mp_primitive(mp, "clipped",unary,clipped_op);
18554 @:clipped_}{\&{clipped} primitive@>
18555 mp_primitive(mp, "bounded",unary,bounded_op);
18556 @:bounded_}{\&{bounded} primitive@>
18557 mp_primitive(mp, "+",plus_or_minus,plus);
18558 @:+ }{\.{+} primitive@>
18559 mp_primitive(mp, "-",plus_or_minus,minus);
18560 @:- }{\.{-} primitive@>
18561 mp_primitive(mp, "*",secondary_binary,times);
18562 @:* }{\.{*} primitive@>
18563 mp_primitive(mp, "/",slash,over); mp->eqtb[frozen_slash]=mp->eqtb[mp->cur_sym];
18564 @:/ }{\.{/} primitive@>
18565 mp_primitive(mp, "++",tertiary_binary,pythag_add);
18566 @:++_}{\.{++} primitive@>
18567 mp_primitive(mp, "+-+",tertiary_binary,pythag_sub);
18568 @:+-+_}{\.{+-+} primitive@>
18569 mp_primitive(mp, "or",tertiary_binary,or_op);
18570 @:or_}{\&{or} primitive@>
18571 mp_primitive(mp, "and",and_command,and_op);
18572 @:and_}{\&{and} primitive@>
18573 mp_primitive(mp, "<",expression_binary,less_than);
18574 @:< }{\.{<} primitive@>
18575 mp_primitive(mp, "<=",expression_binary,less_or_equal);
18576 @:<=_}{\.{<=} primitive@>
18577 mp_primitive(mp, ">",expression_binary,greater_than);
18578 @:> }{\.{>} primitive@>
18579 mp_primitive(mp, ">=",expression_binary,greater_or_equal);
18580 @:>=_}{\.{>=} primitive@>
18581 mp_primitive(mp, "=",equals,equal_to);
18582 @:= }{\.{=} primitive@>
18583 mp_primitive(mp, "<>",expression_binary,unequal_to);
18584 @:<>_}{\.{<>} primitive@>
18585 mp_primitive(mp, "substring",primary_binary,substring_of);
18586 @:substring_}{\&{substring} primitive@>
18587 mp_primitive(mp, "subpath",primary_binary,subpath_of);
18588 @:subpath_}{\&{subpath} primitive@>
18589 mp_primitive(mp, "directiontime",primary_binary,direction_time_of);
18590 @:direction_time_}{\&{directiontime} primitive@>
18591 mp_primitive(mp, "point",primary_binary,point_of);
18592 @:point_}{\&{point} primitive@>
18593 mp_primitive(mp, "precontrol",primary_binary,precontrol_of);
18594 @:precontrol_}{\&{precontrol} primitive@>
18595 mp_primitive(mp, "postcontrol",primary_binary,postcontrol_of);
18596 @:postcontrol_}{\&{postcontrol} primitive@>
18597 mp_primitive(mp, "penoffset",primary_binary,pen_offset_of);
18598 @:pen_offset_}{\&{penoffset} primitive@>
18599 mp_primitive(mp, "arctime",primary_binary,arc_time_of);
18600 @:arc_time_of_}{\&{arctime} primitive@>
18601 mp_primitive(mp, "mpversion",nullary,mp_version);
18602 @:mp_verison_}{\&{mpversion} primitive@>
18603 mp_primitive(mp, "&",ampersand,concatenate);
18604 @:!!!}{\.{\&} primitive@>
18605 mp_primitive(mp, "rotated",secondary_binary,rotated_by);
18606 @:rotated_}{\&{rotated} primitive@>
18607 mp_primitive(mp, "slanted",secondary_binary,slanted_by);
18608 @:slanted_}{\&{slanted} primitive@>
18609 mp_primitive(mp, "scaled",secondary_binary,scaled_by);
18610 @:scaled_}{\&{scaled} primitive@>
18611 mp_primitive(mp, "shifted",secondary_binary,shifted_by);
18612 @:shifted_}{\&{shifted} primitive@>
18613 mp_primitive(mp, "transformed",secondary_binary,transformed_by);
18614 @:transformed_}{\&{transformed} primitive@>
18615 mp_primitive(mp, "xscaled",secondary_binary,x_scaled);
18616 @:x_scaled_}{\&{xscaled} primitive@>
18617 mp_primitive(mp, "yscaled",secondary_binary,y_scaled);
18618 @:y_scaled_}{\&{yscaled} primitive@>
18619 mp_primitive(mp, "zscaled",secondary_binary,z_scaled);
18620 @:z_scaled_}{\&{zscaled} primitive@>
18621 mp_primitive(mp, "infont",secondary_binary,in_font);
18622 @:in_font_}{\&{infont} primitive@>
18623 mp_primitive(mp, "intersectiontimes",tertiary_binary,intersect);
18624 @:intersection_times_}{\&{intersectiontimes} primitive@>
18625 mp_primitive(mp, "envelope",primary_binary,envelope_of);
18626 @:envelope_}{\&{envelope} primitive@>
18628 @ @<Cases of |print_cmd...@>=
18631 case primary_binary:
18632 case secondary_binary:
18633 case tertiary_binary:
18634 case expression_binary:
18636 case plus_or_minus:
18641 mp_print_op(mp, m);
18644 @ OK, let's look at the simplest \\{do} procedure first.
18646 @c @<Declare nullary action procedure@>
18647 void mp_do_nullary (MP mp,quarterword c) {
18649 if ( mp->internal[mp_tracing_commands]>two )
18650 mp_show_cmd_mod(mp, nullary,c);
18652 case true_code: case false_code:
18653 mp->cur_type=mp_boolean_type; mp->cur_exp=c;
18655 case null_picture_code:
18656 mp->cur_type=mp_picture_type;
18657 mp->cur_exp=mp_get_node(mp, edge_header_size);
18658 mp_init_edges(mp, mp->cur_exp);
18660 case null_pen_code:
18661 mp->cur_type=mp_pen_type; mp->cur_exp=mp_get_pen_circle(mp, 0);
18663 case normal_deviate:
18664 mp->cur_type=mp_known; mp->cur_exp=mp_norm_rand(mp);
18667 mp->cur_type=mp_pen_type; mp->cur_exp=mp_get_pen_circle(mp, unity);
18670 if ( mp->job_name==NULL ) mp_open_log_file(mp);
18671 mp->cur_type=mp_string_type; mp->cur_exp=rts(mp->job_name);
18674 mp->cur_type=mp_string_type;
18675 mp->cur_exp=intern(metapost_version) ;
18677 case read_string_op:
18678 @<Read a string from the terminal@>;
18680 } /* there are no other cases */
18684 @ @<Read a string...@>=
18686 if (mp->noninteractive || mp->interaction<=mp_nonstop_mode )
18687 mp_fatal_error(mp, "*** (cannot readstring in nonstop modes)");
18688 mp_begin_file_reading(mp); name=is_read;
18689 limit=start; prompt_input("");
18690 mp_finish_read(mp);
18693 @ @<Declare nullary action procedure@>=
18694 void mp_finish_read (MP mp) { /* copy |buffer| line to |cur_exp| */
18696 str_room((int)mp->last-start);
18697 for (k=start;k<=mp->last-1;k++) {
18698 append_char(mp->buffer[k]);
18700 mp_end_file_reading(mp); mp->cur_type=mp_string_type;
18701 mp->cur_exp=mp_make_string(mp);
18704 @ Things get a bit more interesting when there's an operand. The
18705 operand to |do_unary| appears in |cur_type| and |cur_exp|.
18707 @c @<Declare unary action procedures@>
18708 void mp_do_unary (MP mp,quarterword c) {
18709 pointer p,q,r; /* for list manipulation */
18710 integer x; /* a temporary register */
18712 if ( mp->internal[mp_tracing_commands]>two )
18713 @<Trace the current unary operation@>;
18716 if ( mp->cur_type<mp_color_type ) mp_bad_unary(mp, plus);
18719 @<Negate the current expression@>;
18721 @<Additional cases of unary operators@>;
18722 } /* there are no other cases */
18726 @ The |nice_pair| function returns |true| if both components of a pair
18729 @<Declare unary action procedures@>=
18730 boolean mp_nice_pair (MP mp,integer p, quarterword t) {
18731 if ( t==mp_pair_type ) {
18733 if ( type(x_part_loc(p))==mp_known )
18734 if ( type(y_part_loc(p))==mp_known )
18740 @ The |nice_color_or_pair| function is analogous except that it also accepts
18741 fully known colors.
18743 @<Declare unary action procedures@>=
18744 boolean mp_nice_color_or_pair (MP mp,integer p, quarterword t) {
18745 pointer q,r; /* for scanning the big node */
18746 if ( (t!=mp_pair_type)&&(t!=mp_color_type)&&(t!=mp_cmykcolor_type) ) {
18750 r=q+mp->big_node_size[type(p)];
18753 if ( type(r)!=mp_known )
18760 @ @<Declare unary action...@>=
18761 void mp_print_known_or_unknown_type (MP mp,small_number t, integer v) {
18762 mp_print_char(mp, '(');
18763 if ( t>mp_known ) mp_print(mp, "unknown numeric");
18764 else { if ( (t==mp_pair_type)||(t==mp_color_type)||(t==mp_cmykcolor_type) )
18765 if ( ! mp_nice_color_or_pair(mp, v,t) ) mp_print(mp, "unknown ");
18766 mp_print_type(mp, t);
18768 mp_print_char(mp, ')');
18771 @ @<Declare unary action...@>=
18772 void mp_bad_unary (MP mp,quarterword c) {
18773 exp_err("Not implemented: "); mp_print_op(mp, c);
18774 @.Not implemented...@>
18775 mp_print_known_or_unknown_type(mp, mp->cur_type,mp->cur_exp);
18776 help3("I'm afraid I don't know how to apply that operation to that")
18777 ("particular type. Continue, and I'll simply return the")
18778 ("argument (shown above) as the result of the operation.");
18779 mp_put_get_error(mp);
18782 @ @<Trace the current unary operation@>=
18784 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
18785 mp_print_op(mp, c); mp_print_char(mp, '(');
18786 mp_print_exp(mp, null,0); /* show the operand, but not verbosely */
18787 mp_print(mp, ")}"); mp_end_diagnostic(mp, false);
18790 @ Negation is easy except when the current expression
18791 is of type |independent|, or when it is a pair with one or more
18792 |independent| components.
18794 It is tempting to argue that the negative of an independent variable
18795 is an independent variable, hence we don't have to do anything when
18796 negating it. The fallacy is that other dependent variables pointing
18797 to the current expression must change the sign of their
18798 coefficients if we make no change to the current expression.
18800 Instead, we work around the problem by copying the current expression
18801 and recycling it afterwards (cf.~the |stash_in| routine).
18803 @<Negate the current expression@>=
18804 switch (mp->cur_type) {
18805 case mp_color_type:
18806 case mp_cmykcolor_type:
18808 case mp_independent:
18809 q=mp->cur_exp; mp_make_exp_copy(mp, q);
18810 if ( mp->cur_type==mp_dependent ) {
18811 mp_negate_dep_list(mp, dep_list(mp->cur_exp));
18812 } else if ( mp->cur_type<=mp_pair_type ) { /* |mp_color_type| or |mp_pair_type| */
18813 p=value(mp->cur_exp);
18814 r=p+mp->big_node_size[mp->cur_type];
18817 if ( type(r)==mp_known ) negate(value(r));
18818 else mp_negate_dep_list(mp, dep_list(r));
18820 } /* if |cur_type=mp_known| then |cur_exp=0| */
18821 mp_recycle_value(mp, q); mp_free_node(mp, q,value_node_size);
18824 case mp_proto_dependent:
18825 mp_negate_dep_list(mp, dep_list(mp->cur_exp));
18828 negate(mp->cur_exp);
18831 mp_bad_unary(mp, minus);
18835 @ @<Declare unary action...@>=
18836 void mp_negate_dep_list (MP mp,pointer p) {
18839 if ( info(p)==null ) return;
18844 @ @<Additional cases of unary operators@>=
18846 if ( mp->cur_type!=mp_boolean_type ) mp_bad_unary(mp, not_op);
18847 else mp->cur_exp=true_code+false_code-mp->cur_exp;
18850 @ @d three_sixty_units 23592960 /* that's |360*unity| */
18851 @d boolean_reset(A) if ( (A) ) mp->cur_exp=true_code; else mp->cur_exp=false_code
18853 @<Additional cases of unary operators@>=
18860 case uniform_deviate:
18862 case char_exists_op:
18863 if ( mp->cur_type!=mp_known ) {
18864 mp_bad_unary(mp, c);
18867 case sqrt_op:mp->cur_exp=mp_square_rt(mp, mp->cur_exp);break;
18868 case m_exp_op:mp->cur_exp=mp_m_exp(mp, mp->cur_exp);break;
18869 case m_log_op:mp->cur_exp=mp_m_log(mp, mp->cur_exp);break;
18872 mp_n_sin_cos(mp, (mp->cur_exp % three_sixty_units)*16);
18873 if ( c==sin_d_op ) mp->cur_exp=mp_round_fraction(mp, mp->n_sin);
18874 else mp->cur_exp=mp_round_fraction(mp, mp->n_cos);
18876 case floor_op:mp->cur_exp=mp_floor_scaled(mp, mp->cur_exp);break;
18877 case uniform_deviate:mp->cur_exp=mp_unif_rand(mp, mp->cur_exp);break;
18879 boolean_reset(odd(mp_round_unscaled(mp, mp->cur_exp)));
18880 mp->cur_type=mp_boolean_type;
18882 case char_exists_op:
18883 @<Determine if a character has been shipped out@>;
18885 } /* there are no other cases */
18889 @ @<Additional cases of unary operators@>=
18891 if ( mp_nice_pair(mp, mp->cur_exp,mp->cur_type) ) {
18892 p=value(mp->cur_exp);
18893 x=mp_n_arg(mp, value(x_part_loc(p)),value(y_part_loc(p)));
18894 if ( x>=0 ) mp_flush_cur_exp(mp, (x+8)/ 16);
18895 else mp_flush_cur_exp(mp, -((-x+8)/ 16));
18897 mp_bad_unary(mp, angle_op);
18901 @ If the current expression is a pair, but the context wants it to
18902 be a path, we call |pair_to_path|.
18904 @<Declare unary action...@>=
18905 void mp_pair_to_path (MP mp) {
18906 mp->cur_exp=mp_new_knot(mp);
18907 mp->cur_type=mp_path_type;
18911 @d pict_color_type(A) ((link(dummy_loc(mp->cur_exp))!=null) &&
18912 (has_color(link(dummy_loc(mp->cur_exp)))) &&
18913 ((color_model(link(dummy_loc(mp->cur_exp)))==A)
18915 ((color_model(link(dummy_loc(mp->cur_exp)))==mp_uninitialized_model) &&
18916 (mp->internal[mp_default_color_model]/unity)==(A))))
18918 @<Additional cases of unary operators@>=
18921 if ( (mp->cur_type==mp_pair_type)||(mp->cur_type==mp_transform_type) )
18922 mp_take_part(mp, c);
18923 else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
18924 else mp_bad_unary(mp, c);
18930 if ( mp->cur_type==mp_transform_type ) mp_take_part(mp, c);
18931 else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
18932 else mp_bad_unary(mp, c);
18937 if ( mp->cur_type==mp_color_type ) mp_take_part(mp, c);
18938 else if ( mp->cur_type==mp_picture_type ) {
18939 if pict_color_type(mp_rgb_model) mp_take_pict_part(mp, c);
18940 else mp_bad_color_part(mp, c);
18942 else mp_bad_unary(mp, c);
18948 if ( mp->cur_type==mp_cmykcolor_type) mp_take_part(mp, c);
18949 else if ( mp->cur_type==mp_picture_type ) {
18950 if pict_color_type(mp_cmyk_model) mp_take_pict_part(mp, c);
18951 else mp_bad_color_part(mp, c);
18953 else mp_bad_unary(mp, c);
18956 if ( mp->cur_type==mp_known ) mp->cur_exp=value(c);
18957 else if ( mp->cur_type==mp_picture_type ) {
18958 if pict_color_type(mp_grey_model) mp_take_pict_part(mp, c);
18959 else mp_bad_color_part(mp, c);
18961 else mp_bad_unary(mp, c);
18963 case color_model_part:
18964 if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
18965 else mp_bad_unary(mp, c);
18968 @ @<Declarations@>=
18969 void mp_bad_color_part(MP mp, quarterword c);
18972 void mp_bad_color_part(MP mp, quarterword c) {
18973 pointer p; /* the big node */
18974 p=link(dummy_loc(mp->cur_exp));
18975 exp_err("Wrong picture color model: "); mp_print_op(mp, c);
18976 @.Wrong picture color model...@>
18977 if (color_model(p)==mp_grey_model)
18978 mp_print(mp, " of grey object");
18979 else if (color_model(p)==mp_cmyk_model)
18980 mp_print(mp, " of cmyk object");
18981 else if (color_model(p)==mp_rgb_model)
18982 mp_print(mp, " of rgb object");
18983 else if (color_model(p)==mp_no_model)
18984 mp_print(mp, " of marking object");
18986 mp_print(mp," of defaulted object");
18987 help3("You can only ask for the redpart, greenpart, bluepart of a rgb object,")
18988 ("the cyanpart, magentapart, yellowpart or blackpart of a cmyk object, ")
18989 ("or the greypart of a grey object. No mixing and matching, please.");
18992 mp_flush_cur_exp(mp,unity);
18994 mp_flush_cur_exp(mp,0);
18997 @ In the following procedure, |cur_exp| points to a capsule, which points to
18998 a big node. We want to delete all but one part of the big node.
19000 @<Declare unary action...@>=
19001 void mp_take_part (MP mp,quarterword c) {
19002 pointer p; /* the big node */
19003 p=value(mp->cur_exp); value(temp_val)=p; type(temp_val)=mp->cur_type;
19004 link(p)=temp_val; mp_free_node(mp, mp->cur_exp,value_node_size);
19005 mp_make_exp_copy(mp, p+mp->sector_offset[c+mp_x_part_sector-x_part]);
19006 mp_recycle_value(mp, temp_val);
19009 @ @<Initialize table entries...@>=
19010 name_type(temp_val)=mp_capsule;
19012 @ @<Additional cases of unary operators@>=
19018 if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
19019 else mp_bad_unary(mp, c);
19022 @ @<Declarations@>=
19023 void mp_scale_edges (MP mp);
19025 @ @<Declare unary action...@>=
19026 void mp_take_pict_part (MP mp,quarterword c) {
19027 pointer p; /* first graphical object in |cur_exp| */
19028 p=link(dummy_loc(mp->cur_exp));
19031 case x_part: case y_part: case xx_part:
19032 case xy_part: case yx_part: case yy_part:
19033 if ( type(p)==mp_text_code ) mp_flush_cur_exp(mp, text_trans_part(p+c));
19034 else goto NOT_FOUND;
19036 case red_part: case green_part: case blue_part:
19037 if ( has_color(p) ) mp_flush_cur_exp(mp, obj_color_part(p+c));
19038 else goto NOT_FOUND;
19040 case cyan_part: case magenta_part: case yellow_part:
19042 if ( has_color(p) ) {
19043 if ( color_model(p)==mp_uninitialized_model && c==black_part)
19044 mp_flush_cur_exp(mp, unity);
19046 mp_flush_cur_exp(mp, obj_color_part(p+c+(red_part-cyan_part)));
19047 } else goto NOT_FOUND;
19050 if ( has_color(p) )
19051 mp_flush_cur_exp(mp, obj_color_part(p+c+(red_part-grey_part)));
19052 else goto NOT_FOUND;
19054 case color_model_part:
19055 if ( has_color(p) ) {
19056 if ( color_model(p)==mp_uninitialized_model )
19057 mp_flush_cur_exp(mp, mp->internal[mp_default_color_model]);
19059 mp_flush_cur_exp(mp, color_model(p)*unity);
19060 } else goto NOT_FOUND;
19062 @<Handle other cases in |take_pict_part| or |goto not_found|@>;
19063 } /* all cases have been enumerated */
19067 @<Convert the current expression to a null value appropriate
19071 @ @<Handle other cases in |take_pict_part| or |goto not_found|@>=
19073 if ( type(p)!=mp_text_code ) goto NOT_FOUND;
19075 mp_flush_cur_exp(mp, text_p(p));
19076 add_str_ref(mp->cur_exp);
19077 mp->cur_type=mp_string_type;
19081 if ( type(p)!=mp_text_code ) goto NOT_FOUND;
19083 mp_flush_cur_exp(mp, rts(mp->font_name[font_n(p)]));
19084 add_str_ref(mp->cur_exp);
19085 mp->cur_type=mp_string_type;
19089 if ( type(p)==mp_text_code ) goto NOT_FOUND;
19090 else if ( is_stop(p) ) mp_confusion(mp, "pict");
19091 @:this can't happen pict}{\quad pict@>
19093 mp_flush_cur_exp(mp, mp_copy_path(mp, path_p(p)));
19094 mp->cur_type=mp_path_type;
19098 if ( ! has_pen(p) ) goto NOT_FOUND;
19100 if ( pen_p(p)==null ) goto NOT_FOUND;
19101 else { mp_flush_cur_exp(mp, copy_pen(pen_p(p)));
19102 mp->cur_type=mp_pen_type;
19107 if ( type(p)!=mp_stroked_code ) goto NOT_FOUND;
19108 else { if ( dash_p(p)==null ) goto NOT_FOUND;
19109 else { add_edge_ref(dash_p(p));
19110 mp->se_sf=dash_scale(p);
19111 mp->se_pic=dash_p(p);
19112 mp_scale_edges(mp);
19113 mp_flush_cur_exp(mp, mp->se_pic);
19114 mp->cur_type=mp_picture_type;
19119 @ Since |scale_edges| had to be declared |forward|, it had to be declared as a
19120 parameterless procedure even though it really takes two arguments and updates
19121 one of them. Hence the following globals are needed.
19124 pointer se_pic; /* edge header used and updated by |scale_edges| */
19125 scaled se_sf; /* the scale factor argument to |scale_edges| */
19127 @ @<Convert the current expression to a null value appropriate...@>=
19129 case text_part: case font_part:
19130 mp_flush_cur_exp(mp, rts(""));
19131 mp->cur_type=mp_string_type;
19134 mp_flush_cur_exp(mp, mp_get_node(mp, knot_node_size));
19135 left_type(mp->cur_exp)=mp_endpoint;
19136 right_type(mp->cur_exp)=mp_endpoint;
19137 link(mp->cur_exp)=mp->cur_exp;
19138 x_coord(mp->cur_exp)=0;
19139 y_coord(mp->cur_exp)=0;
19140 originator(mp->cur_exp)=mp_metapost_user;
19141 mp->cur_type=mp_path_type;
19144 mp_flush_cur_exp(mp, mp_get_pen_circle(mp, 0));
19145 mp->cur_type=mp_pen_type;
19148 mp_flush_cur_exp(mp, mp_get_node(mp, edge_header_size));
19149 mp_init_edges(mp, mp->cur_exp);
19150 mp->cur_type=mp_picture_type;
19153 mp_flush_cur_exp(mp, 0);
19157 @ @<Additional cases of unary...@>=
19159 if ( mp->cur_type!=mp_known ) {
19160 mp_bad_unary(mp, char_op);
19162 mp->cur_exp=mp_round_unscaled(mp, mp->cur_exp) % 256;
19163 mp->cur_type=mp_string_type;
19164 if ( mp->cur_exp<0 ) mp->cur_exp=mp->cur_exp+256;
19168 if ( mp->cur_type!=mp_known ) {
19169 mp_bad_unary(mp, decimal);
19171 mp->old_setting=mp->selector; mp->selector=new_string;
19172 mp_print_scaled(mp, mp->cur_exp); mp->cur_exp=mp_make_string(mp);
19173 mp->selector=mp->old_setting; mp->cur_type=mp_string_type;
19179 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, c);
19180 else mp_str_to_num(mp, c);
19183 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, font_size);
19184 else @<Find the design size of the font whose name is |cur_exp|@>;
19187 @ @<Declare unary action...@>=
19188 void mp_str_to_num (MP mp,quarterword c) { /* converts a string to a number */
19189 integer n; /* accumulator */
19190 ASCII_code m; /* current character */
19191 pool_pointer k; /* index into |str_pool| */
19192 int b; /* radix of conversion */
19193 boolean bad_char; /* did the string contain an invalid digit? */
19194 if ( c==ASCII_op ) {
19195 if ( length(mp->cur_exp)==0 ) n=-1;
19196 else n=mp->str_pool[mp->str_start[mp->cur_exp]];
19198 if ( c==oct_op ) b=8; else b=16;
19199 n=0; bad_char=false;
19200 for (k=mp->str_start[mp->cur_exp];k<=str_stop(mp->cur_exp)-1;k++) {
19202 if ( (m>='0')&&(m<='9') ) m=m-'0';
19203 else if ( (m>='A')&&(m<='F') ) m=m-'A'+10;
19204 else if ( (m>='a')&&(m<='f') ) m=m-'a'+10;
19205 else { bad_char=true; m=0; };
19206 if ( m>=b ) { bad_char=true; m=0; };
19207 if ( n<32768 / b ) n=n*b+m; else n=32767;
19209 @<Give error messages if |bad_char| or |n>=4096|@>;
19211 mp_flush_cur_exp(mp, n*unity);
19214 @ @<Give error messages if |bad_char|...@>=
19216 exp_err("String contains illegal digits");
19217 @.String contains illegal digits@>
19219 help1("I zeroed out characters that weren't in the range 0..7.");
19221 help1("I zeroed out characters that weren't hex digits.");
19223 mp_put_get_error(mp);
19226 if ( mp->internal[mp_warning_check]>0 ) {
19227 print_err("Number too large (");
19228 mp_print_int(mp, n); mp_print_char(mp, ')');
19229 @.Number too large@>
19230 help2("I have trouble with numbers greater than 4095; watch out.")
19231 ("(Set warningcheck:=0 to suppress this message.)");
19232 mp_put_get_error(mp);
19236 @ The length operation is somewhat unusual in that it applies to a variety
19237 of different types of operands.
19239 @<Additional cases of unary...@>=
19241 switch (mp->cur_type) {
19242 case mp_string_type: mp_flush_cur_exp(mp, length(mp->cur_exp)*unity); break;
19243 case mp_path_type: mp_flush_cur_exp(mp, mp_path_length(mp)); break;
19244 case mp_known: mp->cur_exp=abs(mp->cur_exp); break;
19245 case mp_picture_type: mp_flush_cur_exp(mp, mp_pict_length(mp)); break;
19247 if ( mp_nice_pair(mp, mp->cur_exp,mp->cur_type) )
19248 mp_flush_cur_exp(mp, mp_pyth_add(mp,
19249 value(x_part_loc(value(mp->cur_exp))),
19250 value(y_part_loc(value(mp->cur_exp)))));
19251 else mp_bad_unary(mp, c);
19256 @ @<Declare unary action...@>=
19257 scaled mp_path_length (MP mp) { /* computes the length of the current path */
19258 scaled n; /* the path length so far */
19259 pointer p; /* traverser */
19261 if ( left_type(p)==mp_endpoint ) n=-unity; else n=0;
19262 do { p=link(p); n=n+unity; } while (p!=mp->cur_exp);
19266 @ @<Declare unary action...@>=
19267 scaled mp_pict_length (MP mp) {
19268 /* counts interior components in picture |cur_exp| */
19269 scaled n; /* the count so far */
19270 pointer p; /* traverser */
19272 p=link(dummy_loc(mp->cur_exp));
19274 if ( is_start_or_stop(p) )
19275 if ( mp_skip_1component(mp, p)==null ) p=link(p);
19276 while ( p!=null ) {
19277 skip_component(p) return n;
19284 @ Implement |turningnumber|
19286 @<Additional cases of unary...@>=
19288 if ( mp->cur_type==mp_pair_type ) mp_flush_cur_exp(mp, 0);
19289 else if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, turning_op);
19290 else if ( left_type(mp->cur_exp)==mp_endpoint )
19291 mp_flush_cur_exp(mp, 0); /* not a cyclic path */
19293 mp_flush_cur_exp(mp, mp_turn_cycles_wrapper(mp, mp->cur_exp));
19296 @ The function |an_angle| returns the value of the |angle| primitive, or $0$ if the
19297 argument is |origin|.
19299 @<Declare unary action...@>=
19300 angle mp_an_angle (MP mp,scaled xpar, scaled ypar) {
19301 if ( (! ((xpar==0) && (ypar==0))) )
19302 return mp_n_arg(mp, xpar,ypar);
19307 @ The actual turning number is (for the moment) computed in a C function
19308 that receives eight integers corresponding to the four controlling points,
19309 and returns a single angle. Besides those, we have to account for discrete
19310 moves at the actual points.
19312 @d floor(a) (a>=0 ? a : -(int)(-a))
19313 @d bezier_error (720<<20)+1
19314 @d sign(v) ((v)>0 ? 1 : ((v)<0 ? -1 : 0 ))
19316 @d out ((double)(xo>>20))
19317 @d mid ((double)(xm>>20))
19318 @d in ((double)(xi>>20))
19319 @d divisor (256*256)
19320 @d double2angle(a) (int)floor(a*256.0*256.0*16.0)
19322 @<Declare unary action...@>=
19323 angle mp_bezier_slope(MP mp, integer AX,integer AY,integer BX,integer BY,
19324 integer CX,integer CY,integer DX,integer DY);
19327 angle mp_bezier_slope(MP mp, integer AX,integer AY,integer BX,integer BY,
19328 integer CX,integer CY,integer DX,integer DY) {
19330 integer deltax,deltay;
19331 double ax,ay,bx,by,cx,cy,dx,dy;
19332 angle xi = 0, xo = 0, xm = 0;
19334 ax=AX/divisor; ay=AY/divisor;
19335 bx=BX/divisor; by=BY/divisor;
19336 cx=CX/divisor; cy=CY/divisor;
19337 dx=DX/divisor; dy=DY/divisor;
19339 deltax = (BX-AX); deltay = (BY-AY);
19340 if (deltax==0 && deltay == 0) { deltax=(CX-AX); deltay=(CY-AY); }
19341 if (deltax==0 && deltay == 0) { deltax=(DX-AX); deltay=(DY-AY); }
19342 xi = mp_an_angle(mp,deltax,deltay);
19344 deltax = (CX-BX); deltay = (CY-BY);
19345 xm = mp_an_angle(mp,deltax,deltay);
19347 deltax = (DX-CX); deltay = (DY-CY);
19348 if (deltax==0 && deltay == 0) { deltax=(DX-BX); deltay=(DY-BY); }
19349 if (deltax==0 && deltay == 0) { deltax=(DX-AX); deltay=(DY-AY); }
19350 xo = mp_an_angle(mp,deltax,deltay);
19352 a = (bx-ax)*(cy-by) - (cx-bx)*(by-ay); /* a = (bp-ap)x(cp-bp); */
19353 b = (bx-ax)*(dy-cy) - (by-ay)*(dx-cx);; /* b = (bp-ap)x(dp-cp);*/
19354 c = (cx-bx)*(dy-cy) - (dx-cx)*(cy-by); /* c = (cp-bp)x(dp-cp);*/
19356 if ((a==0)&&(c==0)) {
19357 res = (b==0 ? 0 : (out-in));
19358 print_roots("no roots (a)");
19359 } else if ((a==0)||(c==0)) {
19360 if ((sign(b) == sign(a)) || (sign(b) == sign(c))) {
19361 res = out-in; /* ? */
19364 else if (res>180.0)
19366 print_roots("no roots (b)");
19368 res = out-in; /* ? */
19369 print_roots("one root (a)");
19371 } else if ((sign(a)*sign(c))<0) {
19372 res = out-in; /* ? */
19375 else if (res>180.0)
19377 print_roots("one root (b)");
19379 if (sign(a) == sign(b)) {
19380 res = out-in; /* ? */
19383 else if (res>180.0)
19385 print_roots("no roots (d)");
19387 if ((b*b) == (4*a*c)) {
19388 res = bezier_error;
19389 print_roots("double root"); /* cusp */
19390 } else if ((b*b) < (4*a*c)) {
19391 res = out-in; /* ? */
19392 if (res<=0.0 &&res>-180.0)
19394 else if (res>=0.0 && res<180.0)
19396 print_roots("no roots (e)");
19401 else if (res>180.0)
19403 print_roots("two roots"); /* two inflections */
19407 return double2angle(res);
19411 @d p_nextnext link(link(p))
19413 @d seven_twenty_deg 05500000000 /* $720\cdot2^{20}$, represents $720^\circ$ */
19415 @<Declare unary action...@>=
19416 scaled mp_new_turn_cycles (MP mp,pointer c) {
19417 angle res,ang; /* the angles of intermediate results */
19418 scaled turns; /* the turn counter */
19419 pointer p; /* for running around the path */
19420 integer xp,yp; /* coordinates of next point */
19421 integer x,y; /* helper coordinates */
19422 angle in_angle,out_angle; /* helper angles */
19423 int old_setting; /* saved |selector| setting */
19427 old_setting = mp->selector; mp->selector=term_only;
19428 if ( mp->internal[mp_tracing_commands]>unity ) {
19429 mp_begin_diagnostic(mp);
19430 mp_print_nl(mp, "");
19431 mp_end_diagnostic(mp, false);
19434 xp = x_coord(p_next); yp = y_coord(p_next);
19435 ang = mp_bezier_slope(mp,x_coord(p), y_coord(p), right_x(p), right_y(p),
19436 left_x(p_next), left_y(p_next), xp, yp);
19437 if ( ang>seven_twenty_deg ) {
19438 print_err("Strange path");
19440 mp->selector=old_setting;
19444 if ( res > one_eighty_deg ) {
19445 res = res - three_sixty_deg;
19446 turns = turns + unity;
19448 if ( res <= -one_eighty_deg ) {
19449 res = res + three_sixty_deg;
19450 turns = turns - unity;
19452 /* incoming angle at next point */
19453 x = left_x(p_next); y = left_y(p_next);
19454 if ( (xp==x)&&(yp==y) ) { x = right_x(p); y = right_y(p); };
19455 if ( (xp==x)&&(yp==y) ) { x = x_coord(p); y = y_coord(p); };
19456 in_angle = mp_an_angle(mp, xp - x, yp - y);
19457 /* outgoing angle at next point */
19458 x = right_x(p_next); y = right_y(p_next);
19459 if ( (xp==x)&&(yp==y) ) { x = left_x(p_nextnext); y = left_y(p_nextnext); };
19460 if ( (xp==x)&&(yp==y) ) { x = x_coord(p_nextnext); y = y_coord(p_nextnext); };
19461 out_angle = mp_an_angle(mp, x - xp, y- yp);
19462 ang = (out_angle - in_angle);
19466 if ( res >= one_eighty_deg ) {
19467 res = res - three_sixty_deg;
19468 turns = turns + unity;
19470 if ( res <= -one_eighty_deg ) {
19471 res = res + three_sixty_deg;
19472 turns = turns - unity;
19477 mp->selector=old_setting;
19482 @ This code is based on Bogus\l{}av Jackowski's
19483 |emergency_turningnumber| macro, with some minor changes by Taco
19484 Hoekwater. The macro code looked more like this:
19486 vardef turning\_number primary p =
19487 ~~save res, ang, turns;
19489 ~~if length p <= 2:
19490 ~~~~if Angle ((point 0 of p) - (postcontrol 0 of p)) >= 0: 1 else: -1 fi
19492 ~~~~for t = 0 upto length p-1 :
19493 ~~~~~~angc := Angle ((point t+1 of p) - (point t of p))
19494 ~~~~~~~~- Angle ((point t of p) - (point t-1 of p));
19495 ~~~~~~if angc > 180: angc := angc - 360; fi;
19496 ~~~~~~if angc < -180: angc := angc + 360; fi;
19497 ~~~~~~res := res + angc;
19502 The general idea is to calculate only the sum of the angles of
19503 straight lines between the points, of a path, not worrying about cusps
19504 or self-intersections in the segments at all. If the segment is not
19505 well-behaved, the result is not necesarily correct. But the old code
19506 was not always correct either, and worse, it sometimes failed for
19507 well-behaved paths as well. All known bugs that were triggered by the
19508 original code no longer occur with this code, and it runs roughly 3
19509 times as fast because the algorithm is much simpler.
19511 @ It is possible to overflow the return value of the |turn_cycles|
19512 function when the path is sufficiently long and winding, but I am not
19513 going to bother testing for that. In any case, it would only return
19514 the looped result value, which is not a big problem.
19516 The macro code for the repeat loop was a bit nicer to look
19517 at than the pascal code, because it could use |point -1 of p|. In
19518 pascal, the fastest way to loop around the path is not to look
19519 backward once, but forward twice. These defines help hide the trick.
19521 @d p_to link(link(p))
19525 @<Declare unary action...@>=
19526 scaled mp_turn_cycles (MP mp,pointer c) {
19527 angle res,ang; /* the angles of intermediate results */
19528 scaled turns; /* the turn counter */
19529 pointer p; /* for running around the path */
19530 res=0; turns= 0; p=c;
19532 ang = mp_an_angle (mp, x_coord(p_to) - x_coord(p_here),
19533 y_coord(p_to) - y_coord(p_here))
19534 - mp_an_angle (mp, x_coord(p_here) - x_coord(p_from),
19535 y_coord(p_here) - y_coord(p_from));
19538 if ( res >= three_sixty_deg ) {
19539 res = res - three_sixty_deg;
19540 turns = turns + unity;
19542 if ( res <= -three_sixty_deg ) {
19543 res = res + three_sixty_deg;
19544 turns = turns - unity;
19551 @ @<Declare unary action...@>=
19552 scaled mp_turn_cycles_wrapper (MP mp,pointer c) {
19554 scaled saved_t_o; /* tracing\_online saved */
19555 if ( (link(c)==c)||(link(link(c))==c) ) {
19556 if ( mp_an_angle (mp, x_coord(c) - right_x(c), y_coord(c) - right_y(c)) > 0 )
19561 nval = mp_new_turn_cycles(mp, c);
19562 oval = mp_turn_cycles(mp, c);
19563 if ( nval!=oval ) {
19564 saved_t_o=mp->internal[mp_tracing_online];
19565 mp->internal[mp_tracing_online]=unity;
19566 mp_begin_diagnostic(mp);
19567 mp_print_nl (mp, "Warning: the turningnumber algorithms do not agree."
19568 " The current computed value is ");
19569 mp_print_scaled(mp, nval);
19570 mp_print(mp, ", but the 'connect-the-dots' algorithm returned ");
19571 mp_print_scaled(mp, oval);
19572 mp_end_diagnostic(mp, false);
19573 mp->internal[mp_tracing_online]=saved_t_o;
19579 @ @<Declare unary action...@>=
19580 scaled mp_count_turns (MP mp,pointer c) {
19581 pointer p; /* a knot in envelope spec |c| */
19582 integer t; /* total pen offset changes counted */
19585 t=t+info(p)-zero_off;
19588 return ((t / 3)*unity);
19591 @ @d type_range(A,B) {
19592 if ( (mp->cur_type>=(A)) && (mp->cur_type<=(B)) )
19593 mp_flush_cur_exp(mp, true_code);
19594 else mp_flush_cur_exp(mp, false_code);
19595 mp->cur_type=mp_boolean_type;
19598 if ( mp->cur_type==(A) ) mp_flush_cur_exp(mp, true_code);
19599 else mp_flush_cur_exp(mp, false_code);
19600 mp->cur_type=mp_boolean_type;
19603 @<Additional cases of unary operators@>=
19604 case mp_boolean_type:
19605 type_range(mp_boolean_type,mp_unknown_boolean); break;
19606 case mp_string_type:
19607 type_range(mp_string_type,mp_unknown_string); break;
19609 type_range(mp_pen_type,mp_unknown_pen); break;
19611 type_range(mp_path_type,mp_unknown_path); break;
19612 case mp_picture_type:
19613 type_range(mp_picture_type,mp_unknown_picture); break;
19614 case mp_transform_type: case mp_color_type: case mp_cmykcolor_type:
19616 type_test(c); break;
19617 case mp_numeric_type:
19618 type_range(mp_known,mp_independent); break;
19619 case known_op: case unknown_op:
19620 mp_test_known(mp, c); break;
19622 @ @<Declare unary action procedures@>=
19623 void mp_test_known (MP mp,quarterword c) {
19624 int b; /* is the current expression known? */
19625 pointer p,q; /* locations in a big node */
19627 switch (mp->cur_type) {
19628 case mp_vacuous: case mp_boolean_type: case mp_string_type:
19629 case mp_pen_type: case mp_path_type: case mp_picture_type:
19633 case mp_transform_type:
19634 case mp_color_type: case mp_cmykcolor_type: case mp_pair_type:
19635 p=value(mp->cur_exp);
19636 q=p+mp->big_node_size[mp->cur_type];
19639 if ( type(q)!=mp_known )
19648 if ( c==known_op ) mp_flush_cur_exp(mp, b);
19649 else mp_flush_cur_exp(mp, true_code+false_code-b);
19650 mp->cur_type=mp_boolean_type;
19653 @ @<Additional cases of unary operators@>=
19655 if ( mp->cur_type!=mp_path_type ) mp_flush_cur_exp(mp, false_code);
19656 else if ( left_type(mp->cur_exp)!=mp_endpoint ) mp_flush_cur_exp(mp, true_code);
19657 else mp_flush_cur_exp(mp, false_code);
19658 mp->cur_type=mp_boolean_type;
19661 @ @<Additional cases of unary operators@>=
19663 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19664 if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, arc_length);
19665 else mp_flush_cur_exp(mp, mp_get_arc_length(mp, mp->cur_exp));
19668 @ Here we use the fact that |c-filled_op+fill_code| is the desired graphical
19670 @^data structure assumptions@>
19672 @<Additional cases of unary operators@>=
19678 if ( mp->cur_type!=mp_picture_type ) mp_flush_cur_exp(mp, false_code);
19679 else if ( link(dummy_loc(mp->cur_exp))==null ) mp_flush_cur_exp(mp, false_code);
19680 else if ( type(link(dummy_loc(mp->cur_exp)))==c+mp_fill_code-filled_op )
19681 mp_flush_cur_exp(mp, true_code);
19682 else mp_flush_cur_exp(mp, false_code);
19683 mp->cur_type=mp_boolean_type;
19686 @ @<Additional cases of unary operators@>=
19688 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19689 if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, make_pen_op);
19691 mp->cur_type=mp_pen_type;
19692 mp->cur_exp=mp_make_pen(mp, mp->cur_exp,true);
19696 if ( mp->cur_type!=mp_pen_type ) mp_bad_unary(mp, make_path_op);
19698 mp->cur_type=mp_path_type;
19699 mp_make_path(mp, mp->cur_exp);
19703 if ( mp->cur_type==mp_path_type ) {
19704 p=mp_htap_ypoc(mp, mp->cur_exp);
19705 if ( right_type(p)==mp_endpoint ) p=link(p);
19706 mp_toss_knot_list(mp, mp->cur_exp); mp->cur_exp=p;
19707 } else if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19708 else mp_bad_unary(mp, reverse);
19711 @ The |pair_value| routine changes the current expression to a
19712 given ordered pair of values.
19714 @<Declare unary action procedures@>=
19715 void mp_pair_value (MP mp,scaled x, scaled y) {
19716 pointer p; /* a pair node */
19717 p=mp_get_node(mp, value_node_size);
19718 mp_flush_cur_exp(mp, p); mp->cur_type=mp_pair_type;
19719 type(p)=mp_pair_type; name_type(p)=mp_capsule; mp_init_big_node(mp, p);
19721 type(x_part_loc(p))=mp_known; value(x_part_loc(p))=x;
19722 type(y_part_loc(p))=mp_known; value(y_part_loc(p))=y;
19725 @ @<Additional cases of unary operators@>=
19727 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ll_corner_op);
19728 else mp_pair_value(mp, minx,miny);
19731 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, lr_corner_op);
19732 else mp_pair_value(mp, maxx,miny);
19735 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ul_corner_op);
19736 else mp_pair_value(mp, minx,maxy);
19739 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ur_corner_op);
19740 else mp_pair_value(mp, maxx,maxy);
19743 @ Here is a function that sets |minx|, |maxx|, |miny|, |maxy| to the bounding
19744 box of the current expression. The boolean result is |false| if the expression
19745 has the wrong type.
19747 @<Declare unary action procedures@>=
19748 boolean mp_get_cur_bbox (MP mp) {
19749 switch (mp->cur_type) {
19750 case mp_picture_type:
19751 mp_set_bbox(mp, mp->cur_exp,true);
19752 if ( minx_val(mp->cur_exp)>maxx_val(mp->cur_exp) ) {
19753 minx=0; maxx=0; miny=0; maxy=0;
19755 minx=minx_val(mp->cur_exp);
19756 maxx=maxx_val(mp->cur_exp);
19757 miny=miny_val(mp->cur_exp);
19758 maxy=maxy_val(mp->cur_exp);
19762 mp_path_bbox(mp, mp->cur_exp);
19765 mp_pen_bbox(mp, mp->cur_exp);
19773 @ @<Additional cases of unary operators@>=
19775 case close_from_op:
19776 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, c);
19777 else mp_do_read_or_close(mp,c);
19780 @ Here is a routine that interprets |cur_exp| as a file name and tries to read
19781 a line from the file or to close the file.
19783 @<Declare unary action procedures@>=
19784 void mp_do_read_or_close (MP mp,quarterword c) {
19785 readf_index n,n0; /* indices for searching |rd_fname| */
19786 @<Find the |n| where |rd_fname[n]=cur_exp|; if |cur_exp| must be inserted,
19787 call |start_read_input| and |goto found| or |not_found|@>;
19788 mp_begin_file_reading(mp);
19790 if ( mp_input_ln(mp, mp->rd_file[n] ) )
19792 mp_end_file_reading(mp);
19794 @<Record the end of file and set |cur_exp| to a dummy value@>;
19797 mp_flush_cur_exp(mp, 0); mp->cur_type=mp_vacuous;
19800 mp_flush_cur_exp(mp, 0);
19801 mp_finish_read(mp);
19804 @ Free slots in the |rd_file| and |rd_fname| arrays are marked with NULL's in
19807 @<Find the |n| where |rd_fname[n]=cur_exp|...@>=
19812 fn = str(mp->cur_exp);
19813 while (mp_xstrcmp(fn,mp->rd_fname[n])!=0) {
19816 } else if ( c==close_from_op ) {
19819 if ( n0==mp->read_files ) {
19820 if ( mp->read_files<mp->max_read_files ) {
19821 incr(mp->read_files);
19826 l = mp->max_read_files + (mp->max_read_files>>2);
19827 rd_file = xmalloc((l+1), sizeof(void *));
19828 rd_fname = xmalloc((l+1), sizeof(char *));
19829 for (k=0;k<=l;k++) {
19830 if (k<=mp->max_read_files) {
19831 rd_file[k]=mp->rd_file[k];
19832 rd_fname[k]=mp->rd_fname[k];
19838 xfree(mp->rd_file); xfree(mp->rd_fname);
19839 mp->max_read_files = l;
19840 mp->rd_file = rd_file;
19841 mp->rd_fname = rd_fname;
19845 if ( mp_start_read_input(mp,fn,n) )
19850 if ( mp->rd_fname[n]==NULL ) { n0=n; }
19852 if ( c==close_from_op ) {
19853 (mp->close_file)(mp,mp->rd_file[n]);
19858 @ @<Record the end of file and set |cur_exp| to a dummy value@>=
19859 xfree(mp->rd_fname[n]);
19860 mp->rd_fname[n]=NULL;
19861 if ( n==mp->read_files-1 ) mp->read_files=n;
19862 if ( c==close_from_op )
19864 mp_flush_cur_exp(mp, mp->eof_line);
19865 mp->cur_type=mp_string_type
19867 @ The string denoting end-of-file is a one-byte string at position zero, by definition
19870 str_number eof_line;
19875 @ Finally, we have the operations that combine a capsule~|p|
19876 with the current expression.
19878 @d binary_return { mp_finish_binary(mp, old_p, old_exp); return; }
19880 @c @<Declare binary action procedures@>
19881 void mp_finish_binary (MP mp, pointer old_p, pointer old_exp ){
19883 @<Recycle any sidestepped |independent| capsules@>;
19885 void mp_do_binary (MP mp,pointer p, quarterword c) {
19886 pointer q,r,rr; /* for list manipulation */
19887 pointer old_p,old_exp; /* capsules to recycle */
19888 integer v; /* for numeric manipulation */
19890 if ( mp->internal[mp_tracing_commands]>two ) {
19891 @<Trace the current binary operation@>;
19893 @<Sidestep |independent| cases in capsule |p|@>;
19894 @<Sidestep |independent| cases in the current expression@>;
19896 case plus: case minus:
19897 @<Add or subtract the current expression from |p|@>;
19899 @<Additional cases of binary operators@>;
19900 }; /* there are no other cases */
19901 mp_recycle_value(mp, p);
19902 mp_free_node(mp, p,value_node_size); /* |return| to avoid this */
19903 mp_finish_binary(mp, old_p, old_exp);
19906 @ @<Declare binary action...@>=
19907 void mp_bad_binary (MP mp,pointer p, quarterword c) {
19908 mp_disp_err(mp, p,"");
19909 exp_err("Not implemented: ");
19910 @.Not implemented...@>
19911 if ( c>=min_of ) mp_print_op(mp, c);
19912 mp_print_known_or_unknown_type(mp, type(p),p);
19913 if ( c>=min_of ) mp_print(mp, "of"); else mp_print_op(mp, c);
19914 mp_print_known_or_unknown_type(mp, mp->cur_type,mp->cur_exp);
19915 help3("I'm afraid I don't know how to apply that operation to that")
19916 ("combination of types. Continue, and I'll return the second")
19917 ("argument (see above) as the result of the operation.");
19918 mp_put_get_error(mp);
19920 void mp_bad_envelope_pen (MP mp) {
19921 mp_disp_err(mp, null,"");
19922 exp_err("Not implemented: envelope(elliptical pen)of(path)");
19923 @.Not implemented...@>
19924 help3("I'm afraid I don't know how to apply that operation to that")
19925 ("combination of types. Continue, and I'll return the second")
19926 ("argument (see above) as the result of the operation.");
19927 mp_put_get_error(mp);
19930 @ @<Trace the current binary operation@>=
19932 mp_begin_diagnostic(mp); mp_print_nl(mp, "{(");
19933 mp_print_exp(mp,p,0); /* show the operand, but not verbosely */
19934 mp_print_char(mp,')'); mp_print_op(mp,c); mp_print_char(mp,'(');
19935 mp_print_exp(mp,null,0); mp_print(mp,")}");
19936 mp_end_diagnostic(mp, false);
19939 @ Several of the binary operations are potentially complicated by the
19940 fact that |independent| values can sneak into capsules. For example,
19941 we've seen an instance of this difficulty in the unary operation
19942 of negation. In order to reduce the number of cases that need to be
19943 handled, we first change the two operands (if necessary)
19944 to rid them of |independent| components. The original operands are
19945 put into capsules called |old_p| and |old_exp|, which will be
19946 recycled after the binary operation has been safely carried out.
19948 @<Recycle any sidestepped |independent| capsules@>=
19949 if ( old_p!=null ) {
19950 mp_recycle_value(mp, old_p); mp_free_node(mp, old_p,value_node_size);
19952 if ( old_exp!=null ) {
19953 mp_recycle_value(mp, old_exp); mp_free_node(mp, old_exp,value_node_size);
19956 @ A big node is considered to be ``tarnished'' if it contains at least one
19957 independent component. We will define a simple function called `|tarnished|'
19958 that returns |null| if and only if its argument is not tarnished.
19960 @<Sidestep |independent| cases in capsule |p|@>=
19962 case mp_transform_type:
19963 case mp_color_type:
19964 case mp_cmykcolor_type:
19966 old_p=mp_tarnished(mp, p);
19968 case mp_independent: old_p=mp_void; break;
19969 default: old_p=null; break;
19971 if ( old_p!=null ) {
19972 q=mp_stash_cur_exp(mp); old_p=p; mp_make_exp_copy(mp, old_p);
19973 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q);
19976 @ @<Sidestep |independent| cases in the current expression@>=
19977 switch (mp->cur_type) {
19978 case mp_transform_type:
19979 case mp_color_type:
19980 case mp_cmykcolor_type:
19982 old_exp=mp_tarnished(mp, mp->cur_exp);
19984 case mp_independent:old_exp=mp_void; break;
19985 default: old_exp=null; break;
19987 if ( old_exp!=null ) {
19988 old_exp=mp->cur_exp; mp_make_exp_copy(mp, old_exp);
19991 @ @<Declare binary action...@>=
19992 pointer mp_tarnished (MP mp,pointer p) {
19993 pointer q; /* beginning of the big node */
19994 pointer r; /* current position in the big node */
19995 q=value(p); r=q+mp->big_node_size[type(p)];
19998 if ( type(r)==mp_independent ) return mp_void;
20003 @ @<Add or subtract the current expression from |p|@>=
20004 if ( (mp->cur_type<mp_color_type)||(type(p)<mp_color_type) ) {
20005 mp_bad_binary(mp, p,c);
20007 if ((mp->cur_type>mp_pair_type)&&(type(p)>mp_pair_type) ) {
20008 mp_add_or_subtract(mp, p,null,c);
20010 if ( mp->cur_type!=type(p) ) {
20011 mp_bad_binary(mp, p,c);
20013 q=value(p); r=value(mp->cur_exp);
20014 rr=r+mp->big_node_size[mp->cur_type];
20016 mp_add_or_subtract(mp, q,r,c);
20023 @ The first argument to |add_or_subtract| is the location of a value node
20024 in a capsule or pair node that will soon be recycled. The second argument
20025 is either a location within a pair or transform node of |cur_exp|,
20026 or it is null (which means that |cur_exp| itself should be the second
20027 argument). The third argument is either |plus| or |minus|.
20029 The sum or difference of the numeric quantities will replace the second
20030 operand. Arithmetic overflow may go undetected; users aren't supposed to
20031 be monkeying around with really big values.
20032 @^overflow in arithmetic@>
20034 @<Declare binary action...@>=
20035 @<Declare the procedure called |dep_finish|@>
20036 void mp_add_or_subtract (MP mp,pointer p, pointer q, quarterword c) {
20037 small_number s,t; /* operand types */
20038 pointer r; /* list traverser */
20039 integer v; /* second operand value */
20042 if ( t<mp_dependent ) v=mp->cur_exp; else v=dep_list(mp->cur_exp);
20045 if ( t<mp_dependent ) v=value(q); else v=dep_list(q);
20047 if ( t==mp_known ) {
20048 if ( c==minus ) negate(v);
20049 if ( type(p)==mp_known ) {
20050 v=mp_slow_add(mp, value(p),v);
20051 if ( q==null ) mp->cur_exp=v; else value(q)=v;
20054 @<Add a known value to the constant term of |dep_list(p)|@>;
20056 if ( c==minus ) mp_negate_dep_list(mp, v);
20057 @<Add operand |p| to the dependency list |v|@>;
20061 @ @<Add a known value to the constant term of |dep_list(p)|@>=
20063 while ( info(r)!=null ) r=link(r);
20064 value(r)=mp_slow_add(mp, value(r),v);
20066 q=mp_get_node(mp, value_node_size); mp->cur_exp=q; mp->cur_type=type(p);
20067 name_type(q)=mp_capsule;
20069 dep_list(q)=dep_list(p); type(q)=type(p);
20070 prev_dep(q)=prev_dep(p); link(prev_dep(p))=q;
20071 type(p)=mp_known; /* this will keep the recycler from collecting non-garbage */
20073 @ We prefer |dependent| lists to |mp_proto_dependent| ones, because it is
20074 nice to retain the extra accuracy of |fraction| coefficients.
20075 But we have to handle both kinds, and mixtures too.
20077 @<Add operand |p| to the dependency list |v|@>=
20078 if ( type(p)==mp_known ) {
20079 @<Add the known |value(p)| to the constant term of |v|@>;
20081 s=type(p); r=dep_list(p);
20082 if ( t==mp_dependent ) {
20083 if ( s==mp_dependent ) {
20084 if ( mp_max_coef(mp, r)+mp_max_coef(mp, v)<coef_bound )
20085 v=mp_p_plus_q(mp, v,r,mp_dependent); goto DONE;
20086 } /* |fix_needed| will necessarily be false */
20087 t=mp_proto_dependent;
20088 v=mp_p_over_v(mp, v,unity,mp_dependent,mp_proto_dependent);
20090 if ( s==mp_proto_dependent ) v=mp_p_plus_q(mp, v,r,mp_proto_dependent);
20091 else v=mp_p_plus_fq(mp, v,unity,r,mp_proto_dependent,mp_dependent);
20093 @<Output the answer, |v| (which might have become |known|)@>;
20096 @ @<Add the known |value(p)| to the constant term of |v|@>=
20098 while ( info(v)!=null ) v=link(v);
20099 value(v)=mp_slow_add(mp, value(p),value(v));
20102 @ @<Output the answer, |v| (which might have become |known|)@>=
20103 if ( q!=null ) mp_dep_finish(mp, v,q,t);
20104 else { mp->cur_type=t; mp_dep_finish(mp, v,null,t); }
20106 @ Here's the current situation: The dependency list |v| of type |t|
20107 should either be put into the current expression (if |q=null|) or
20108 into location |q| within a pair node (otherwise). The destination (|cur_exp|
20109 or |q|) formerly held a dependency list with the same
20110 final pointer as the list |v|.
20112 @<Declare the procedure called |dep_finish|@>=
20113 void mp_dep_finish (MP mp, pointer v, pointer q, small_number t) {
20114 pointer p; /* the destination */
20115 scaled vv; /* the value, if it is |known| */
20116 if ( q==null ) p=mp->cur_exp; else p=q;
20117 dep_list(p)=v; type(p)=t;
20118 if ( info(v)==null ) {
20121 mp_flush_cur_exp(mp, vv);
20123 mp_recycle_value(mp, p); type(q)=mp_known; value(q)=vv;
20125 } else if ( q==null ) {
20128 if ( mp->fix_needed ) mp_fix_dependencies(mp);
20131 @ Let's turn now to the six basic relations of comparison.
20133 @<Additional cases of binary operators@>=
20134 case less_than: case less_or_equal: case greater_than:
20135 case greater_or_equal: case equal_to: case unequal_to:
20136 check_arith; /* at this point |arith_error| should be |false|? */
20137 if ( (mp->cur_type>mp_pair_type)&&(type(p)>mp_pair_type) ) {
20138 mp_add_or_subtract(mp, p,null,minus); /* |cur_exp:=(p)-cur_exp| */
20139 } else if ( mp->cur_type!=type(p) ) {
20140 mp_bad_binary(mp, p,c); goto DONE;
20141 } else if ( mp->cur_type==mp_string_type ) {
20142 mp_flush_cur_exp(mp, mp_str_vs_str(mp, value(p),mp->cur_exp));
20143 } else if ((mp->cur_type==mp_unknown_string)||
20144 (mp->cur_type==mp_unknown_boolean) ) {
20145 @<Check if unknowns have been equated@>;
20146 } else if ( (mp->cur_type<=mp_pair_type)&&(mp->cur_type>=mp_transform_type)) {
20147 @<Reduce comparison of big nodes to comparison of scalars@>;
20148 } else if ( mp->cur_type==mp_boolean_type ) {
20149 mp_flush_cur_exp(mp, mp->cur_exp-value(p));
20151 mp_bad_binary(mp, p,c); goto DONE;
20153 @<Compare the current expression with zero@>;
20155 mp->arith_error=false; /* ignore overflow in comparisons */
20158 @ @<Compare the current expression with zero@>=
20159 if ( mp->cur_type!=mp_known ) {
20160 if ( mp->cur_type<mp_known ) {
20161 mp_disp_err(mp, p,"");
20162 help1("The quantities shown above have not been equated.")
20164 help2("Oh dear. I can\'t decide if the expression above is positive,")
20165 ("negative, or zero. So this comparison test won't be `true'.");
20167 exp_err("Unknown relation will be considered false");
20168 @.Unknown relation...@>
20169 mp_put_get_flush_error(mp, false_code);
20172 case less_than: boolean_reset(mp->cur_exp<0); break;
20173 case less_or_equal: boolean_reset(mp->cur_exp<=0); break;
20174 case greater_than: boolean_reset(mp->cur_exp>0); break;
20175 case greater_or_equal: boolean_reset(mp->cur_exp>=0); break;
20176 case equal_to: boolean_reset(mp->cur_exp==0); break;
20177 case unequal_to: boolean_reset(mp->cur_exp!=0); break;
20178 }; /* there are no other cases */
20180 mp->cur_type=mp_boolean_type
20182 @ When two unknown strings are in the same ring, we know that they are
20183 equal. Otherwise, we don't know whether they are equal or not, so we
20186 @<Check if unknowns have been equated@>=
20188 q=value(mp->cur_exp);
20189 while ( (q!=mp->cur_exp)&&(q!=p) ) q=value(q);
20190 if ( q==p ) mp_flush_cur_exp(mp, 0);
20193 @ @<Reduce comparison of big nodes to comparison of scalars@>=
20195 q=value(p); r=value(mp->cur_exp);
20196 rr=r+mp->big_node_size[mp->cur_type]-2;
20197 while (1) { mp_add_or_subtract(mp, q,r,minus);
20198 if ( type(r)!=mp_known ) break;
20199 if ( value(r)!=0 ) break;
20200 if ( r==rr ) break;
20203 mp_take_part(mp, name_type(r)+x_part-mp_x_part_sector);
20206 @ Here we use the sneaky fact that |and_op-false_code=or_op-true_code|.
20208 @<Additional cases of binary operators@>=
20211 if ( (type(p)!=mp_boolean_type)||(mp->cur_type!=mp_boolean_type) )
20212 mp_bad_binary(mp, p,c);
20213 else if ( value(p)==c+false_code-and_op ) mp->cur_exp=value(p);
20216 @ @<Additional cases of binary operators@>=
20218 if ( (mp->cur_type<mp_color_type)||(type(p)<mp_color_type) ) {
20219 mp_bad_binary(mp, p,times);
20220 } else if ( (mp->cur_type==mp_known)||(type(p)==mp_known) ) {
20221 @<Multiply when at least one operand is known@>;
20222 } else if ( (mp_nice_color_or_pair(mp, p,type(p))&&(mp->cur_type>mp_pair_type))
20223 ||(mp_nice_color_or_pair(mp, mp->cur_exp,mp->cur_type)&&
20224 (type(p)>mp_pair_type)) ) {
20225 mp_hard_times(mp, p);
20228 mp_bad_binary(mp, p,times);
20232 @ @<Multiply when at least one operand is known@>=
20234 if ( type(p)==mp_known ) {
20235 v=value(p); mp_free_node(mp, p,value_node_size);
20237 v=mp->cur_exp; mp_unstash_cur_exp(mp, p);
20239 if ( mp->cur_type==mp_known ) {
20240 mp->cur_exp=mp_take_scaled(mp, mp->cur_exp,v);
20241 } else if ( (mp->cur_type==mp_pair_type)||
20242 (mp->cur_type==mp_color_type)||
20243 (mp->cur_type==mp_cmykcolor_type) ) {
20244 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20246 p=p-2; mp_dep_mult(mp, p,v,true);
20247 } while (p!=value(mp->cur_exp));
20249 mp_dep_mult(mp, null,v,true);
20254 @ @<Declare binary action...@>=
20255 void mp_dep_mult (MP mp,pointer p, integer v, boolean v_is_scaled) {
20256 pointer q; /* the dependency list being multiplied by |v| */
20257 small_number s,t; /* its type, before and after */
20260 } else if ( type(p)!=mp_known ) {
20263 if ( v_is_scaled ) value(p)=mp_take_scaled(mp, value(p),v);
20264 else value(p)=mp_take_fraction(mp, value(p),v);
20267 t=type(q); q=dep_list(q); s=t;
20268 if ( t==mp_dependent ) if ( v_is_scaled )
20269 if (mp_ab_vs_cd(mp, mp_max_coef(mp,q),abs(v),coef_bound-1,unity)>=0 )
20270 t=mp_proto_dependent;
20271 q=mp_p_times_v(mp, q,v,s,t,v_is_scaled);
20272 mp_dep_finish(mp, q,p,t);
20275 @ Here is a routine that is similar to |times|; but it is invoked only
20276 internally, when |v| is a |fraction| whose magnitude is at most~1,
20277 and when |cur_type>=mp_color_type|.
20279 @c void mp_frac_mult (MP mp,scaled n, scaled d) {
20280 /* multiplies |cur_exp| by |n/d| */
20281 pointer p; /* a pair node */
20282 pointer old_exp; /* a capsule to recycle */
20283 fraction v; /* |n/d| */
20284 if ( mp->internal[mp_tracing_commands]>two ) {
20285 @<Trace the fraction multiplication@>;
20287 switch (mp->cur_type) {
20288 case mp_transform_type:
20289 case mp_color_type:
20290 case mp_cmykcolor_type:
20292 old_exp=mp_tarnished(mp, mp->cur_exp);
20294 case mp_independent: old_exp=mp_void; break;
20295 default: old_exp=null; break;
20297 if ( old_exp!=null ) {
20298 old_exp=mp->cur_exp; mp_make_exp_copy(mp, old_exp);
20300 v=mp_make_fraction(mp, n,d);
20301 if ( mp->cur_type==mp_known ) {
20302 mp->cur_exp=mp_take_fraction(mp, mp->cur_exp,v);
20303 } else if ( mp->cur_type<=mp_pair_type ) {
20304 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20307 mp_dep_mult(mp, p,v,false);
20308 } while (p!=value(mp->cur_exp));
20310 mp_dep_mult(mp, null,v,false);
20312 if ( old_exp!=null ) {
20313 mp_recycle_value(mp, old_exp);
20314 mp_free_node(mp, old_exp,value_node_size);
20318 @ @<Trace the fraction multiplication@>=
20320 mp_begin_diagnostic(mp);
20321 mp_print_nl(mp, "{("); mp_print_scaled(mp,n); mp_print_char(mp,'/');
20322 mp_print_scaled(mp,d); mp_print(mp,")*("); mp_print_exp(mp,null,0);
20324 mp_end_diagnostic(mp, false);
20327 @ The |hard_times| routine multiplies a nice color or pair by a dependency list.
20329 @<Declare binary action procedures@>=
20330 void mp_hard_times (MP mp,pointer p) {
20331 pointer q; /* a copy of the dependent variable |p| */
20332 pointer r; /* a component of the big node for the nice color or pair */
20333 scaled v; /* the known value for |r| */
20334 if ( type(p)<=mp_pair_type ) {
20335 q=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, p); p=q;
20336 }; /* now |cur_type=mp_pair_type| or |cur_type=mp_color_type| */
20337 r=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20342 if ( r==value(mp->cur_exp) )
20344 mp_new_dep(mp, r,mp_copy_dep_list(mp, dep_list(p)));
20345 mp_dep_mult(mp, r,v,true);
20347 mp->mem[value_loc(r)]=mp->mem[value_loc(p)];
20348 link(prev_dep(p))=r;
20349 mp_free_node(mp, p,value_node_size);
20350 mp_dep_mult(mp, r,v,true);
20353 @ @<Additional cases of binary operators@>=
20355 if ( (mp->cur_type!=mp_known)||(type(p)<mp_color_type) ) {
20356 mp_bad_binary(mp, p,over);
20358 v=mp->cur_exp; mp_unstash_cur_exp(mp, p);
20360 @<Squeal about division by zero@>;
20362 if ( mp->cur_type==mp_known ) {
20363 mp->cur_exp=mp_make_scaled(mp, mp->cur_exp,v);
20364 } else if ( mp->cur_type<=mp_pair_type ) {
20365 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20367 p=p-2; mp_dep_div(mp, p,v);
20368 } while (p!=value(mp->cur_exp));
20370 mp_dep_div(mp, null,v);
20377 @ @<Declare binary action...@>=
20378 void mp_dep_div (MP mp,pointer p, scaled v) {
20379 pointer q; /* the dependency list being divided by |v| */
20380 small_number s,t; /* its type, before and after */
20381 if ( p==null ) q=mp->cur_exp;
20382 else if ( type(p)!=mp_known ) q=p;
20383 else { value(p)=mp_make_scaled(mp, value(p),v); return; };
20384 t=type(q); q=dep_list(q); s=t;
20385 if ( t==mp_dependent )
20386 if ( mp_ab_vs_cd(mp, mp_max_coef(mp,q),unity,coef_bound-1,abs(v))>=0 )
20387 t=mp_proto_dependent;
20388 q=mp_p_over_v(mp, q,v,s,t);
20389 mp_dep_finish(mp, q,p,t);
20392 @ @<Squeal about division by zero@>=
20394 exp_err("Division by zero");
20395 @.Division by zero@>
20396 help2("You're trying to divide the quantity shown above the error")
20397 ("message by zero. I'm going to divide it by one instead.");
20398 mp_put_get_error(mp);
20401 @ @<Additional cases of binary operators@>=
20404 if ( (mp->cur_type==mp_known)&&(type(p)==mp_known) ) {
20405 if ( c==pythag_add ) mp->cur_exp=mp_pyth_add(mp, value(p),mp->cur_exp);
20406 else mp->cur_exp=mp_pyth_sub(mp, value(p),mp->cur_exp);
20407 } else mp_bad_binary(mp, p,c);
20410 @ The next few sections of the program deal with affine transformations
20411 of coordinate data.
20413 @<Additional cases of binary operators@>=
20414 case rotated_by: case slanted_by:
20415 case scaled_by: case shifted_by: case transformed_by:
20416 case x_scaled: case y_scaled: case z_scaled:
20417 if ( type(p)==mp_path_type ) {
20418 path_trans(c,p); binary_return;
20419 } else if ( type(p)==mp_pen_type ) {
20421 mp->cur_exp=mp_convex_hull(mp, mp->cur_exp);
20422 /* rounding error could destroy convexity */
20424 } else if ( (type(p)==mp_pair_type)||(type(p)==mp_transform_type) ) {
20425 mp_big_trans(mp, p,c);
20426 } else if ( type(p)==mp_picture_type ) {
20427 mp_do_edges_trans(mp, p,c); binary_return;
20429 mp_bad_binary(mp, p,c);
20433 @ Let |c| be one of the eight transform operators. The procedure call
20434 |set_up_trans(c)| first changes |cur_exp| to a transform that corresponds to
20435 |c| and the original value of |cur_exp|. (In particular, |cur_exp| doesn't
20436 change at all if |c=transformed_by|.)
20438 Then, if all components of the resulting transform are |known|, they are
20439 moved to the global variables |txx|, |txy|, |tyx|, |tyy|, |tx|, |ty|;
20440 and |cur_exp| is changed to the known value zero.
20442 @<Declare binary action...@>=
20443 void mp_set_up_trans (MP mp,quarterword c) {
20444 pointer p,q,r; /* list manipulation registers */
20445 if ( (c!=transformed_by)||(mp->cur_type!=mp_transform_type) ) {
20446 @<Put the current transform into |cur_exp|@>;
20448 @<If the current transform is entirely known, stash it in global variables;
20449 otherwise |return|@>;
20458 scaled ty; /* current transform coefficients */
20460 @ @<Put the current transform...@>=
20462 p=mp_stash_cur_exp(mp);
20463 mp->cur_exp=mp_id_transform(mp);
20464 mp->cur_type=mp_transform_type;
20465 q=value(mp->cur_exp);
20467 @<For each of the eight cases, change the relevant fields of |cur_exp|
20469 but do nothing if capsule |p| doesn't have the appropriate type@>;
20470 }; /* there are no other cases */
20471 mp_disp_err(mp, p,"Improper transformation argument");
20472 @.Improper transformation argument@>
20473 help3("The expression shown above has the wrong type,")
20474 ("so I can\'t transform anything using it.")
20475 ("Proceed, and I'll omit the transformation.");
20476 mp_put_get_error(mp);
20478 mp_recycle_value(mp, p);
20479 mp_free_node(mp, p,value_node_size);
20482 @ @<If the current transform is entirely known, ...@>=
20483 q=value(mp->cur_exp); r=q+transform_node_size;
20486 if ( type(r)!=mp_known ) return;
20488 mp->txx=value(xx_part_loc(q));
20489 mp->txy=value(xy_part_loc(q));
20490 mp->tyx=value(yx_part_loc(q));
20491 mp->tyy=value(yy_part_loc(q));
20492 mp->tx=value(x_part_loc(q));
20493 mp->ty=value(y_part_loc(q));
20494 mp_flush_cur_exp(mp, 0)
20496 @ @<For each of the eight cases...@>=
20498 if ( type(p)==mp_known )
20499 @<Install sines and cosines, then |goto done|@>;
20502 if ( type(p)>mp_pair_type ) {
20503 mp_install(mp, xy_part_loc(q),p); goto DONE;
20507 if ( type(p)>mp_pair_type ) {
20508 mp_install(mp, xx_part_loc(q),p); mp_install(mp, yy_part_loc(q),p);
20513 if ( type(p)==mp_pair_type ) {
20514 r=value(p); mp_install(mp, x_part_loc(q),x_part_loc(r));
20515 mp_install(mp, y_part_loc(q),y_part_loc(r)); goto DONE;
20519 if ( type(p)>mp_pair_type ) {
20520 mp_install(mp, xx_part_loc(q),p); goto DONE;
20524 if ( type(p)>mp_pair_type ) {
20525 mp_install(mp, yy_part_loc(q),p); goto DONE;
20529 if ( type(p)==mp_pair_type )
20530 @<Install a complex multiplier, then |goto done|@>;
20532 case transformed_by:
20536 @ @<Install sines and cosines, then |goto done|@>=
20537 { mp_n_sin_cos(mp, (value(p) % three_sixty_units)*16);
20538 value(xx_part_loc(q))=mp_round_fraction(mp, mp->n_cos);
20539 value(yx_part_loc(q))=mp_round_fraction(mp, mp->n_sin);
20540 value(xy_part_loc(q))=-value(yx_part_loc(q));
20541 value(yy_part_loc(q))=value(xx_part_loc(q));
20545 @ @<Install a complex multiplier, then |goto done|@>=
20548 mp_install(mp, xx_part_loc(q),x_part_loc(r));
20549 mp_install(mp, yy_part_loc(q),x_part_loc(r));
20550 mp_install(mp, yx_part_loc(q),y_part_loc(r));
20551 if ( type(y_part_loc(r))==mp_known ) negate(value(y_part_loc(r)));
20552 else mp_negate_dep_list(mp, dep_list(y_part_loc(r)));
20553 mp_install(mp, xy_part_loc(q),y_part_loc(r));
20557 @ Procedure |set_up_known_trans| is like |set_up_trans|, but it
20558 insists that the transformation be entirely known.
20560 @<Declare binary action...@>=
20561 void mp_set_up_known_trans (MP mp,quarterword c) {
20562 mp_set_up_trans(mp, c);
20563 if ( mp->cur_type!=mp_known ) {
20564 exp_err("Transform components aren't all known");
20565 @.Transform components...@>
20566 help3("I'm unable to apply a partially specified transformation")
20567 ("except to a fully known pair or transform.")
20568 ("Proceed, and I'll omit the transformation.");
20569 mp_put_get_flush_error(mp, 0);
20570 mp->txx=unity; mp->txy=0; mp->tyx=0; mp->tyy=unity;
20571 mp->tx=0; mp->ty=0;
20575 @ Here's a procedure that applies the transform |txx..ty| to a pair of
20576 coordinates in locations |p| and~|q|.
20578 @<Declare binary action...@>=
20579 void mp_trans (MP mp,pointer p, pointer q) {
20580 scaled v; /* the new |x| value */
20581 v=mp_take_scaled(mp, mp->mem[p].sc,mp->txx)+
20582 mp_take_scaled(mp, mp->mem[q].sc,mp->txy)+mp->tx;
20583 mp->mem[q].sc=mp_take_scaled(mp, mp->mem[p].sc,mp->tyx)+
20584 mp_take_scaled(mp, mp->mem[q].sc,mp->tyy)+mp->ty;
20588 @ The simplest transformation procedure applies a transform to all
20589 coordinates of a path. The |path_trans(c)(p)| macro applies
20590 a transformation defined by |cur_exp| and the transform operator |c|
20593 @d path_trans(A,B) { mp_set_up_known_trans(mp, (A));
20594 mp_unstash_cur_exp(mp, (B));
20595 mp_do_path_trans(mp, mp->cur_exp); }
20597 @<Declare binary action...@>=
20598 void mp_do_path_trans (MP mp,pointer p) {
20599 pointer q; /* list traverser */
20602 if ( left_type(q)!=mp_endpoint )
20603 mp_trans(mp, q+3,q+4); /* that's |left_x| and |left_y| */
20604 mp_trans(mp, q+1,q+2); /* that's |x_coord| and |y_coord| */
20605 if ( right_type(q)!=mp_endpoint )
20606 mp_trans(mp, q+5,q+6); /* that's |right_x| and |right_y| */
20607 @^data structure assumptions@>
20612 @ Transforming a pen is very similar, except that there are no |left_type|
20613 and |right_type| fields.
20615 @d pen_trans(A,B) { mp_set_up_known_trans(mp, (A));
20616 mp_unstash_cur_exp(mp, (B));
20617 mp_do_pen_trans(mp, mp->cur_exp); }
20619 @<Declare binary action...@>=
20620 void mp_do_pen_trans (MP mp,pointer p) {
20621 pointer q; /* list traverser */
20622 if ( pen_is_elliptical(p) ) {
20623 mp_trans(mp, p+3,p+4); /* that's |left_x| and |left_y| */
20624 mp_trans(mp, p+5,p+6); /* that's |right_x| and |right_y| */
20628 mp_trans(mp, q+1,q+2); /* that's |x_coord| and |y_coord| */
20629 @^data structure assumptions@>
20634 @ The next transformation procedure applies to edge structures. It will do
20635 any transformation, but the results may be substandard if the picture contains
20636 text that uses downloaded bitmap fonts. The binary action procedure is
20637 |do_edges_trans|, but we also need a function that just scales a picture.
20638 That routine is |scale_edges|. Both it and the underlying routine |edges_trans|
20639 should be thought of as procedures that update an edge structure |h|, except
20640 that they have to return a (possibly new) structure because of the need to call
20643 @<Declare binary action...@>=
20644 pointer mp_edges_trans (MP mp, pointer h) {
20645 pointer q; /* the object being transformed */
20646 pointer r,s; /* for list manipulation */
20647 scaled sx,sy; /* saved transformation parameters */
20648 scaled sqdet; /* square root of determinant for |dash_scale| */
20649 integer sgndet; /* sign of the determinant */
20650 scaled v; /* a temporary value */
20651 h=mp_private_edges(mp, h);
20652 sqdet=mp_sqrt_det(mp, mp->txx,mp->txy,mp->tyx,mp->tyy);
20653 sgndet=mp_ab_vs_cd(mp, mp->txx,mp->tyy,mp->txy,mp->tyx);
20654 if ( dash_list(h)!=null_dash ) {
20655 @<Try to transform the dash list of |h|@>;
20657 @<Make the bounding box of |h| unknown if it can't be updated properly
20658 without scanning the whole structure@>;
20659 q=link(dummy_loc(h));
20660 while ( q!=null ) {
20661 @<Transform graphical object |q|@>;
20666 void mp_do_edges_trans (MP mp,pointer p, quarterword c) {
20667 mp_set_up_known_trans(mp, c);
20668 value(p)=mp_edges_trans(mp, value(p));
20669 mp_unstash_cur_exp(mp, p);
20671 void mp_scale_edges (MP mp) {
20672 mp->txx=mp->se_sf; mp->tyy=mp->se_sf;
20673 mp->txy=0; mp->tyx=0; mp->tx=0; mp->ty=0;
20674 mp->se_pic=mp_edges_trans(mp, mp->se_pic);
20677 @ @<Try to transform the dash list of |h|@>=
20678 if ( (mp->txy!=0)||(mp->tyx!=0)||
20679 (mp->ty!=0)||(abs(mp->txx)!=abs(mp->tyy))) {
20680 mp_flush_dash_list(mp, h);
20682 if ( mp->txx<0 ) { @<Reverse the dash list of |h|@>; }
20683 @<Scale the dash list by |txx| and shift it by |tx|@>;
20684 dash_y(h)=mp_take_scaled(mp, dash_y(h),abs(mp->tyy));
20687 @ @<Reverse the dash list of |h|@>=
20690 dash_list(h)=null_dash;
20691 while ( r!=null_dash ) {
20693 v=start_x(s); start_x(s)=stop_x(s); stop_x(s)=v;
20694 link(s)=dash_list(h);
20699 @ @<Scale the dash list by |txx| and shift it by |tx|@>=
20701 while ( r!=null_dash ) {
20702 start_x(r)=mp_take_scaled(mp, start_x(r),mp->txx)+mp->tx;
20703 stop_x(r)=mp_take_scaled(mp, stop_x(r),mp->txx)+mp->tx;
20707 @ @<Make the bounding box of |h| unknown if it can't be updated properly...@>=
20708 if ( (mp->txx==0)&&(mp->tyy==0) ) {
20709 @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>;
20710 } else if ( (mp->txy!=0)||(mp->tyx!=0) ) {
20711 mp_init_bbox(mp, h);
20714 if ( minx_val(h)<=maxx_val(h) ) {
20715 @<Scale the bounding box by |txx+txy| and |tyx+tyy|; then shift by
20722 @ @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>=
20724 v=minx_val(h); minx_val(h)=miny_val(h); miny_val(h)=v;
20725 v=maxx_val(h); maxx_val(h)=maxy_val(h); maxy_val(h)=v;
20728 @ The sum ``|txx+txy|'' is whichever of |txx| or |txy| is nonzero. The other
20731 @<Scale the bounding box by |txx+txy| and |tyx+tyy|; then shift...@>=
20733 minx_val(h)=mp_take_scaled(mp, minx_val(h),mp->txx+mp->txy)+mp->tx;
20734 maxx_val(h)=mp_take_scaled(mp, maxx_val(h),mp->txx+mp->txy)+mp->tx;
20735 miny_val(h)=mp_take_scaled(mp, miny_val(h),mp->tyx+mp->tyy)+mp->ty;
20736 maxy_val(h)=mp_take_scaled(mp, maxy_val(h),mp->tyx+mp->tyy)+mp->ty;
20737 if ( mp->txx+mp->txy<0 ) {
20738 v=minx_val(h); minx_val(h)=maxx_val(h); maxx_val(h)=v;
20740 if ( mp->tyx+mp->tyy<0 ) {
20741 v=miny_val(h); miny_val(h)=maxy_val(h); maxy_val(h)=v;
20745 @ Now we ready for the main task of transforming the graphical objects in edge
20748 @<Transform graphical object |q|@>=
20750 case mp_fill_code: case mp_stroked_code:
20751 mp_do_path_trans(mp, path_p(q));
20752 @<Transform |pen_p(q)|, making sure polygonal pens stay counter-clockwise@>;
20754 case mp_start_clip_code: case mp_start_bounds_code:
20755 mp_do_path_trans(mp, path_p(q));
20759 @<Transform the compact transformation starting at |r|@>;
20761 case mp_stop_clip_code: case mp_stop_bounds_code:
20763 } /* there are no other cases */
20765 @ Note that the shift parameters |(tx,ty)| apply only to the path being stroked.
20766 The |dash_scale| has to be adjusted to scale the dash lengths in |dash_p(q)|
20767 since the \ps\ output procedures will try to compensate for the transformation
20768 we are applying to |pen_p(q)|. Since this compensation is based on the square
20769 root of the determinant, |sqdet| is the appropriate factor.
20771 @<Transform |pen_p(q)|, making sure...@>=
20772 if ( pen_p(q)!=null ) {
20773 sx=mp->tx; sy=mp->ty;
20774 mp->tx=0; mp->ty=0;
20775 mp_do_pen_trans(mp, pen_p(q));
20776 if ( ((type(q)==mp_stroked_code)&&(dash_p(q)!=null)) )
20777 dash_scale(q)=mp_take_scaled(mp, dash_scale(q),sqdet);
20778 if ( ! pen_is_elliptical(pen_p(q)) )
20780 pen_p(q)=mp_make_pen(mp, mp_copy_path(mp, pen_p(q)),true);
20781 /* this unreverses the pen */
20782 mp->tx=sx; mp->ty=sy;
20785 @ This uses the fact that transformations are stored in the order
20786 |(tx,ty,txx,txy,tyx,tyy)|.
20787 @^data structure assumptions@>
20789 @<Transform the compact transformation starting at |r|@>=
20790 mp_trans(mp, r,r+1);
20791 sx=mp->tx; sy=mp->ty;
20792 mp->tx=0; mp->ty=0;
20793 mp_trans(mp, r+2,r+4);
20794 mp_trans(mp, r+3,r+5);
20795 mp->tx=sx; mp->ty=sy
20797 @ The hard cases of transformation occur when big nodes are involved,
20798 and when some of their components are unknown.
20800 @<Declare binary action...@>=
20801 @<Declare subroutines needed by |big_trans|@>
20802 void mp_big_trans (MP mp,pointer p, quarterword c) {
20803 pointer q,r,pp,qq; /* list manipulation registers */
20804 small_number s; /* size of a big node */
20805 s=mp->big_node_size[type(p)]; q=value(p); r=q+s;
20808 if ( type(r)!=mp_known ) {
20809 @<Transform an unknown big node and |return|@>;
20812 @<Transform a known big node@>;
20813 } /* node |p| will now be recycled by |do_binary| */
20815 @ @<Transform an unknown big node and |return|@>=
20817 mp_set_up_known_trans(mp, c); mp_make_exp_copy(mp, p);
20818 r=value(mp->cur_exp);
20819 if ( mp->cur_type==mp_transform_type ) {
20820 mp_bilin1(mp, yy_part_loc(r),mp->tyy,xy_part_loc(q),mp->tyx,0);
20821 mp_bilin1(mp, yx_part_loc(r),mp->tyy,xx_part_loc(q),mp->tyx,0);
20822 mp_bilin1(mp, xy_part_loc(r),mp->txx,yy_part_loc(q),mp->txy,0);
20823 mp_bilin1(mp, xx_part_loc(r),mp->txx,yx_part_loc(q),mp->txy,0);
20825 mp_bilin1(mp, y_part_loc(r),mp->tyy,x_part_loc(q),mp->tyx,mp->ty);
20826 mp_bilin1(mp, x_part_loc(r),mp->txx,y_part_loc(q),mp->txy,mp->tx);
20830 @ Let |p| point to a two-word value field inside a big node of |cur_exp|,
20831 and let |q| point to a another value field. The |bilin1| procedure
20832 replaces |p| by $p\cdot t+q\cdot u+\delta$.
20834 @<Declare subroutines needed by |big_trans|@>=
20835 void mp_bilin1 (MP mp, pointer p, scaled t, pointer q,
20836 scaled u, scaled delta) {
20837 pointer r; /* list traverser */
20838 if ( t!=unity ) mp_dep_mult(mp, p,t,true);
20840 if ( type(q)==mp_known ) {
20841 delta+=mp_take_scaled(mp, value(q),u);
20843 @<Ensure that |type(p)=mp_proto_dependent|@>;
20844 dep_list(p)=mp_p_plus_fq(mp, dep_list(p),u,dep_list(q),
20845 mp_proto_dependent,type(q));
20848 if ( type(p)==mp_known ) {
20852 while ( info(r)!=null ) r=link(r);
20854 if ( r!=dep_list(p) ) value(r)=delta;
20855 else { mp_recycle_value(mp, p); type(p)=mp_known; value(p)=delta; };
20857 if ( mp->fix_needed ) mp_fix_dependencies(mp);
20860 @ @<Ensure that |type(p)=mp_proto_dependent|@>=
20861 if ( type(p)!=mp_proto_dependent ) {
20862 if ( type(p)==mp_known )
20863 mp_new_dep(mp, p,mp_const_dependency(mp, value(p)));
20865 dep_list(p)=mp_p_times_v(mp, dep_list(p),unity,mp_dependent,
20866 mp_proto_dependent,true);
20867 type(p)=mp_proto_dependent;
20870 @ @<Transform a known big node@>=
20871 mp_set_up_trans(mp, c);
20872 if ( mp->cur_type==mp_known ) {
20873 @<Transform known by known@>;
20875 pp=mp_stash_cur_exp(mp); qq=value(pp);
20876 mp_make_exp_copy(mp, p); r=value(mp->cur_exp);
20877 if ( mp->cur_type==mp_transform_type ) {
20878 mp_bilin2(mp, yy_part_loc(r),yy_part_loc(qq),
20879 value(xy_part_loc(q)),yx_part_loc(qq),null);
20880 mp_bilin2(mp, yx_part_loc(r),yy_part_loc(qq),
20881 value(xx_part_loc(q)),yx_part_loc(qq),null);
20882 mp_bilin2(mp, xy_part_loc(r),xx_part_loc(qq),
20883 value(yy_part_loc(q)),xy_part_loc(qq),null);
20884 mp_bilin2(mp, xx_part_loc(r),xx_part_loc(qq),
20885 value(yx_part_loc(q)),xy_part_loc(qq),null);
20887 mp_bilin2(mp, y_part_loc(r),yy_part_loc(qq),
20888 value(x_part_loc(q)),yx_part_loc(qq),y_part_loc(qq));
20889 mp_bilin2(mp, x_part_loc(r),xx_part_loc(qq),
20890 value(y_part_loc(q)),xy_part_loc(qq),x_part_loc(qq));
20891 mp_recycle_value(mp, pp); mp_free_node(mp, pp,value_node_size);
20894 @ Let |p| be a |mp_proto_dependent| value whose dependency list ends
20895 at |dep_final|. The following procedure adds |v| times another
20896 numeric quantity to~|p|.
20898 @<Declare subroutines needed by |big_trans|@>=
20899 void mp_add_mult_dep (MP mp,pointer p, scaled v, pointer r) {
20900 if ( type(r)==mp_known ) {
20901 value(mp->dep_final)+=mp_take_scaled(mp, value(r),v);
20903 dep_list(p)=mp_p_plus_fq(mp, dep_list(p),v,dep_list(r),
20904 mp_proto_dependent,type(r));
20905 if ( mp->fix_needed ) mp_fix_dependencies(mp);
20909 @ The |bilin2| procedure is something like |bilin1|, but with known
20910 and unknown quantities reversed. Parameter |p| points to a value field
20911 within the big node for |cur_exp|; and |type(p)=mp_known|. Parameters
20912 |t| and~|u| point to value fields elsewhere; so does parameter~|q|,
20913 unless it is |null| (which stands for zero). Location~|p| will be
20914 replaced by $p\cdot t+v\cdot u+q$.
20916 @<Declare subroutines needed by |big_trans|@>=
20917 void mp_bilin2 (MP mp,pointer p, pointer t, scaled v,
20918 pointer u, pointer q) {
20919 scaled vv; /* temporary storage for |value(p)| */
20920 vv=value(p); type(p)=mp_proto_dependent;
20921 mp_new_dep(mp, p,mp_const_dependency(mp, 0)); /* this sets |dep_final| */
20923 mp_add_mult_dep(mp, p,vv,t); /* |dep_final| doesn't change */
20924 if ( v!=0 ) mp_add_mult_dep(mp, p,v,u);
20925 if ( q!=null ) mp_add_mult_dep(mp, p,unity,q);
20926 if ( dep_list(p)==mp->dep_final ) {
20927 vv=value(mp->dep_final); mp_recycle_value(mp, p);
20928 type(p)=mp_known; value(p)=vv;
20932 @ @<Transform known by known@>=
20934 mp_make_exp_copy(mp, p); r=value(mp->cur_exp);
20935 if ( mp->cur_type==mp_transform_type ) {
20936 mp_bilin3(mp, yy_part_loc(r),mp->tyy,value(xy_part_loc(q)),mp->tyx,0);
20937 mp_bilin3(mp, yx_part_loc(r),mp->tyy,value(xx_part_loc(q)),mp->tyx,0);
20938 mp_bilin3(mp, xy_part_loc(r),mp->txx,value(yy_part_loc(q)),mp->txy,0);
20939 mp_bilin3(mp, xx_part_loc(r),mp->txx,value(yx_part_loc(q)),mp->txy,0);
20941 mp_bilin3(mp, y_part_loc(r),mp->tyy,value(x_part_loc(q)),mp->tyx,mp->ty);
20942 mp_bilin3(mp, x_part_loc(r),mp->txx,value(y_part_loc(q)),mp->txy,mp->tx);
20945 @ Finally, in |bilin3| everything is |known|.
20947 @<Declare subroutines needed by |big_trans|@>=
20948 void mp_bilin3 (MP mp,pointer p, scaled t,
20949 scaled v, scaled u, scaled delta) {
20951 delta+=mp_take_scaled(mp, value(p),t);
20954 if ( u!=0 ) value(p)=delta+mp_take_scaled(mp, v,u);
20955 else value(p)=delta;
20958 @ @<Additional cases of binary operators@>=
20960 if ( (mp->cur_type==mp_string_type)&&(type(p)==mp_string_type) ) mp_cat(mp, p);
20961 else mp_bad_binary(mp, p,concatenate);
20964 if ( mp_nice_pair(mp, p,type(p))&&(mp->cur_type==mp_string_type) )
20965 mp_chop_string(mp, value(p));
20966 else mp_bad_binary(mp, p,substring_of);
20969 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
20970 if ( mp_nice_pair(mp, p,type(p))&&(mp->cur_type==mp_path_type) )
20971 mp_chop_path(mp, value(p));
20972 else mp_bad_binary(mp, p,subpath_of);
20975 @ @<Declare binary action...@>=
20976 void mp_cat (MP mp,pointer p) {
20977 str_number a,b; /* the strings being concatenated */
20978 pool_pointer k; /* index into |str_pool| */
20979 a=value(p); b=mp->cur_exp; str_room(length(a)+length(b));
20980 for (k=mp->str_start[a];k<=str_stop(a)-1;k++) {
20981 append_char(mp->str_pool[k]);
20983 for (k=mp->str_start[b];k<=str_stop(b)-1;k++) {
20984 append_char(mp->str_pool[k]);
20986 mp->cur_exp=mp_make_string(mp); delete_str_ref(b);
20989 @ @<Declare binary action...@>=
20990 void mp_chop_string (MP mp,pointer p) {
20991 integer a, b; /* start and stop points */
20992 integer l; /* length of the original string */
20993 integer k; /* runs from |a| to |b| */
20994 str_number s; /* the original string */
20995 boolean reversed; /* was |a>b|? */
20996 a=mp_round_unscaled(mp, value(x_part_loc(p)));
20997 b=mp_round_unscaled(mp, value(y_part_loc(p)));
20998 if ( a<=b ) reversed=false;
20999 else { reversed=true; k=a; a=b; b=k; };
21000 s=mp->cur_exp; l=length(s);
21011 for (k=mp->str_start[s]+b-1;k>=mp->str_start[s]+a;k--) {
21012 append_char(mp->str_pool[k]);
21015 for (k=mp->str_start[s]+a;k<=mp->str_start[s]+b-1;k++) {
21016 append_char(mp->str_pool[k]);
21019 mp->cur_exp=mp_make_string(mp); delete_str_ref(s);
21022 @ @<Declare binary action...@>=
21023 void mp_chop_path (MP mp,pointer p) {
21024 pointer q; /* a knot in the original path */
21025 pointer pp,qq,rr,ss; /* link variables for copies of path nodes */
21026 scaled a,b,k,l; /* indices for chopping */
21027 boolean reversed; /* was |a>b|? */
21028 l=mp_path_length(mp); a=value(x_part_loc(p)); b=value(y_part_loc(p));
21029 if ( a<=b ) reversed=false;
21030 else { reversed=true; k=a; a=b; b=k; };
21031 @<Dispense with the cases |a<0| and/or |b>l|@>;
21033 while ( a>=unity ) {
21034 q=link(q); a=a-unity; b=b-unity;
21037 @<Construct a path from |pp| to |qq| of length zero@>;
21039 @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>;
21041 left_type(pp)=mp_endpoint; right_type(qq)=mp_endpoint; link(qq)=pp;
21042 mp_toss_knot_list(mp, mp->cur_exp);
21044 mp->cur_exp=link(mp_htap_ypoc(mp, pp)); mp_toss_knot_list(mp, pp);
21050 @ @<Dispense with the cases |a<0| and/or |b>l|@>=
21052 if ( left_type(mp->cur_exp)==mp_endpoint ) {
21053 a=0; if ( b<0 ) b=0;
21055 do { a=a+l; b=b+l; } while (a<0); /* a cycle always has length |l>0| */
21059 if ( left_type(mp->cur_exp)==mp_endpoint ) {
21060 b=l; if ( a>l ) a=l;
21068 @ @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>=
21070 pp=mp_copy_knot(mp, q); qq=pp;
21072 q=link(q); rr=qq; qq=mp_copy_knot(mp, q); link(rr)=qq; b=b-unity;
21075 ss=pp; pp=link(pp);
21076 mp_split_cubic(mp, ss,a*010000); pp=link(ss);
21077 mp_free_node(mp, ss,knot_node_size);
21079 b=mp_make_scaled(mp, b,unity-a); rr=pp;
21083 mp_split_cubic(mp, rr,(b+unity)*010000);
21084 mp_free_node(mp, qq,knot_node_size);
21089 @ @<Construct a path from |pp| to |qq| of length zero@>=
21091 if ( a>0 ) { mp_split_cubic(mp, q,a*010000); q=link(q); };
21092 pp=mp_copy_knot(mp, q); qq=pp;
21095 @ @<Additional cases of binary operators@>=
21096 case point_of: case precontrol_of: case postcontrol_of:
21097 if ( mp->cur_type==mp_pair_type )
21098 mp_pair_to_path(mp);
21099 if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_known) )
21100 mp_find_point(mp, value(p),c);
21102 mp_bad_binary(mp, p,c);
21104 case pen_offset_of:
21105 if ( (mp->cur_type==mp_pen_type)&& mp_nice_pair(mp, p,type(p)) )
21106 mp_set_up_offset(mp, value(p));
21108 mp_bad_binary(mp, p,pen_offset_of);
21110 case direction_time_of:
21111 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
21112 if ( (mp->cur_type==mp_path_type)&& mp_nice_pair(mp, p,type(p)) )
21113 mp_set_up_direction_time(mp, value(p));
21115 mp_bad_binary(mp, p,direction_time_of);
21118 if ( (type(p) != mp_pen_type) || (mp->cur_type != mp_path_type) )
21119 mp_bad_binary(mp, p,envelope_of);
21121 mp_set_up_envelope(mp, p);
21124 @ @<Declare binary action...@>=
21125 void mp_set_up_offset (MP mp,pointer p) {
21126 mp_find_offset(mp, value(x_part_loc(p)),value(y_part_loc(p)),mp->cur_exp);
21127 mp_pair_value(mp, mp->cur_x,mp->cur_y);
21129 void mp_set_up_direction_time (MP mp,pointer p) {
21130 mp_flush_cur_exp(mp, mp_find_direction_time(mp, value(x_part_loc(p)),
21131 value(y_part_loc(p)),mp->cur_exp));
21133 void mp_set_up_envelope (MP mp,pointer p) {
21134 small_number ljoin, lcap;
21136 pointer q = mp_copy_path(mp, mp->cur_exp); /* the original path */
21137 /* TODO: accept elliptical pens for straight paths */
21138 if (pen_is_elliptical(value(p))) {
21139 mp_bad_envelope_pen(mp);
21141 mp->cur_type = mp_path_type;
21144 if ( mp->internal[mp_linejoin]>unity ) ljoin=2;
21145 else if ( mp->internal[mp_linejoin]>0 ) ljoin=1;
21147 if ( mp->internal[mp_linecap]>unity ) lcap=2;
21148 else if ( mp->internal[mp_linecap]>0 ) lcap=1;
21150 if ( mp->internal[mp_miterlimit]<unity )
21153 miterlim=mp->internal[mp_miterlimit];
21154 mp->cur_exp = mp_make_envelope(mp, q, value(p), ljoin,lcap,miterlim);
21155 mp->cur_type = mp_path_type;
21158 @ @<Declare binary action...@>=
21159 void mp_find_point (MP mp,scaled v, quarterword c) {
21160 pointer p; /* the path */
21161 scaled n; /* its length */
21163 if ( left_type(p)==mp_endpoint ) n=-unity; else n=0;
21164 do { p=link(p); n=n+unity; } while (p!=mp->cur_exp);
21167 } else if ( v<0 ) {
21168 if ( left_type(p)==mp_endpoint ) v=0;
21169 else v=n-1-((-v-1) % n);
21170 } else if ( v>n ) {
21171 if ( left_type(p)==mp_endpoint ) v=n;
21175 while ( v>=unity ) { p=link(p); v=v-unity; };
21177 @<Insert a fractional node by splitting the cubic@>;
21179 @<Set the current expression to the desired path coordinates@>;
21182 @ @<Insert a fractional node...@>=
21183 { mp_split_cubic(mp, p,v*010000); p=link(p); }
21185 @ @<Set the current expression to the desired path coordinates...@>=
21188 mp_pair_value(mp, x_coord(p),y_coord(p));
21190 case precontrol_of:
21191 if ( left_type(p)==mp_endpoint ) mp_pair_value(mp, x_coord(p),y_coord(p));
21192 else mp_pair_value(mp, left_x(p),left_y(p));
21194 case postcontrol_of:
21195 if ( right_type(p)==mp_endpoint ) mp_pair_value(mp, x_coord(p),y_coord(p));
21196 else mp_pair_value(mp, right_x(p),right_y(p));
21198 } /* there are no other cases */
21200 @ @<Additional cases of binary operators@>=
21202 if ( mp->cur_type==mp_pair_type )
21203 mp_pair_to_path(mp);
21204 if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_known) )
21205 mp_flush_cur_exp(mp, mp_get_arc_time(mp, mp->cur_exp,value(p)));
21207 mp_bad_binary(mp, p,c);
21210 @ @<Additional cases of bin...@>=
21212 if ( type(p)==mp_pair_type ) {
21213 q=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, p);
21214 mp_pair_to_path(mp); p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q);
21216 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
21217 if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_path_type) ) {
21218 mp_path_intersection(mp, value(p),mp->cur_exp);
21219 mp_pair_value(mp, mp->cur_t,mp->cur_tt);
21221 mp_bad_binary(mp, p,intersect);
21225 @ @<Additional cases of bin...@>=
21227 if ( (mp->cur_type!=mp_string_type)||(type(p)!=mp_string_type))
21228 mp_bad_binary(mp, p,in_font);
21229 else { mp_do_infont(mp, p); binary_return; }
21232 @ Function |new_text_node| owns the reference count for its second argument
21233 (the text string) but not its first (the font name).
21235 @<Declare binary action...@>=
21236 void mp_do_infont (MP mp,pointer p) {
21238 q=mp_get_node(mp, edge_header_size);
21239 mp_init_edges(mp, q);
21240 link(obj_tail(q))=mp_new_text_node(mp,str(mp->cur_exp),value(p));
21241 obj_tail(q)=link(obj_tail(q));
21242 mp_free_node(mp, p,value_node_size);
21243 mp_flush_cur_exp(mp, q);
21244 mp->cur_type=mp_picture_type;
21247 @* \[40] Statements and commands.
21248 The chief executive of \MP\ is the |do_statement| routine, which
21249 contains the master switch that causes all the various pieces of \MP\
21250 to do their things, in the right order.
21252 In a sense, this is the grand climax of the program: It applies all the
21253 tools that we have worked so hard to construct. In another sense, this is
21254 the messiest part of the program: It necessarily refers to other pieces
21255 of code all over the place, so that a person can't fully understand what is
21256 going on without paging back and forth to be reminded of conventions that
21257 are defined elsewhere. We are now at the hub of the web.
21259 The structure of |do_statement| itself is quite simple. The first token
21260 of the statement is fetched using |get_x_next|. If it can be the first
21261 token of an expression, we look for an equation, an assignment, or a
21262 title. Otherwise we use a \&{case} construction to branch at high speed to
21263 the appropriate routine for various and sundry other types of commands,
21264 each of which has an ``action procedure'' that does the necessary work.
21266 The program uses the fact that
21267 $$\hbox{|min_primary_command=max_statement_command=type_name|}$$
21268 to interpret a statement that starts with, e.g., `\&{string}',
21269 as a type declaration rather than a boolean expression.
21271 @c void mp_do_statement (MP mp) { /* governs \MP's activities */
21272 mp->cur_type=mp_vacuous; mp_get_x_next(mp);
21273 if ( mp->cur_cmd>max_primary_command ) {
21274 @<Worry about bad statement@>;
21275 } else if ( mp->cur_cmd>max_statement_command ) {
21276 @<Do an equation, assignment, title, or
21277 `$\langle\,$expression$\,\rangle\,$\&{endgroup}'@>;
21279 @<Do a statement that doesn't begin with an expression@>;
21281 if ( mp->cur_cmd<semicolon )
21282 @<Flush unparsable junk that was found after the statement@>;
21286 @ @<Declarations@>=
21287 @<Declare action procedures for use by |do_statement|@>
21289 @ The only command codes |>max_primary_command| that can be present
21290 at the beginning of a statement are |semicolon| and higher; these
21291 occur when the statement is null.
21293 @<Worry about bad statement@>=
21295 if ( mp->cur_cmd<semicolon ) {
21296 print_err("A statement can't begin with `");
21297 @.A statement can't begin with x@>
21298 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod); mp_print_char(mp, '\'');
21299 help5("I was looking for the beginning of a new statement.")
21300 ("If you just proceed without changing anything, I'll ignore")
21301 ("everything up to the next `;'. Please insert a semicolon")
21302 ("now in front of anything that you don't want me to delete.")
21303 ("(See Chapter 27 of The METAFONTbook for an example.)");
21304 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
21305 mp_back_error(mp); mp_get_x_next(mp);
21309 @ The help message printed here says that everything is flushed up to
21310 a semicolon, but actually the commands |end_group| and |stop| will
21311 also terminate a statement.
21313 @<Flush unparsable junk that was found after the statement@>=
21315 print_err("Extra tokens will be flushed");
21316 @.Extra tokens will be flushed@>
21317 help6("I've just read as much of that statement as I could fathom,")
21318 ("so a semicolon should have been next. It's very puzzling...")
21319 ("but I'll try to get myself back together, by ignoring")
21320 ("everything up to the next `;'. Please insert a semicolon")
21321 ("now in front of anything that you don't want me to delete.")
21322 ("(See Chapter 27 of The METAFONTbook for an example.)");
21323 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
21324 mp_back_error(mp); mp->scanner_status=flushing;
21327 @<Decrease the string reference count...@>;
21328 } while (! end_of_statement); /* |cur_cmd=semicolon|, |end_group|, or |stop| */
21329 mp->scanner_status=normal;
21332 @ If |do_statement| ends with |cur_cmd=end_group|, we should have
21333 |cur_type=mp_vacuous| unless the statement was simply an expression;
21334 in the latter case, |cur_type| and |cur_exp| should represent that
21337 @<Do a statement that doesn't...@>=
21339 if ( mp->internal[mp_tracing_commands]>0 )
21341 switch (mp->cur_cmd ) {
21342 case type_name:mp_do_type_declaration(mp); break;
21344 if ( mp->cur_mod>var_def ) mp_make_op_def(mp);
21345 else if ( mp->cur_mod>end_def ) mp_scan_def(mp);
21347 @<Cases of |do_statement| that invoke particular commands@>;
21348 } /* there are no other cases */
21349 mp->cur_type=mp_vacuous;
21352 @ The most important statements begin with expressions.
21354 @<Do an equation, assignment, title, or...@>=
21356 mp->var_flag=assignment; mp_scan_expression(mp);
21357 if ( mp->cur_cmd<end_group ) {
21358 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21359 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21360 else if ( mp->cur_type==mp_string_type ) {@<Do a title@> ; }
21361 else if ( mp->cur_type!=mp_vacuous ){
21362 exp_err("Isolated expression");
21363 @.Isolated expression@>
21364 help3("I couldn't find an `=' or `:=' after the")
21365 ("expression that is shown above this error message,")
21366 ("so I guess I'll just ignore it and carry on.");
21367 mp_put_get_error(mp);
21369 mp_flush_cur_exp(mp, 0); mp->cur_type=mp_vacuous;
21375 if ( mp->internal[mp_tracing_titles]>0 ) {
21376 mp_print_nl(mp, ""); mp_print_str(mp, mp->cur_exp); update_terminal;
21380 @ Equations and assignments are performed by the pair of mutually recursive
21382 routines |do_equation| and |do_assignment|. These routines are called when
21383 |cur_cmd=equals| and when |cur_cmd=assignment|, respectively; the left-hand
21384 side is in |cur_type| and |cur_exp|, while the right-hand side is yet
21385 to be scanned. After the routines are finished, |cur_type| and |cur_exp|
21386 will be equal to the right-hand side (which will normally be equal
21387 to the left-hand side).
21389 @<Declare action procedures for use by |do_statement|@>=
21390 @<Declare the procedure called |try_eq|@>
21391 @<Declare the procedure called |make_eq|@>
21392 void mp_do_equation (MP mp) ;
21395 void mp_do_equation (MP mp) {
21396 pointer lhs; /* capsule for the left-hand side */
21397 pointer p; /* temporary register */
21398 lhs=mp_stash_cur_exp(mp); mp_get_x_next(mp);
21399 mp->var_flag=assignment; mp_scan_expression(mp);
21400 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21401 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21402 if ( mp->internal[mp_tracing_commands]>two )
21403 @<Trace the current equation@>;
21404 if ( mp->cur_type==mp_unknown_path ) if ( type(lhs)==mp_pair_type ) {
21405 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, lhs); lhs=p;
21406 }; /* in this case |make_eq| will change the pair to a path */
21407 mp_make_eq(mp, lhs); /* equate |lhs| to |(cur_type,cur_exp)| */
21410 @ And |do_assignment| is similar to |do_equation|:
21413 void mp_do_assignment (MP mp);
21415 @ @<Declare action procedures for use by |do_statement|@>=
21416 void mp_do_assignment (MP mp) ;
21419 void mp_do_assignment (MP mp) {
21420 pointer lhs; /* token list for the left-hand side */
21421 pointer p; /* where the left-hand value is stored */
21422 pointer q; /* temporary capsule for the right-hand value */
21423 if ( mp->cur_type!=mp_token_list ) {
21424 exp_err("Improper `:=' will be changed to `='");
21426 help2("I didn't find a variable name at the left of the `:=',")
21427 ("so I'm going to pretend that you said `=' instead.");
21428 mp_error(mp); mp_do_equation(mp);
21430 lhs=mp->cur_exp; mp->cur_type=mp_vacuous;
21431 mp_get_x_next(mp); mp->var_flag=assignment; mp_scan_expression(mp);
21432 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21433 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21434 if ( mp->internal[mp_tracing_commands]>two )
21435 @<Trace the current assignment@>;
21436 if ( info(lhs)>hash_end ) {
21437 @<Assign the current expression to an internal variable@>;
21439 @<Assign the current expression to the variable |lhs|@>;
21441 mp_flush_node_list(mp, lhs);
21445 @ @<Trace the current equation@>=
21447 mp_begin_diagnostic(mp); mp_print_nl(mp, "{("); mp_print_exp(mp,lhs,0);
21448 mp_print(mp,")=("); mp_print_exp(mp,null,0);
21449 mp_print(mp,")}"); mp_end_diagnostic(mp, false);
21452 @ @<Trace the current assignment@>=
21454 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
21455 if ( info(lhs)>hash_end )
21456 mp_print(mp, mp->int_name[info(lhs)-(hash_end)]);
21458 mp_show_token_list(mp, lhs,null,1000,0);
21459 mp_print(mp, ":="); mp_print_exp(mp, null,0);
21460 mp_print_char(mp, '}'); mp_end_diagnostic(mp, false);
21463 @ @<Assign the current expression to an internal variable@>=
21464 if ( mp->cur_type==mp_known ) {
21465 mp->internal[info(lhs)-(hash_end)]=mp->cur_exp;
21467 exp_err("Internal quantity `");
21468 @.Internal quantity...@>
21469 mp_print(mp, mp->int_name[info(lhs)-(hash_end)]);
21470 mp_print(mp, "' must receive a known value");
21471 help2("I can\'t set an internal quantity to anything but a known")
21472 ("numeric value, so I'll have to ignore this assignment.");
21473 mp_put_get_error(mp);
21476 @ @<Assign the current expression to the variable |lhs|@>=
21478 p=mp_find_variable(mp, lhs);
21480 q=mp_stash_cur_exp(mp); mp->cur_type=mp_und_type(mp, p);
21481 mp_recycle_value(mp, p);
21482 type(p)=mp->cur_type; value(p)=null; mp_make_exp_copy(mp, p);
21483 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q); mp_make_eq(mp, p);
21485 mp_obliterated(mp, lhs); mp_put_get_error(mp);
21490 @ And now we get to the nitty-gritty. The |make_eq| procedure is given
21491 a pointer to a capsule that is to be equated to the current expression.
21493 @<Declare the procedure called |make_eq|@>=
21494 void mp_make_eq (MP mp,pointer lhs) ;
21498 @c void mp_make_eq (MP mp,pointer lhs) {
21499 small_number t; /* type of the left-hand side */
21500 pointer p,q; /* pointers inside of big nodes */
21501 integer v=0; /* value of the left-hand side */
21504 if ( t<=mp_pair_type ) v=value(lhs);
21506 @<For each type |t|, make an equation and |goto done| unless |cur_type|
21507 is incompatible with~|t|@>;
21508 } /* all cases have been listed */
21509 @<Announce that the equation cannot be performed@>;
21511 check_arith; mp_recycle_value(mp, lhs);
21512 mp_free_node(mp, lhs,value_node_size);
21515 @ @<Announce that the equation cannot be performed@>=
21516 mp_disp_err(mp, lhs,"");
21517 exp_err("Equation cannot be performed (");
21518 @.Equation cannot be performed@>
21519 if ( type(lhs)<=mp_pair_type ) mp_print_type(mp, type(lhs));
21520 else mp_print(mp, "numeric");
21521 mp_print_char(mp, '=');
21522 if ( mp->cur_type<=mp_pair_type ) mp_print_type(mp, mp->cur_type);
21523 else mp_print(mp, "numeric");
21524 mp_print_char(mp, ')');
21525 help2("I'm sorry, but I don't know how to make such things equal.")
21526 ("(See the two expressions just above the error message.)");
21527 mp_put_get_error(mp)
21529 @ @<For each type |t|, make an equation and |goto done| unless...@>=
21530 case mp_boolean_type: case mp_string_type: case mp_pen_type:
21531 case mp_path_type: case mp_picture_type:
21532 if ( mp->cur_type==t+unknown_tag ) {
21533 mp_nonlinear_eq(mp, v,mp->cur_exp,false);
21534 mp_unstash_cur_exp(mp, mp->cur_exp); goto DONE;
21535 } else if ( mp->cur_type==t ) {
21536 @<Report redundant or inconsistent equation and |goto done|@>;
21539 case unknown_types:
21540 if ( mp->cur_type==t-unknown_tag ) {
21541 mp_nonlinear_eq(mp, mp->cur_exp,lhs,true); goto DONE;
21542 } else if ( mp->cur_type==t ) {
21543 mp_ring_merge(mp, lhs,mp->cur_exp); goto DONE;
21544 } else if ( mp->cur_type==mp_pair_type ) {
21545 if ( t==mp_unknown_path ) {
21546 mp_pair_to_path(mp); goto RESTART;
21550 case mp_transform_type: case mp_color_type:
21551 case mp_cmykcolor_type: case mp_pair_type:
21552 if ( mp->cur_type==t ) {
21553 @<Do multiple equations and |goto done|@>;
21556 case mp_known: case mp_dependent:
21557 case mp_proto_dependent: case mp_independent:
21558 if ( mp->cur_type>=mp_known ) {
21559 mp_try_eq(mp, lhs,null); goto DONE;
21565 @ @<Report redundant or inconsistent equation and |goto done|@>=
21567 if ( mp->cur_type<=mp_string_type ) {
21568 if ( mp->cur_type==mp_string_type ) {
21569 if ( mp_str_vs_str(mp, v,mp->cur_exp)!=0 ) {
21572 } else if ( v!=mp->cur_exp ) {
21575 @<Exclaim about a redundant equation@>; goto DONE;
21577 print_err("Redundant or inconsistent equation");
21578 @.Redundant or inconsistent equation@>
21579 help2("An equation between already-known quantities can't help.")
21580 ("But don't worry; continue and I'll just ignore it.");
21581 mp_put_get_error(mp); goto DONE;
21583 print_err("Inconsistent equation");
21584 @.Inconsistent equation@>
21585 help2("The equation I just read contradicts what was said before.")
21586 ("But don't worry; continue and I'll just ignore it.");
21587 mp_put_get_error(mp); goto DONE;
21590 @ @<Do multiple equations and |goto done|@>=
21592 p=v+mp->big_node_size[t];
21593 q=value(mp->cur_exp)+mp->big_node_size[t];
21595 p=p-2; q=q-2; mp_try_eq(mp, p,q);
21600 @ The first argument to |try_eq| is the location of a value node
21601 in a capsule that will soon be recycled. The second argument is
21602 either a location within a pair or transform node pointed to by
21603 |cur_exp|, or it is |null| (which means that |cur_exp| itself
21604 serves as the second argument). The idea is to leave |cur_exp| unchanged,
21605 but to equate the two operands.
21607 @<Declare the procedure called |try_eq|@>=
21608 void mp_try_eq (MP mp,pointer l, pointer r) ;
21611 @c void mp_try_eq (MP mp,pointer l, pointer r) {
21612 pointer p; /* dependency list for right operand minus left operand */
21613 int t; /* the type of list |p| */
21614 pointer q; /* the constant term of |p| is here */
21615 pointer pp; /* dependency list for right operand */
21616 int tt; /* the type of list |pp| */
21617 boolean copied; /* have we copied a list that ought to be recycled? */
21618 @<Remove the left operand from its container, negate it, and
21619 put it into dependency list~|p| with constant term~|q|@>;
21620 @<Add the right operand to list |p|@>;
21621 if ( info(p)==null ) {
21622 @<Deal with redundant or inconsistent equation@>;
21624 mp_linear_eq(mp, p,t);
21625 if ( r==null ) if ( mp->cur_type!=mp_known ) {
21626 if ( type(mp->cur_exp)==mp_known ) {
21627 pp=mp->cur_exp; mp->cur_exp=value(mp->cur_exp); mp->cur_type=mp_known;
21628 mp_free_node(mp, pp,value_node_size);
21634 @ @<Remove the left operand from its container, negate it, and...@>=
21636 if ( t==mp_known ) {
21637 t=mp_dependent; p=mp_const_dependency(mp, -value(l)); q=p;
21638 } else if ( t==mp_independent ) {
21639 t=mp_dependent; p=mp_single_dependency(mp, l); negate(value(p));
21642 p=dep_list(l); q=p;
21645 if ( info(q)==null ) break;
21648 link(prev_dep(l))=link(q); prev_dep(link(q))=prev_dep(l);
21652 @ @<Deal with redundant or inconsistent equation@>=
21654 if ( abs(value(p))>64 ) { /* off by .001 or more */
21655 print_err("Inconsistent equation");
21656 @.Inconsistent equation@>
21657 mp_print(mp, " (off by "); mp_print_scaled(mp, value(p));
21658 mp_print_char(mp, ')');
21659 help2("The equation I just read contradicts what was said before.")
21660 ("But don't worry; continue and I'll just ignore it.");
21661 mp_put_get_error(mp);
21662 } else if ( r==null ) {
21663 @<Exclaim about a redundant equation@>;
21665 mp_free_node(mp, p,dep_node_size);
21668 @ @<Add the right operand to list |p|@>=
21670 if ( mp->cur_type==mp_known ) {
21671 value(q)=value(q)+mp->cur_exp; goto DONE1;
21674 if ( tt==mp_independent ) pp=mp_single_dependency(mp, mp->cur_exp);
21675 else pp=dep_list(mp->cur_exp);
21678 if ( type(r)==mp_known ) {
21679 value(q)=value(q)+value(r); goto DONE1;
21682 if ( tt==mp_independent ) pp=mp_single_dependency(mp, r);
21683 else pp=dep_list(r);
21686 if ( tt!=mp_independent ) copied=false;
21687 else { copied=true; tt=mp_dependent; };
21688 @<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>;
21689 if ( copied ) mp_flush_node_list(mp, pp);
21692 @ @<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>=
21693 mp->watch_coefs=false;
21695 p=mp_p_plus_q(mp, p,pp,t);
21696 } else if ( t==mp_proto_dependent ) {
21697 p=mp_p_plus_fq(mp, p,unity,pp,mp_proto_dependent,mp_dependent);
21700 while ( info(q)!=null ) {
21701 value(q)=mp_round_fraction(mp, value(q)); q=link(q);
21703 t=mp_proto_dependent; p=mp_p_plus_q(mp, p,pp,t);
21705 mp->watch_coefs=true;
21707 @ Our next goal is to process type declarations. For this purpose it's
21708 convenient to have a procedure that scans a $\langle\,$declared
21709 variable$\,\rangle$ and returns the corresponding token list. After the
21710 following procedure has acted, the token after the declared variable
21711 will have been scanned, so it will appear in |cur_cmd|, |cur_mod|,
21714 @<Declare the function called |scan_declared_variable|@>=
21715 pointer mp_scan_declared_variable (MP mp) {
21716 pointer x; /* hash address of the variable's root */
21717 pointer h,t; /* head and tail of the token list to be returned */
21718 pointer l; /* hash address of left bracket */
21719 mp_get_symbol(mp); x=mp->cur_sym;
21720 if ( mp->cur_cmd!=tag_token ) mp_clear_symbol(mp, x,false);
21721 h=mp_get_avail(mp); info(h)=x; t=h;
21724 if ( mp->cur_sym==0 ) break;
21725 if ( mp->cur_cmd!=tag_token ) if ( mp->cur_cmd!=internal_quantity) {
21726 if ( mp->cur_cmd==left_bracket ) {
21727 @<Descend past a collective subscript@>;
21732 link(t)=mp_get_avail(mp); t=link(t); info(t)=mp->cur_sym;
21734 if ( (eq_type(x)%outer_tag)!=tag_token ) mp_clear_symbol(mp, x,false);
21735 if ( equiv(x)==null ) mp_new_root(mp, x);
21739 @ If the subscript isn't collective, we don't accept it as part of the
21742 @<Descend past a collective subscript@>=
21744 l=mp->cur_sym; mp_get_x_next(mp);
21745 if ( mp->cur_cmd!=right_bracket ) {
21746 mp_back_input(mp); mp->cur_sym=l; mp->cur_cmd=left_bracket; break;
21748 mp->cur_sym=collective_subscript;
21752 @ Type declarations are introduced by the following primitive operations.
21755 mp_primitive(mp, "numeric",type_name,mp_numeric_type);
21756 @:numeric_}{\&{numeric} primitive@>
21757 mp_primitive(mp, "string",type_name,mp_string_type);
21758 @:string_}{\&{string} primitive@>
21759 mp_primitive(mp, "boolean",type_name,mp_boolean_type);
21760 @:boolean_}{\&{boolean} primitive@>
21761 mp_primitive(mp, "path",type_name,mp_path_type);
21762 @:path_}{\&{path} primitive@>
21763 mp_primitive(mp, "pen",type_name,mp_pen_type);
21764 @:pen_}{\&{pen} primitive@>
21765 mp_primitive(mp, "picture",type_name,mp_picture_type);
21766 @:picture_}{\&{picture} primitive@>
21767 mp_primitive(mp, "transform",type_name,mp_transform_type);
21768 @:transform_}{\&{transform} primitive@>
21769 mp_primitive(mp, "color",type_name,mp_color_type);
21770 @:color_}{\&{color} primitive@>
21771 mp_primitive(mp, "rgbcolor",type_name,mp_color_type);
21772 @:color_}{\&{rgbcolor} primitive@>
21773 mp_primitive(mp, "cmykcolor",type_name,mp_cmykcolor_type);
21774 @:color_}{\&{cmykcolor} primitive@>
21775 mp_primitive(mp, "pair",type_name,mp_pair_type);
21776 @:pair_}{\&{pair} primitive@>
21778 @ @<Cases of |print_cmd...@>=
21779 case type_name: mp_print_type(mp, m); break;
21781 @ Now we are ready to handle type declarations, assuming that a
21782 |type_name| has just been scanned.
21784 @<Declare action procedures for use by |do_statement|@>=
21785 void mp_do_type_declaration (MP mp) ;
21788 void mp_do_type_declaration (MP mp) {
21789 small_number t; /* the type being declared */
21790 pointer p; /* token list for a declared variable */
21791 pointer q; /* value node for the variable */
21792 if ( mp->cur_mod>=mp_transform_type )
21795 t=mp->cur_mod+unknown_tag;
21797 p=mp_scan_declared_variable(mp);
21798 mp_flush_variable(mp, equiv(info(p)),link(p),false);
21799 q=mp_find_variable(mp, p);
21801 type(q)=t; value(q)=null;
21803 print_err("Declared variable conflicts with previous vardef");
21804 @.Declared variable conflicts...@>
21805 help2("You can't use, e.g., `numeric foo[]' after `vardef foo'.")
21806 ("Proceed, and I'll ignore the illegal redeclaration.");
21807 mp_put_get_error(mp);
21809 mp_flush_list(mp, p);
21810 if ( mp->cur_cmd<comma ) {
21811 @<Flush spurious symbols after the declared variable@>;
21813 } while (! end_of_statement);
21816 @ @<Flush spurious symbols after the declared variable@>=
21818 print_err("Illegal suffix of declared variable will be flushed");
21819 @.Illegal suffix...flushed@>
21820 help5("Variables in declarations must consist entirely of")
21821 ("names and collective subscripts, e.g., `x[]a'.")
21822 ("Are you trying to use a reserved word in a variable name?")
21823 ("I'm going to discard the junk I found here,")
21824 ("up to the next comma or the end of the declaration.");
21825 if ( mp->cur_cmd==numeric_token )
21826 mp->help_line[2]="Explicit subscripts like `x15a' aren't permitted.";
21827 mp_put_get_error(mp); mp->scanner_status=flushing;
21830 @<Decrease the string reference count...@>;
21831 } while (mp->cur_cmd<comma); /* either |end_of_statement| or |cur_cmd=comma| */
21832 mp->scanner_status=normal;
21835 @ \MP's |main_control| procedure just calls |do_statement| repeatedly
21836 until coming to the end of the user's program.
21837 Each execution of |do_statement| concludes with
21838 |cur_cmd=semicolon|, |end_group|, or |stop|.
21840 @c void mp_main_control (MP mp) {
21842 mp_do_statement(mp);
21843 if ( mp->cur_cmd==end_group ) {
21844 print_err("Extra `endgroup'");
21845 @.Extra `endgroup'@>
21846 help2("I'm not currently working on a `begingroup',")
21847 ("so I had better not try to end anything.");
21848 mp_flush_error(mp, 0);
21850 } while (mp->cur_cmd!=stop);
21852 int __attribute__((noinline))
21855 if (mp->history < mp_fatal_error_stop ) {
21856 @<Install and test the non-local jump buffer@>;
21857 mp_main_control(mp); /* come to life */
21858 mp_final_cleanup(mp); /* prepare for death */
21859 mp_close_files_and_terminate(mp);
21861 return mp->history;
21864 @ For |mp_execute|, we need to define a structure to store the
21865 redirected input and output. This structure holds the five relevant
21866 streams: the three informational output streams, the PostScript
21867 generation stream, and the input stream. These streams have many
21868 things in common, so it makes sense to give them their own structure
21871 \item{fptr} is a virtual file pointer
21872 \item{data} is the data this stream holds
21873 \item{cur} is a cursor pointing into |data|
21874 \item{size} is the allocated length of the data stream
21875 \item{used} is the actual length of the data stream
21877 There are small differences between input and output: |term_in| never
21878 uses |used|, whereas the other four never use |cur|.
21880 @<Exported types@>=
21881 typedef struct mp_stream {
21889 typedef struct mp_run_data {
21890 mp_stream term_out;
21891 mp_stream error_out;
21895 struct mp_edge_object *edges;
21898 @ We need a function to clear an output stream, this is called at the
21899 beginning of |mp_execute|. We also need one for destroying an output
21900 stream, this is called just before a stream is (re)opened.
21903 static void mp_reset_stream(mp_stream *str) {
21909 static void mp_free_stream(mp_stream *str) {
21911 mp_reset_stream(str);
21914 @ @<Declarations@>=
21915 static void mp_reset_stream(mp_stream *str);
21916 static void mp_free_stream(mp_stream *str);
21918 @ The global instance contains a pointer instead of the actual structure
21919 even though it is essentially static, because that makes it is easier to move
21923 mp_run_data run_data;
21925 @ Another type is needed: the indirection will overload some of the
21926 file pointer objects in the instance (but not all). For clarity, an
21927 indirect object is used that wraps a |FILE *|.
21930 typedef struct File {
21934 @ Here are all of the functions that need to be overloaded for |mp_execute|.
21937 static void *mplib_open_file(MP mp, const char *fname, const char *fmode, int ftype);
21938 static int mplib_get_char(void *f, mp_run_data * mplib_data);
21939 static void mplib_unget_char(void *f, mp_run_data * mplib_data, int c);
21940 static char *mplib_read_ascii_file(MP mp, void *ff, size_t * size);
21941 static void mplib_write_ascii_file(MP mp, void *ff, const char *s);
21942 static void mplib_read_binary_file(MP mp, void *ff, void **data, size_t * size);
21943 static void mplib_write_binary_file(MP mp, void *ff, void *s, size_t size);
21944 static void mplib_close_file(MP mp, void *ff);
21945 static int mplib_eof_file(MP mp, void *ff);
21946 static void mplib_flush_file(MP mp, void *ff);
21947 static void mplib_shipout_backend(MP mp, int h);
21949 @ The |xmalloc(1,1)| calls make sure the stored indirection values are unique.
21951 @d reset_stream(a) do {
21952 mp_reset_stream(&(a));
21954 ff->f = xmalloc(1,1);
21960 static void *mplib_open_file(MP mp, const char *fname, const char *fmode, int ftype)
21962 File *ff = xmalloc(1, sizeof(File));
21963 mp_run_data *run = mp_rundata(mp);
21965 if (ftype == mp_filetype_terminal) {
21966 if (fmode[0] == 'r') {
21968 ff->f = xmalloc(1,1);
21969 run->term_in.fptr = ff->f;
21972 reset_stream(run->term_out);
21974 } else if (ftype == mp_filetype_error) {
21975 reset_stream(run->error_out);
21976 } else if (ftype == mp_filetype_log) {
21977 reset_stream(run->log_out);
21978 } else if (ftype == mp_filetype_postscript) {
21979 mp_free_stream(&(run->ps_out));
21980 ff->f = xmalloc(1,1);
21981 run->ps_out.fptr = ff->f;
21984 char *f = (mp->find_file)(mp, fname, fmode, ftype);
21987 realmode[0] = *fmode;
21990 ff->f = fopen(f, realmode);
21992 if ((fmode[0] == 'r') && (ff->f == NULL)) {
22000 static int mplib_get_char(void *f, mp_run_data * run)
22003 if (f == run->term_in.fptr && run->term_in.data != NULL) {
22004 if (run->term_in.size == 0) {
22005 if (run->term_in.cur != NULL) {
22006 run->term_in.cur = NULL;
22008 xfree(run->term_in.data);
22012 run->term_in.size--;
22013 c = *(run->term_in.cur)++;
22021 static void mplib_unget_char(void *f, mp_run_data * run, int c)
22023 if (f == run->term_in.fptr && run->term_in.cur != NULL) {
22024 run->term_in.size++;
22025 run->term_in.cur--;
22032 static char *mplib_read_ascii_file(MP mp, void *ff, size_t * size)
22037 size_t len = 0, lim = 128;
22038 mp_run_data *run = mp_rundata(mp);
22039 FILE *f = ((File *) ff)->f;
22043 c = mplib_get_char(f, run);
22049 while (c != EOF && c != '\n' && c != '\r') {
22051 s = xrealloc(s, (lim + (lim >> 2)),1);
22057 c = mplib_get_char(f, run);
22060 c = mplib_get_char(f, run);
22061 if (c != EOF && c != '\n')
22062 mplib_unget_char(f, run, c);
22070 static void mp_append_string (MP mp, mp_stream *a,const char *b) {
22072 if ((a->used+l)>=a->size) {
22073 a->size += 256+(a->size)/5+l;
22074 a->data = xrealloc(a->data,a->size,1);
22076 (void)strcpy(a->data+a->used,b);
22081 static void mplib_write_ascii_file(MP mp, void *ff, const char *s)
22084 void *f = ((File *) ff)->f;
22085 mp_run_data *run = mp_rundata(mp);
22087 if (f == run->term_out.fptr) {
22088 mp_append_string(mp,&(run->term_out), s);
22089 } else if (f == run->error_out.fptr) {
22090 mp_append_string(mp,&(run->error_out), s);
22091 } else if (f == run->log_out.fptr) {
22092 mp_append_string(mp,&(run->log_out), s);
22093 } else if (f == run->ps_out.fptr) {
22094 mp_append_string(mp,&(run->ps_out), s);
22096 fprintf((FILE *) f, "%s", s);
22102 static void mplib_read_binary_file(MP mp, void *ff, void **data, size_t * size)
22107 FILE *f = ((File *) ff)->f;
22109 len = fread(*data, 1, *size, f);
22114 static void mplib_write_binary_file(MP mp, void *ff, void *s, size_t size)
22118 FILE *f = ((File *) ff)->f;
22120 fwrite(s, size, 1, f);
22124 static void mplib_close_file(MP mp, void *ff)
22127 mp_run_data *run = mp_rundata(mp);
22128 void *f = ((File *) ff)->f;
22130 if (f != run->term_out.fptr
22131 && f != run->error_out.fptr
22132 && f != run->log_out.fptr
22133 && f != run->ps_out.fptr
22134 && f != run->term_in.fptr) {
22142 static int mplib_eof_file(MP mp, void *ff)
22145 mp_run_data *run = mp_rundata(mp);
22146 FILE *f = ((File *) ff)->f;
22149 if (f == run->term_in.fptr && run->term_in.data != NULL) {
22150 return (run->term_in.size == 0);
22157 static void mplib_flush_file(MP mp, void *ff)
22164 static void mplib_shipout_backend(MP mp, int h)
22166 struct mp_edge_object *hh = mp_gr_export(mp, h);
22168 mp_run_data *run = mp_rundata(mp);
22169 if (run->edges==NULL) {
22172 struct mp_edge_object *p = run->edges;
22173 while (p->_next!=NULL) { p = p->_next; }
22180 @ This is where we fill them all in.
22181 @<Prepare function pointers for non-interactive use@>=
22183 mp->open_file = mplib_open_file;
22184 mp->close_file = mplib_close_file;
22185 mp->eof_file = mplib_eof_file;
22186 mp->flush_file = mplib_flush_file;
22187 mp->write_ascii_file = mplib_write_ascii_file;
22188 mp->read_ascii_file = mplib_read_ascii_file;
22189 mp->write_binary_file = mplib_write_binary_file;
22190 mp->read_binary_file = mplib_read_binary_file;
22191 mp->shipout_backend = mplib_shipout_backend;
22194 @ Perhaps this is the most important API function in the library.
22196 @<Exported function ...@>=
22197 mp_run_data *mp_rundata (MP mp) ;
22200 mp_run_data *mp_rundata (MP mp) {
22201 return &(mp->run_data);
22205 mp_free_stream(&(mp->run_data.term_in));
22206 mp_free_stream(&(mp->run_data.term_out));
22207 mp_free_stream(&(mp->run_data.log_out));
22208 mp_free_stream(&(mp->run_data.error_out));
22209 mp_free_stream(&(mp->run_data.ps_out));
22211 @ @<Finish non-interactive use@>=
22212 xfree(mp->term_out);
22213 xfree(mp->term_in);
22214 xfree(mp->err_out);
22216 @ @<Start non-interactive work@>=
22217 @<Initialize the output routines@>;
22218 mp->input_ptr=0; mp->max_in_stack=0;
22219 mp->in_open=0; mp->open_parens=0; mp->max_buf_stack=0;
22220 mp->param_ptr=0; mp->max_param_stack=0;
22221 start = iindex = loc = mp->first = 0;
22222 line=0; name=is_term;
22223 mp->mpx_name[0]=absent;
22224 mp->force_eof=false;
22226 mp->scanner_status=normal;
22227 if (mp->mem_ident==NULL) {
22228 if ( ! mp_load_mem_file(mp) ) {
22229 (mp->close_file)(mp, mp->mem_file);
22230 mp->history = mp_fatal_error_stop;
22231 return mp->history;
22233 (mp->close_file)(mp, mp->mem_file);
22235 mp_fix_date_and_time(mp);
22236 if (mp->random_seed==0)
22237 mp->random_seed = (mp->internal[mp_time] / unity)+mp->internal[mp_day];
22238 mp_init_randoms(mp, mp->random_seed);
22239 @<Initialize the print |selector|...@>;
22240 mp_open_log_file(mp);
22242 mp_init_map_file(mp, mp->troff_mode);
22243 mp->history=mp_spotless; /* ready to go! */
22244 if (mp->troff_mode) {
22245 mp->internal[mp_gtroffmode]=unity;
22246 mp->internal[mp_prologues]=unity;
22248 if ( mp->start_sym>0 ) { /* insert the `\&{everyjob}' symbol */
22249 mp->cur_sym=mp->start_sym; mp_back_input(mp);
22253 int __attribute__((noinline))
22254 mp_execute (MP mp, char *s, size_t l) {
22256 mp_reset_stream(&(mp->run_data.term_out));
22257 mp_reset_stream(&(mp->run_data.log_out));
22258 mp_reset_stream(&(mp->run_data.error_out));
22259 mp_reset_stream(&(mp->run_data.ps_out));
22260 if (mp->finished) {
22261 return mp->history;
22262 } else if (!mp->noninteractive) {
22263 mp->history = mp_fatal_error_stop ;
22264 return mp->history;
22266 if (mp->history < mp_fatal_error_stop ) {
22267 mp->jump_buf = &buf;
22268 if (setjmp(*(mp->jump_buf)) != 0) {
22269 return mp->history;
22271 if (s==NULL) { /* this signals EOF */
22272 mp_final_cleanup(mp); /* prepare for death */
22273 mp_close_files_and_terminate(mp);
22274 return mp->history;
22277 mp->term_offset=0; mp->file_offset=0;
22278 /* Perhaps some sort of warning here when |data| is not
22279 * yet exhausted would be nice ... this happens after errors
22281 if (mp->run_data.term_in.data)
22282 xfree(mp->run_data.term_in.data);
22283 mp->run_data.term_in.data = xstrdup(s);
22284 mp->run_data.term_in.cur = mp->run_data.term_in.data;
22285 mp->run_data.term_in.size = l;
22286 if (mp->run_state == 0) {
22287 mp->selector=term_only;
22288 @<Start non-interactive work@>;
22291 mp_input_ln(mp,mp->term_in);
22292 mp_firm_up_the_line(mp);
22293 mp->buffer[limit]='%';
22297 mp_do_statement(mp);
22298 } while (mp->cur_cmd!=stop);
22299 mp_final_cleanup(mp);
22300 mp_close_files_and_terminate(mp);
22302 return mp->history;
22305 @ This function cleans up
22307 int __attribute__((noinline))
22308 mp_finish (MP mp) {
22309 int history = mp->history;
22310 if (!mp->finished) {
22311 if (mp->history < mp_fatal_error_stop ) {
22313 mp->jump_buf = &buf;
22314 if (setjmp(*(mp->jump_buf)) != 0) {
22315 history = mp->history;
22316 mp_close_files_and_terminate(mp);
22319 mp_final_cleanup(mp); /* prepare for death */
22320 mp_close_files_and_terminate(mp);
22328 @ People may want to know the library version
22330 const char * mp_metapost_version (void) {
22331 return metapost_version;
22334 @ @<Exported function headers@>=
22335 int mp_run (MP mp);
22336 int mp_execute (MP mp, char *s, size_t l);
22337 int mp_finish (MP mp);
22338 const char * mp_metapost_version (void);
22341 mp_primitive(mp, "end",stop,0);
22342 @:end_}{\&{end} primitive@>
22343 mp_primitive(mp, "dump",stop,1);
22344 @:dump_}{\&{dump} primitive@>
22346 @ @<Cases of |print_cmd...@>=
22348 if ( m==0 ) mp_print(mp, "end");
22349 else mp_print(mp, "dump");
22353 Let's turn now to statements that are classified as ``commands'' because
22354 of their imperative nature. We'll begin with simple ones, so that it
22355 will be clear how to hook command processing into the |do_statement| routine;
22356 then we'll tackle the tougher commands.
22358 Here's one of the simplest:
22360 @<Cases of |do_statement|...@>=
22361 case mp_random_seed: mp_do_random_seed(mp); break;
22363 @ @<Declare action procedures for use by |do_statement|@>=
22364 void mp_do_random_seed (MP mp) ;
22366 @ @c void mp_do_random_seed (MP mp) {
22368 if ( mp->cur_cmd!=assignment ) {
22369 mp_missing_err(mp, ":=");
22371 help1("Always say `randomseed:=<numeric expression>'.");
22374 mp_get_x_next(mp); mp_scan_expression(mp);
22375 if ( mp->cur_type!=mp_known ) {
22376 exp_err("Unknown value will be ignored");
22377 @.Unknown value...ignored@>
22378 help2("Your expression was too random for me to handle,")
22379 ("so I won't change the random seed just now.");
22380 mp_put_get_flush_error(mp, 0);
22382 @<Initialize the random seed to |cur_exp|@>;
22386 @ @<Initialize the random seed to |cur_exp|@>=
22388 mp_init_randoms(mp, mp->cur_exp);
22389 if ( mp->selector>=log_only && mp->selector<write_file) {
22390 mp->old_setting=mp->selector; mp->selector=log_only;
22391 mp_print_nl(mp, "{randomseed:=");
22392 mp_print_scaled(mp, mp->cur_exp);
22393 mp_print_char(mp, '}');
22394 mp_print_nl(mp, ""); mp->selector=mp->old_setting;
22398 @ And here's another simple one (somewhat different in flavor):
22400 @<Cases of |do_statement|...@>=
22402 mp_print_ln(mp); mp->interaction=mp->cur_mod;
22403 @<Initialize the print |selector| based on |interaction|@>;
22404 if ( mp->log_opened ) mp->selector=mp->selector+2;
22409 mp_primitive(mp, "batchmode",mode_command,mp_batch_mode);
22410 @:mp_batch_mode_}{\&{batchmode} primitive@>
22411 mp_primitive(mp, "nonstopmode",mode_command,mp_nonstop_mode);
22412 @:mp_nonstop_mode_}{\&{nonstopmode} primitive@>
22413 mp_primitive(mp, "scrollmode",mode_command,mp_scroll_mode);
22414 @:mp_scroll_mode_}{\&{scrollmode} primitive@>
22415 mp_primitive(mp, "errorstopmode",mode_command,mp_error_stop_mode);
22416 @:mp_error_stop_mode_}{\&{errorstopmode} primitive@>
22418 @ @<Cases of |print_cmd_mod|...@>=
22421 case mp_batch_mode: mp_print(mp, "batchmode"); break;
22422 case mp_nonstop_mode: mp_print(mp, "nonstopmode"); break;
22423 case mp_scroll_mode: mp_print(mp, "scrollmode"); break;
22424 default: mp_print(mp, "errorstopmode"); break;
22428 @ The `\&{inner}' and `\&{outer}' commands are only slightly harder.
22430 @<Cases of |do_statement|...@>=
22431 case protection_command: mp_do_protection(mp); break;
22434 mp_primitive(mp, "inner",protection_command,0);
22435 @:inner_}{\&{inner} primitive@>
22436 mp_primitive(mp, "outer",protection_command,1);
22437 @:outer_}{\&{outer} primitive@>
22439 @ @<Cases of |print_cmd...@>=
22440 case protection_command:
22441 if ( m==0 ) mp_print(mp, "inner");
22442 else mp_print(mp, "outer");
22445 @ @<Declare action procedures for use by |do_statement|@>=
22446 void mp_do_protection (MP mp) ;
22448 @ @c void mp_do_protection (MP mp) {
22449 int m; /* 0 to unprotect, 1 to protect */
22450 halfword t; /* the |eq_type| before we change it */
22453 mp_get_symbol(mp); t=eq_type(mp->cur_sym);
22455 if ( t>=outer_tag )
22456 eq_type(mp->cur_sym)=t-outer_tag;
22457 } else if ( t<outer_tag ) {
22458 eq_type(mp->cur_sym)=t+outer_tag;
22461 } while (mp->cur_cmd==comma);
22464 @ \MP\ never defines the tokens `\.(' and `\.)' to be primitives, but
22465 plain \MP\ begins with the declaration `\&{delimiters} \.{()}'. Such a
22466 declaration assigns the command code |left_delimiter| to `\.{(}' and
22467 |right_delimiter| to `\.{)}'; the |equiv| of each delimiter is the
22468 hash address of its mate.
22470 @<Cases of |do_statement|...@>=
22471 case delimiters: mp_def_delims(mp); break;
22473 @ @<Declare action procedures for use by |do_statement|@>=
22474 void mp_def_delims (MP mp) ;
22476 @ @c void mp_def_delims (MP mp) {
22477 pointer l_delim,r_delim; /* the new delimiter pair */
22478 mp_get_clear_symbol(mp); l_delim=mp->cur_sym;
22479 mp_get_clear_symbol(mp); r_delim=mp->cur_sym;
22480 eq_type(l_delim)=left_delimiter; equiv(l_delim)=r_delim;
22481 eq_type(r_delim)=right_delimiter; equiv(r_delim)=l_delim;
22485 @ Here is a procedure that is called when \MP\ has reached a point
22486 where some right delimiter is mandatory.
22488 @<Declare the procedure called |check_delimiter|@>=
22489 void mp_check_delimiter (MP mp,pointer l_delim, pointer r_delim) {
22490 if ( mp->cur_cmd==right_delimiter )
22491 if ( mp->cur_mod==l_delim )
22493 if ( mp->cur_sym!=r_delim ) {
22494 mp_missing_err(mp, str(text(r_delim)));
22496 help2("I found no right delimiter to match a left one. So I've")
22497 ("put one in, behind the scenes; this may fix the problem.");
22500 print_err("The token `"); mp_print_text(r_delim);
22501 @.The token...delimiter@>
22502 mp_print(mp, "' is no longer a right delimiter");
22503 help3("Strange: This token has lost its former meaning!")
22504 ("I'll read it as a right delimiter this time;")
22505 ("but watch out, I'll probably miss it later.");
22510 @ The next four commands save or change the values associated with tokens.
22512 @<Cases of |do_statement|...@>=
22515 mp_get_symbol(mp); mp_save_variable(mp, mp->cur_sym); mp_get_x_next(mp);
22516 } while (mp->cur_cmd==comma);
22518 case interim_command: mp_do_interim(mp); break;
22519 case let_command: mp_do_let(mp); break;
22520 case new_internal: mp_do_new_internal(mp); break;
22522 @ @<Declare action procedures for use by |do_statement|@>=
22523 void mp_do_statement (MP mp);
22524 void mp_do_interim (MP mp);
22526 @ @c void mp_do_interim (MP mp) {
22528 if ( mp->cur_cmd!=internal_quantity ) {
22529 print_err("The token `");
22530 @.The token...quantity@>
22531 if ( mp->cur_sym==0 ) mp_print(mp, "(%CAPSULE)");
22532 else mp_print_text(mp->cur_sym);
22533 mp_print(mp, "' isn't an internal quantity");
22534 help1("Something like `tracingonline' should follow `interim'.");
22537 mp_save_internal(mp, mp->cur_mod); mp_back_input(mp);
22539 mp_do_statement(mp);
22542 @ The following procedure is careful not to undefine the left-hand symbol
22543 too soon, lest commands like `{\tt let x=x}' have a surprising effect.
22545 @<Declare action procedures for use by |do_statement|@>=
22546 void mp_do_let (MP mp) ;
22548 @ @c void mp_do_let (MP mp) {
22549 pointer l; /* hash location of the left-hand symbol */
22550 mp_get_symbol(mp); l=mp->cur_sym; mp_get_x_next(mp);
22551 if ( mp->cur_cmd!=equals ) if ( mp->cur_cmd!=assignment ) {
22552 mp_missing_err(mp, "=");
22554 help3("You should have said `let symbol = something'.")
22555 ("But don't worry; I'll pretend that an equals sign")
22556 ("was present. The next token I read will be `something'.");
22560 switch (mp->cur_cmd) {
22561 case defined_macro: case secondary_primary_macro:
22562 case tertiary_secondary_macro: case expression_tertiary_macro:
22563 add_mac_ref(mp->cur_mod);
22568 mp_clear_symbol(mp, l,false); eq_type(l)=mp->cur_cmd;
22569 if ( mp->cur_cmd==tag_token ) equiv(l)=null;
22570 else equiv(l)=mp->cur_mod;
22574 @ @<Declarations@>=
22575 void mp_grow_internals (MP mp, int l);
22576 void mp_do_new_internal (MP mp) ;
22579 void mp_grow_internals (MP mp, int l) {
22583 if ( hash_end+l>max_halfword ) {
22584 mp_confusion(mp, "out of memory space"); /* can't be reached */
22586 int_name = xmalloc ((l+1),sizeof(char *));
22587 internal = xmalloc ((l+1),sizeof(scaled));
22588 for (k=0;k<=l; k++ ) {
22589 if (k<=mp->max_internal) {
22590 internal[k]=mp->internal[k];
22591 int_name[k]=mp->int_name[k];
22597 xfree(mp->internal); xfree(mp->int_name);
22598 mp->int_name = int_name;
22599 mp->internal = internal;
22600 mp->max_internal = l;
22604 void mp_do_new_internal (MP mp) {
22606 if ( mp->int_ptr==mp->max_internal ) {
22607 mp_grow_internals(mp, (mp->max_internal + (mp->max_internal>>2)));
22609 mp_get_clear_symbol(mp); incr(mp->int_ptr);
22610 eq_type(mp->cur_sym)=internal_quantity;
22611 equiv(mp->cur_sym)=mp->int_ptr;
22612 if(mp->int_name[mp->int_ptr]!=NULL)
22613 xfree(mp->int_name[mp->int_ptr]);
22614 mp->int_name[mp->int_ptr]=str(text(mp->cur_sym));
22615 mp->internal[mp->int_ptr]=0;
22617 } while (mp->cur_cmd==comma);
22620 @ @<Dealloc variables@>=
22621 for (k=0;k<=mp->max_internal;k++) {
22622 xfree(mp->int_name[k]);
22624 xfree(mp->internal);
22625 xfree(mp->int_name);
22628 @ The various `\&{show}' commands are distinguished by modifier fields
22631 @d show_token_code 0 /* show the meaning of a single token */
22632 @d show_stats_code 1 /* show current memory and string usage */
22633 @d show_code 2 /* show a list of expressions */
22634 @d show_var_code 3 /* show a variable and its descendents */
22635 @d show_dependencies_code 4 /* show dependent variables in terms of independents */
22638 mp_primitive(mp, "showtoken",show_command,show_token_code);
22639 @:show_token_}{\&{showtoken} primitive@>
22640 mp_primitive(mp, "showstats",show_command,show_stats_code);
22641 @:show_stats_}{\&{showstats} primitive@>
22642 mp_primitive(mp, "show",show_command,show_code);
22643 @:show_}{\&{show} primitive@>
22644 mp_primitive(mp, "showvariable",show_command,show_var_code);
22645 @:show_var_}{\&{showvariable} primitive@>
22646 mp_primitive(mp, "showdependencies",show_command,show_dependencies_code);
22647 @:show_dependencies_}{\&{showdependencies} primitive@>
22649 @ @<Cases of |print_cmd...@>=
22652 case show_token_code:mp_print(mp, "showtoken"); break;
22653 case show_stats_code:mp_print(mp, "showstats"); break;
22654 case show_code:mp_print(mp, "show"); break;
22655 case show_var_code:mp_print(mp, "showvariable"); break;
22656 default: mp_print(mp, "showdependencies"); break;
22660 @ @<Cases of |do_statement|...@>=
22661 case show_command:mp_do_show_whatever(mp); break;
22663 @ The value of |cur_mod| controls the |verbosity| in the |print_exp| routine:
22664 if it's |show_code|, complicated structures are abbreviated, otherwise
22667 @<Declare action procedures for use by |do_statement|@>=
22668 void mp_do_show (MP mp) ;
22670 @ @c void mp_do_show (MP mp) {
22672 mp_get_x_next(mp); mp_scan_expression(mp);
22673 mp_print_nl(mp, ">> ");
22675 mp_print_exp(mp, null,2); mp_flush_cur_exp(mp, 0);
22676 } while (mp->cur_cmd==comma);
22679 @ @<Declare action procedures for use by |do_statement|@>=
22680 void mp_disp_token (MP mp) ;
22682 @ @c void mp_disp_token (MP mp) {
22683 mp_print_nl(mp, "> ");
22685 if ( mp->cur_sym==0 ) {
22686 @<Show a numeric or string or capsule token@>;
22688 mp_print_text(mp->cur_sym); mp_print_char(mp, '=');
22689 if ( eq_type(mp->cur_sym)>=outer_tag ) mp_print(mp, "(outer) ");
22690 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod);
22691 if ( mp->cur_cmd==defined_macro ) {
22692 mp_print_ln(mp); mp_show_macro(mp, mp->cur_mod,null,100000);
22693 } /* this avoids recursion between |show_macro| and |print_cmd_mod| */
22698 @ @<Show a numeric or string or capsule token@>=
22700 if ( mp->cur_cmd==numeric_token ) {
22701 mp_print_scaled(mp, mp->cur_mod);
22702 } else if ( mp->cur_cmd==capsule_token ) {
22703 mp_print_capsule(mp,mp->cur_mod);
22705 mp_print_char(mp, '"');
22706 mp_print_str(mp, mp->cur_mod); mp_print_char(mp, '"');
22707 delete_str_ref(mp->cur_mod);
22711 @ The following cases of |print_cmd_mod| might arise in connection
22712 with |disp_token|, although they don't necessarily correspond to
22715 @<Cases of |print_cmd_...@>=
22716 case left_delimiter:
22717 case right_delimiter:
22718 if ( c==left_delimiter ) mp_print(mp, "left");
22719 else mp_print(mp, "right");
22720 mp_print(mp, " delimiter that matches ");
22724 if ( m==null ) mp_print(mp, "tag");
22725 else mp_print(mp, "variable");
22727 case defined_macro:
22728 mp_print(mp, "macro:");
22730 case secondary_primary_macro:
22731 case tertiary_secondary_macro:
22732 case expression_tertiary_macro:
22733 mp_print_cmd_mod(mp, macro_def,c);
22734 mp_print(mp, "'d macro:");
22735 mp_print_ln(mp); mp_show_token_list(mp, link(link(m)),null,1000,0);
22738 mp_print(mp, "[repeat the loop]");
22740 case internal_quantity:
22741 mp_print(mp, mp->int_name[m]);
22744 @ @<Declare action procedures for use by |do_statement|@>=
22745 void mp_do_show_token (MP mp) ;
22747 @ @c void mp_do_show_token (MP mp) {
22749 get_t_next; mp_disp_token(mp);
22751 } while (mp->cur_cmd==comma);
22754 @ @<Declare action procedures for use by |do_statement|@>=
22755 void mp_do_show_stats (MP mp) ;
22757 @ @c void mp_do_show_stats (MP mp) {
22758 mp_print_nl(mp, "Memory usage ");
22759 @.Memory usage...@>
22760 mp_print_int(mp, mp->var_used); mp_print_char(mp, '&'); mp_print_int(mp, mp->dyn_used);
22761 mp_print(mp, " ("); mp_print_int(mp, mp->hi_mem_min-mp->lo_mem_max-1);
22762 mp_print(mp, " still untouched)"); mp_print_ln(mp);
22763 mp_print_nl(mp, "String usage ");
22764 mp_print_int(mp, mp->strs_in_use-mp->init_str_use);
22765 mp_print_char(mp, '&'); mp_print_int(mp, mp->pool_in_use-mp->init_pool_ptr);
22766 mp_print(mp, " (");
22767 mp_print_int(mp, mp->max_strings-1-mp->strs_used_up); mp_print_char(mp, '&');
22768 mp_print_int(mp, mp->pool_size-mp->pool_ptr);
22769 mp_print(mp, " now untouched)"); mp_print_ln(mp);
22773 @ Here's a recursive procedure that gives an abbreviated account
22774 of a variable, for use by |do_show_var|.
22776 @<Declare action procedures for use by |do_statement|@>=
22777 void mp_disp_var (MP mp,pointer p) ;
22779 @ @c void mp_disp_var (MP mp,pointer p) {
22780 pointer q; /* traverses attributes and subscripts */
22781 int n; /* amount of macro text to show */
22782 if ( type(p)==mp_structured ) {
22783 @<Descend the structure@>;
22784 } else if ( type(p)>=mp_unsuffixed_macro ) {
22785 @<Display a variable macro@>;
22786 } else if ( type(p)!=undefined ){
22787 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22788 mp_print_char(mp, '=');
22789 mp_print_exp(mp, p,0);
22793 @ @<Descend the structure@>=
22796 do { mp_disp_var(mp, q); q=link(q); } while (q!=end_attr);
22798 while ( name_type(q)==mp_subscr ) {
22799 mp_disp_var(mp, q); q=link(q);
22803 @ @<Display a variable macro@>=
22805 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22806 if ( type(p)>mp_unsuffixed_macro )
22807 mp_print(mp, "@@#"); /* |suffixed_macro| */
22808 mp_print(mp, "=macro:");
22809 if ( (int)mp->file_offset>=mp->max_print_line-20 ) n=5;
22810 else n=mp->max_print_line-mp->file_offset-15;
22811 mp_show_macro(mp, value(p),null,n);
22814 @ @<Declare action procedures for use by |do_statement|@>=
22815 void mp_do_show_var (MP mp) ;
22817 @ @c void mp_do_show_var (MP mp) {
22820 if ( mp->cur_sym>0 ) if ( mp->cur_sym<=hash_end )
22821 if ( mp->cur_cmd==tag_token ) if ( mp->cur_mod!=null ) {
22822 mp_disp_var(mp, mp->cur_mod); goto DONE;
22827 } while (mp->cur_cmd==comma);
22830 @ @<Declare action procedures for use by |do_statement|@>=
22831 void mp_do_show_dependencies (MP mp) ;
22833 @ @c void mp_do_show_dependencies (MP mp) {
22834 pointer p; /* link that runs through all dependencies */
22836 while ( p!=dep_head ) {
22837 if ( mp_interesting(mp, p) ) {
22838 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22839 if ( type(p)==mp_dependent ) mp_print_char(mp, '=');
22840 else mp_print(mp, " = "); /* extra spaces imply proto-dependency */
22841 mp_print_dependency(mp, dep_list(p),type(p));
22844 while ( info(p)!=null ) p=link(p);
22850 @ Finally we are ready for the procedure that governs all of the
22853 @<Declare action procedures for use by |do_statement|@>=
22854 void mp_do_show_whatever (MP mp) ;
22856 @ @c void mp_do_show_whatever (MP mp) {
22857 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
22858 switch (mp->cur_mod) {
22859 case show_token_code:mp_do_show_token(mp); break;
22860 case show_stats_code:mp_do_show_stats(mp); break;
22861 case show_code:mp_do_show(mp); break;
22862 case show_var_code:mp_do_show_var(mp); break;
22863 case show_dependencies_code:mp_do_show_dependencies(mp); break;
22864 } /* there are no other cases */
22865 if ( mp->internal[mp_showstopping]>0 ){
22868 if ( mp->interaction<mp_error_stop_mode ) {
22869 help0; decr(mp->error_count);
22871 help1("This isn't an error message; I'm just showing something.");
22873 if ( mp->cur_cmd==semicolon ) mp_error(mp);
22874 else mp_put_get_error(mp);
22878 @ The `\&{addto}' command needs the following additional primitives:
22880 @d double_path_code 0 /* command modifier for `\&{doublepath}' */
22881 @d contour_code 1 /* command modifier for `\&{contour}' */
22882 @d also_code 2 /* command modifier for `\&{also}' */
22884 @ Pre and postscripts need two new identifiers:
22886 @d with_pre_script 11
22887 @d with_post_script 13
22890 mp_primitive(mp, "doublepath",thing_to_add,double_path_code);
22891 @:double_path_}{\&{doublepath} primitive@>
22892 mp_primitive(mp, "contour",thing_to_add,contour_code);
22893 @:contour_}{\&{contour} primitive@>
22894 mp_primitive(mp, "also",thing_to_add,also_code);
22895 @:also_}{\&{also} primitive@>
22896 mp_primitive(mp, "withpen",with_option,mp_pen_type);
22897 @:with_pen_}{\&{withpen} primitive@>
22898 mp_primitive(mp, "dashed",with_option,mp_picture_type);
22899 @:dashed_}{\&{dashed} primitive@>
22900 mp_primitive(mp, "withprescript",with_option,with_pre_script);
22901 @:with_pre_script_}{\&{withprescript} primitive@>
22902 mp_primitive(mp, "withpostscript",with_option,with_post_script);
22903 @:with_post_script_}{\&{withpostscript} primitive@>
22904 mp_primitive(mp, "withoutcolor",with_option,mp_no_model);
22905 @:with_color_}{\&{withoutcolor} primitive@>
22906 mp_primitive(mp, "withgreyscale",with_option,mp_grey_model);
22907 @:with_color_}{\&{withgreyscale} primitive@>
22908 mp_primitive(mp, "withcolor",with_option,mp_uninitialized_model);
22909 @:with_color_}{\&{withcolor} primitive@>
22910 /* \&{withrgbcolor} is an alias for \&{withcolor} */
22911 mp_primitive(mp, "withrgbcolor",with_option,mp_rgb_model);
22912 @:with_color_}{\&{withrgbcolor} primitive@>
22913 mp_primitive(mp, "withcmykcolor",with_option,mp_cmyk_model);
22914 @:with_color_}{\&{withcmykcolor} primitive@>
22916 @ @<Cases of |print_cmd...@>=
22918 if ( m==contour_code ) mp_print(mp, "contour");
22919 else if ( m==double_path_code ) mp_print(mp, "doublepath");
22920 else mp_print(mp, "also");
22923 if ( m==mp_pen_type ) mp_print(mp, "withpen");
22924 else if ( m==with_pre_script ) mp_print(mp, "withprescript");
22925 else if ( m==with_post_script ) mp_print(mp, "withpostscript");
22926 else if ( m==mp_no_model ) mp_print(mp, "withoutcolor");
22927 else if ( m==mp_rgb_model ) mp_print(mp, "withrgbcolor");
22928 else if ( m==mp_uninitialized_model ) mp_print(mp, "withcolor");
22929 else if ( m==mp_cmyk_model ) mp_print(mp, "withcmykcolor");
22930 else if ( m==mp_grey_model ) mp_print(mp, "withgreyscale");
22931 else mp_print(mp, "dashed");
22934 @ The |scan_with_list| procedure parses a $\langle$with list$\rangle$ and
22935 updates the list of graphical objects starting at |p|. Each $\langle$with
22936 clause$\rangle$ updates all graphical objects whose |type| is compatible.
22937 Other objects are ignored.
22939 @<Declare action procedures for use by |do_statement|@>=
22940 void mp_scan_with_list (MP mp,pointer p) ;
22942 @ @c void mp_scan_with_list (MP mp,pointer p) {
22943 small_number t; /* |cur_mod| of the |with_option| (should match |cur_type|) */
22944 pointer q; /* for list manipulation */
22945 int old_setting; /* saved |selector| setting */
22946 pointer k; /* for finding the near-last item in a list */
22947 str_number s; /* for string cleanup after combining */
22948 pointer cp,pp,dp,ap,bp;
22949 /* objects being updated; |void| initially; |null| to suppress update */
22950 cp=mp_void; pp=mp_void; dp=mp_void; ap=mp_void; bp=mp_void;
22952 while ( mp->cur_cmd==with_option ){
22955 if ( t!=mp_no_model ) mp_scan_expression(mp);
22956 if (((t==with_pre_script)&&(mp->cur_type!=mp_string_type))||
22957 ((t==with_post_script)&&(mp->cur_type!=mp_string_type))||
22958 ((t==mp_uninitialized_model)&&
22959 ((mp->cur_type!=mp_cmykcolor_type)&&(mp->cur_type!=mp_color_type)
22960 &&(mp->cur_type!=mp_known)&&(mp->cur_type!=mp_boolean_type)))||
22961 ((t==mp_cmyk_model)&&(mp->cur_type!=mp_cmykcolor_type))||
22962 ((t==mp_rgb_model)&&(mp->cur_type!=mp_color_type))||
22963 ((t==mp_grey_model)&&(mp->cur_type!=mp_known))||
22964 ((t==mp_pen_type)&&(mp->cur_type!=t))||
22965 ((t==mp_picture_type)&&(mp->cur_type!=t)) ) {
22966 @<Complain about improper type@>;
22967 } else if ( t==mp_uninitialized_model ) {
22968 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22970 @<Transfer a color from the current expression to object~|cp|@>;
22971 mp_flush_cur_exp(mp, 0);
22972 } else if ( t==mp_rgb_model ) {
22973 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22975 @<Transfer a rgbcolor from the current expression to object~|cp|@>;
22976 mp_flush_cur_exp(mp, 0);
22977 } else if ( t==mp_cmyk_model ) {
22978 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22980 @<Transfer a cmykcolor from the current expression to object~|cp|@>;
22981 mp_flush_cur_exp(mp, 0);
22982 } else if ( t==mp_grey_model ) {
22983 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22985 @<Transfer a greyscale from the current expression to object~|cp|@>;
22986 mp_flush_cur_exp(mp, 0);
22987 } else if ( t==mp_no_model ) {
22988 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22990 @<Transfer a noncolor from the current expression to object~|cp|@>;
22991 } else if ( t==mp_pen_type ) {
22992 if ( pp==mp_void ) @<Make |pp| an object in list~|p| that needs a pen@>;
22994 if ( pen_p(pp)!=null ) mp_toss_knot_list(mp, pen_p(pp));
22995 pen_p(pp)=mp->cur_exp; mp->cur_type=mp_vacuous;
22997 } else if ( t==with_pre_script ) {
23000 while ( (ap!=null)&&(! has_color(ap)) )
23003 if ( pre_script(ap)!=null ) { /* build a new,combined string */
23005 old_setting=mp->selector;
23006 mp->selector=new_string;
23007 str_room(length(pre_script(ap))+length(mp->cur_exp)+2);
23008 mp_print_str(mp, mp->cur_exp);
23009 append_char(13); /* a forced \ps\ newline */
23010 mp_print_str(mp, pre_script(ap));
23011 pre_script(ap)=mp_make_string(mp);
23013 mp->selector=old_setting;
23015 pre_script(ap)=mp->cur_exp;
23017 mp->cur_type=mp_vacuous;
23019 } else if ( t==with_post_script ) {
23023 while ( link(k)!=null ) {
23025 if ( has_color(k) ) bp=k;
23028 if ( post_script(bp)!=null ) {
23030 old_setting=mp->selector;
23031 mp->selector=new_string;
23032 str_room(length(post_script(bp))+length(mp->cur_exp)+2);
23033 mp_print_str(mp, post_script(bp));
23034 append_char(13); /* a forced \ps\ newline */
23035 mp_print_str(mp, mp->cur_exp);
23036 post_script(bp)=mp_make_string(mp);
23038 mp->selector=old_setting;
23040 post_script(bp)=mp->cur_exp;
23042 mp->cur_type=mp_vacuous;
23045 if ( dp==mp_void ) {
23046 @<Make |dp| a stroked node in list~|p|@>;
23049 if ( dash_p(dp)!=null ) delete_edge_ref(dash_p(dp));
23050 dash_p(dp)=mp_make_dashes(mp, mp->cur_exp);
23051 dash_scale(dp)=unity;
23052 mp->cur_type=mp_vacuous;
23056 @<Copy the information from objects |cp|, |pp|, and |dp| into the rest
23060 @ @<Complain about improper type@>=
23061 { exp_err("Improper type");
23063 help2("Next time say `withpen <known pen expression>';")
23064 ("I'll ignore the bad `with' clause and look for another.");
23065 if ( t==with_pre_script )
23066 mp->help_line[1]="Next time say `withprescript <known string expression>';";
23067 else if ( t==with_post_script )
23068 mp->help_line[1]="Next time say `withpostscript <known string expression>';";
23069 else if ( t==mp_picture_type )
23070 mp->help_line[1]="Next time say `dashed <known picture expression>';";
23071 else if ( t==mp_uninitialized_model )
23072 mp->help_line[1]="Next time say `withcolor <known color expression>';";
23073 else if ( t==mp_rgb_model )
23074 mp->help_line[1]="Next time say `withrgbcolor <known color expression>';";
23075 else if ( t==mp_cmyk_model )
23076 mp->help_line[1]="Next time say `withcmykcolor <known cmykcolor expression>';";
23077 else if ( t==mp_grey_model )
23078 mp->help_line[1]="Next time say `withgreyscale <known numeric expression>';";;
23079 mp_put_get_flush_error(mp, 0);
23082 @ Forcing the color to be between |0| and |unity| here guarantees that no
23083 picture will ever contain a color outside the legal range for \ps\ graphics.
23085 @<Transfer a color from the current expression to object~|cp|@>=
23086 { if ( mp->cur_type==mp_color_type )
23087 @<Transfer a rgbcolor from the current expression to object~|cp|@>
23088 else if ( mp->cur_type==mp_cmykcolor_type )
23089 @<Transfer a cmykcolor from the current expression to object~|cp|@>
23090 else if ( mp->cur_type==mp_known )
23091 @<Transfer a greyscale from the current expression to object~|cp|@>
23092 else if ( mp->cur_exp==false_code )
23093 @<Transfer a noncolor from the current expression to object~|cp|@>;
23096 @ @<Transfer a rgbcolor from the current expression to object~|cp|@>=
23097 { q=value(mp->cur_exp);
23102 red_val(cp)=value(red_part_loc(q));
23103 green_val(cp)=value(green_part_loc(q));
23104 blue_val(cp)=value(blue_part_loc(q));
23105 color_model(cp)=mp_rgb_model;
23106 if ( red_val(cp)<0 ) red_val(cp)=0;
23107 if ( green_val(cp)<0 ) green_val(cp)=0;
23108 if ( blue_val(cp)<0 ) blue_val(cp)=0;
23109 if ( red_val(cp)>unity ) red_val(cp)=unity;
23110 if ( green_val(cp)>unity ) green_val(cp)=unity;
23111 if ( blue_val(cp)>unity ) blue_val(cp)=unity;
23114 @ @<Transfer a cmykcolor from the current expression to object~|cp|@>=
23115 { q=value(mp->cur_exp);
23116 cyan_val(cp)=value(cyan_part_loc(q));
23117 magenta_val(cp)=value(magenta_part_loc(q));
23118 yellow_val(cp)=value(yellow_part_loc(q));
23119 black_val(cp)=value(black_part_loc(q));
23120 color_model(cp)=mp_cmyk_model;
23121 if ( cyan_val(cp)<0 ) cyan_val(cp)=0;
23122 if ( magenta_val(cp)<0 ) magenta_val(cp)=0;
23123 if ( yellow_val(cp)<0 ) yellow_val(cp)=0;
23124 if ( black_val(cp)<0 ) black_val(cp)=0;
23125 if ( cyan_val(cp)>unity ) cyan_val(cp)=unity;
23126 if ( magenta_val(cp)>unity ) magenta_val(cp)=unity;
23127 if ( yellow_val(cp)>unity ) yellow_val(cp)=unity;
23128 if ( black_val(cp)>unity ) black_val(cp)=unity;
23131 @ @<Transfer a greyscale from the current expression to object~|cp|@>=
23138 color_model(cp)=mp_grey_model;
23139 if ( grey_val(cp)<0 ) grey_val(cp)=0;
23140 if ( grey_val(cp)>unity ) grey_val(cp)=unity;
23143 @ @<Transfer a noncolor from the current expression to object~|cp|@>=
23150 color_model(cp)=mp_no_model;
23153 @ @<Make |cp| a colored object in object list~|p|@>=
23155 while ( cp!=null ){
23156 if ( has_color(cp) ) break;
23161 @ @<Make |pp| an object in list~|p| that needs a pen@>=
23163 while ( pp!=null ) {
23164 if ( has_pen(pp) ) break;
23169 @ @<Make |dp| a stroked node in list~|p|@>=
23171 while ( dp!=null ) {
23172 if ( type(dp)==mp_stroked_code ) break;
23177 @ @<Copy the information from objects |cp|, |pp|, and |dp| into...@>=
23178 @<Copy |cp|'s color into the colored objects linked to~|cp|@>;
23179 if ( pp>mp_void ) {
23180 @<Copy |pen_p(pp)| into stroked and filled nodes linked to |pp|@>;
23182 if ( dp>mp_void ) {
23183 @<Make stroked nodes linked to |dp| refer to |dash_p(dp)|@>;
23187 @ @<Copy |cp|'s color into the colored objects linked to~|cp|@>=
23189 while ( q!=null ) {
23190 if ( has_color(q) ) {
23191 red_val(q)=red_val(cp);
23192 green_val(q)=green_val(cp);
23193 blue_val(q)=blue_val(cp);
23194 black_val(q)=black_val(cp);
23195 color_model(q)=color_model(cp);
23201 @ @<Copy |pen_p(pp)| into stroked and filled nodes linked to |pp|@>=
23203 while ( q!=null ) {
23204 if ( has_pen(q) ) {
23205 if ( pen_p(q)!=null ) mp_toss_knot_list(mp, pen_p(q));
23206 pen_p(q)=copy_pen(pen_p(pp));
23212 @ @<Make stroked nodes linked to |dp| refer to |dash_p(dp)|@>=
23214 while ( q!=null ) {
23215 if ( type(q)==mp_stroked_code ) {
23216 if ( dash_p(q)!=null ) delete_edge_ref(dash_p(q));
23217 dash_p(q)=dash_p(dp);
23218 dash_scale(q)=unity;
23219 if ( dash_p(q)!=null ) add_edge_ref(dash_p(q));
23225 @ One of the things we need to do when we've parsed an \&{addto} or
23226 similar command is find the header of a supposed \&{picture} variable, given
23227 a token list for that variable. Since the edge structure is about to be
23228 updated, we use |private_edges| to make sure that this is possible.
23230 @<Declare action procedures for use by |do_statement|@>=
23231 pointer mp_find_edges_var (MP mp, pointer t) ;
23233 @ @c pointer mp_find_edges_var (MP mp, pointer t) {
23235 pointer cur_edges; /* the return value */
23236 p=mp_find_variable(mp, t); cur_edges=null;
23238 mp_obliterated(mp, t); mp_put_get_error(mp);
23239 } else if ( type(p)!=mp_picture_type ) {
23240 print_err("Variable "); mp_show_token_list(mp, t,null,1000,0);
23241 @.Variable x is the wrong type@>
23242 mp_print(mp, " is the wrong type (");
23243 mp_print_type(mp, type(p)); mp_print_char(mp, ')');
23244 help2("I was looking for a \"known\" picture variable.")
23245 ("So I'll not change anything just now.");
23246 mp_put_get_error(mp);
23248 value(p)=mp_private_edges(mp, value(p));
23249 cur_edges=value(p);
23251 mp_flush_node_list(mp, t);
23255 @ @<Cases of |do_statement|...@>=
23256 case add_to_command: mp_do_add_to(mp); break;
23257 case bounds_command:mp_do_bounds(mp); break;
23260 mp_primitive(mp, "clip",bounds_command,mp_start_clip_code);
23261 @:clip_}{\&{clip} primitive@>
23262 mp_primitive(mp, "setbounds",bounds_command,mp_start_bounds_code);
23263 @:set_bounds_}{\&{setbounds} primitive@>
23265 @ @<Cases of |print_cmd...@>=
23266 case bounds_command:
23267 if ( m==mp_start_clip_code ) mp_print(mp, "clip");
23268 else mp_print(mp, "setbounds");
23271 @ The following function parses the beginning of an \&{addto} or \&{clip}
23272 command: it expects a variable name followed by a token with |cur_cmd=sep|
23273 and then an expression. The function returns the token list for the variable
23274 and stores the command modifier for the separator token in the global variable
23275 |last_add_type|. We must be careful because this variable might get overwritten
23276 any time we call |get_x_next|.
23279 quarterword last_add_type;
23280 /* command modifier that identifies the last \&{addto} command */
23282 @ @<Declare action procedures for use by |do_statement|@>=
23283 pointer mp_start_draw_cmd (MP mp,quarterword sep) ;
23285 @ @c pointer mp_start_draw_cmd (MP mp,quarterword sep) {
23286 pointer lhv; /* variable to add to left */
23287 quarterword add_type=0; /* value to be returned in |last_add_type| */
23289 mp_get_x_next(mp); mp->var_flag=sep; mp_scan_primary(mp);
23290 if ( mp->cur_type!=mp_token_list ) {
23291 @<Abandon edges command because there's no variable@>;
23293 lhv=mp->cur_exp; add_type=mp->cur_mod;
23294 mp->cur_type=mp_vacuous; mp_get_x_next(mp); mp_scan_expression(mp);
23296 mp->last_add_type=add_type;
23300 @ @<Abandon edges command because there's no variable@>=
23301 { exp_err("Not a suitable variable");
23302 @.Not a suitable variable@>
23303 help4("At this point I needed to see the name of a picture variable.")
23304 ("(Or perhaps you have indeed presented me with one; I might")
23305 ("have missed it, if it wasn't followed by the proper token.)")
23306 ("So I'll not change anything just now.");
23307 mp_put_get_flush_error(mp, 0);
23310 @ Here is an example of how to use |start_draw_cmd|.
23312 @<Declare action procedures for use by |do_statement|@>=
23313 void mp_do_bounds (MP mp) ;
23315 @ @c void mp_do_bounds (MP mp) {
23316 pointer lhv,lhe; /* variable on left, the corresponding edge structure */
23317 pointer p; /* for list manipulation */
23318 integer m; /* initial value of |cur_mod| */
23320 lhv=mp_start_draw_cmd(mp, to_token);
23322 lhe=mp_find_edges_var(mp, lhv);
23324 mp_flush_cur_exp(mp, 0);
23325 } else if ( mp->cur_type!=mp_path_type ) {
23326 exp_err("Improper `clip'");
23327 @.Improper `addto'@>
23328 help2("This expression should have specified a known path.")
23329 ("So I'll not change anything just now.");
23330 mp_put_get_flush_error(mp, 0);
23331 } else if ( left_type(mp->cur_exp)==mp_endpoint ) {
23332 @<Complain about a non-cycle@>;
23334 @<Make |cur_exp| into a \&{setbounds} or clipping path and add it to |lhe|@>;
23339 @ @<Complain about a non-cycle@>=
23340 { print_err("Not a cycle");
23342 help2("That contour should have ended with `..cycle' or `&cycle'.")
23343 ("So I'll not change anything just now."); mp_put_get_error(mp);
23346 @ @<Make |cur_exp| into a \&{setbounds} or clipping path and add...@>=
23347 { p=mp_new_bounds_node(mp, mp->cur_exp,m);
23348 link(p)=link(dummy_loc(lhe));
23349 link(dummy_loc(lhe))=p;
23350 if ( obj_tail(lhe)==dummy_loc(lhe) ) obj_tail(lhe)=p;
23351 p=mp_get_node(mp, mp->gr_object_size[stop_type(m)]);
23352 type(p)=stop_type(m);
23353 link(obj_tail(lhe))=p;
23355 mp_init_bbox(mp, lhe);
23358 @ The |do_add_to| procedure is a little like |do_clip| but there are a lot more
23359 cases to deal with.
23361 @<Declare action procedures for use by |do_statement|@>=
23362 void mp_do_add_to (MP mp) ;
23364 @ @c void mp_do_add_to (MP mp) {
23365 pointer lhv,lhe; /* variable on left, the corresponding edge structure */
23366 pointer p; /* the graphical object or list for |scan_with_list| to update */
23367 pointer e; /* an edge structure to be merged */
23368 quarterword add_type; /* |also_code|, |contour_code|, or |double_path_code| */
23369 lhv=mp_start_draw_cmd(mp, thing_to_add); add_type=mp->last_add_type;
23371 if ( add_type==also_code ) {
23372 @<Make sure the current expression is a suitable picture and set |e| and |p|
23375 @<Create a graphical object |p| based on |add_type| and the current
23378 mp_scan_with_list(mp, p);
23379 @<Use |p|, |e|, and |add_type| to augment |lhv| as requested@>;
23383 @ Setting |p:=null| causes the $\langle$with list$\rangle$ to be ignored;
23384 setting |e:=null| prevents anything from being added to |lhe|.
23386 @ @<Make sure the current expression is a suitable picture and set |e|...@>=
23389 if ( mp->cur_type!=mp_picture_type ) {
23390 exp_err("Improper `addto'");
23391 @.Improper `addto'@>
23392 help2("This expression should have specified a known picture.")
23393 ("So I'll not change anything just now."); mp_put_get_flush_error(mp, 0);
23395 e=mp_private_edges(mp, mp->cur_exp); mp->cur_type=mp_vacuous;
23396 p=link(dummy_loc(e));
23400 @ In this case |add_type<>also_code| so setting |p:=null| suppresses future
23401 attempts to add to the edge structure.
23403 @<Create a graphical object |p| based on |add_type| and the current...@>=
23405 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
23406 if ( mp->cur_type!=mp_path_type ) {
23407 exp_err("Improper `addto'");
23408 @.Improper `addto'@>
23409 help2("This expression should have specified a known path.")
23410 ("So I'll not change anything just now.");
23411 mp_put_get_flush_error(mp, 0);
23412 } else if ( add_type==contour_code ) {
23413 if ( left_type(mp->cur_exp)==mp_endpoint ) {
23414 @<Complain about a non-cycle@>;
23416 p=mp_new_fill_node(mp, mp->cur_exp);
23417 mp->cur_type=mp_vacuous;
23420 p=mp_new_stroked_node(mp, mp->cur_exp);
23421 mp->cur_type=mp_vacuous;
23425 @ @<Use |p|, |e|, and |add_type| to augment |lhv| as requested@>=
23426 lhe=mp_find_edges_var(mp, lhv);
23428 if ( (e==null)&&(p!=null) ) e=mp_toss_gr_object(mp, p);
23429 if ( e!=null ) delete_edge_ref(e);
23430 } else if ( add_type==also_code ) {
23432 @<Merge |e| into |lhe| and delete |e|@>;
23436 } else if ( p!=null ) {
23437 link(obj_tail(lhe))=p;
23439 if ( add_type==double_path_code )
23440 if ( pen_p(p)==null )
23441 pen_p(p)=mp_get_pen_circle(mp, 0);
23444 @ @<Merge |e| into |lhe| and delete |e|@>=
23445 { if ( link(dummy_loc(e))!=null ) {
23446 link(obj_tail(lhe))=link(dummy_loc(e));
23447 obj_tail(lhe)=obj_tail(e);
23448 obj_tail(e)=dummy_loc(e);
23449 link(dummy_loc(e))=null;
23450 mp_flush_dash_list(mp, lhe);
23452 mp_toss_edges(mp, e);
23455 @ @<Cases of |do_statement|...@>=
23456 case ship_out_command: mp_do_ship_out(mp); break;
23458 @ @<Declare action procedures for use by |do_statement|@>=
23459 @<Declare the function called |tfm_check|@>
23460 @<Declare the \ps\ output procedures@>
23461 void mp_do_ship_out (MP mp) ;
23463 @ @c void mp_do_ship_out (MP mp) {
23464 integer c; /* the character code */
23465 mp_get_x_next(mp); mp_scan_expression(mp);
23466 if ( mp->cur_type!=mp_picture_type ) {
23467 @<Complain that it's not a known picture@>;
23469 c=mp_round_unscaled(mp, mp->internal[mp_char_code]) % 256;
23470 if ( c<0 ) c=c+256;
23471 @<Store the width information for character code~|c|@>;
23472 mp_ship_out(mp, mp->cur_exp);
23473 mp_flush_cur_exp(mp, 0);
23477 @ @<Complain that it's not a known picture@>=
23479 exp_err("Not a known picture");
23480 help1("I can only output known pictures.");
23481 mp_put_get_flush_error(mp, 0);
23484 @ The \&{everyjob} command simply assigns a nonzero value to the global variable
23487 @<Cases of |do_statement|...@>=
23488 case every_job_command:
23489 mp_get_symbol(mp); mp->start_sym=mp->cur_sym; mp_get_x_next(mp);
23493 halfword start_sym; /* a symbolic token to insert at beginning of job */
23498 @ Finally, we have only the ``message'' commands remaining.
23501 @d err_message_code 1
23503 @d filename_template_code 3
23504 @d print_with_leading_zeroes(A) g = mp->pool_ptr;
23505 mp_print_int(mp, (A)); g = mp->pool_ptr-g;
23507 mp->pool_ptr = mp->pool_ptr - g;
23509 mp_print_char(mp, '0');
23512 mp_print_int(mp, (A));
23517 mp_primitive(mp, "message",message_command,message_code);
23518 @:message_}{\&{message} primitive@>
23519 mp_primitive(mp, "errmessage",message_command,err_message_code);
23520 @:err_message_}{\&{errmessage} primitive@>
23521 mp_primitive(mp, "errhelp",message_command,err_help_code);
23522 @:err_help_}{\&{errhelp} primitive@>
23523 mp_primitive(mp, "filenametemplate",message_command,filename_template_code);
23524 @:filename_template_}{\&{filenametemplate} primitive@>
23526 @ @<Cases of |print_cmd...@>=
23527 case message_command:
23528 if ( m<err_message_code ) mp_print(mp, "message");
23529 else if ( m==err_message_code ) mp_print(mp, "errmessage");
23530 else if ( m==filename_template_code ) mp_print(mp, "filenametemplate");
23531 else mp_print(mp, "errhelp");
23534 @ @<Cases of |do_statement|...@>=
23535 case message_command: mp_do_message(mp); break;
23537 @ @<Declare action procedures for use by |do_statement|@>=
23538 @<Declare a procedure called |no_string_err|@>
23539 void mp_do_message (MP mp) ;
23542 @c void mp_do_message (MP mp) {
23543 int m; /* the type of message */
23544 m=mp->cur_mod; mp_get_x_next(mp); mp_scan_expression(mp);
23545 if ( mp->cur_type!=mp_string_type )
23546 mp_no_string_err(mp, "A message should be a known string expression.");
23550 mp_print_nl(mp, ""); mp_print_str(mp, mp->cur_exp);
23552 case err_message_code:
23553 @<Print string |cur_exp| as an error message@>;
23555 case err_help_code:
23556 @<Save string |cur_exp| as the |err_help|@>;
23558 case filename_template_code:
23559 @<Save the filename template@>;
23561 } /* there are no other cases */
23563 mp_flush_cur_exp(mp, 0);
23566 @ @<Declare a procedure called |no_string_err|@>=
23567 void mp_no_string_err (MP mp, const char *s) {
23568 exp_err("Not a string");
23571 mp_put_get_error(mp);
23574 @ The global variable |err_help| is zero when the user has most recently
23575 given an empty help string, or if none has ever been given.
23577 @<Save string |cur_exp| as the |err_help|@>=
23579 if ( mp->err_help!=0 ) delete_str_ref(mp->err_help);
23580 if ( length(mp->cur_exp)==0 ) mp->err_help=0;
23581 else { mp->err_help=mp->cur_exp; add_str_ref(mp->err_help); }
23584 @ If \&{errmessage} occurs often in |mp_scroll_mode|, without user-defined
23585 \&{errhelp}, we don't want to give a long help message each time. So we
23586 give a verbose explanation only once.
23589 boolean long_help_seen; /* has the long \.{\\errmessage} help been used? */
23591 @ @<Set init...@>=mp->long_help_seen=false;
23593 @ @<Print string |cur_exp| as an error message@>=
23595 print_err(""); mp_print_str(mp, mp->cur_exp);
23596 if ( mp->err_help!=0 ) {
23597 mp->use_err_help=true;
23598 } else if ( mp->long_help_seen ) {
23599 help1("(That was another `errmessage'.)") ;
23601 if ( mp->interaction<mp_error_stop_mode ) mp->long_help_seen=true;
23602 help4("This error message was generated by an `errmessage'")
23603 ("command, so I can\'t give any explicit help.")
23604 ("Pretend that you're Miss Marple: Examine all clues,")
23606 ("and deduce the truth by inspired guesses.");
23608 mp_put_get_error(mp); mp->use_err_help=false;
23611 @ @<Cases of |do_statement|...@>=
23612 case write_command: mp_do_write(mp); break;
23614 @ @<Declare action procedures for use by |do_statement|@>=
23615 void mp_do_write (MP mp) ;
23617 @ @c void mp_do_write (MP mp) {
23618 str_number t; /* the line of text to be written */
23619 write_index n,n0; /* for searching |wr_fname| and |wr_file| arrays */
23620 int old_setting; /* for saving |selector| during output */
23622 mp_scan_expression(mp);
23623 if ( mp->cur_type!=mp_string_type ) {
23624 mp_no_string_err(mp, "The text to be written should be a known string expression");
23625 } else if ( mp->cur_cmd!=to_token ) {
23626 print_err("Missing `to' clause");
23627 help1("A write command should end with `to <filename>'");
23628 mp_put_get_error(mp);
23630 t=mp->cur_exp; mp->cur_type=mp_vacuous;
23632 mp_scan_expression(mp);
23633 if ( mp->cur_type!=mp_string_type )
23634 mp_no_string_err(mp, "I can\'t write to that file name. It isn't a known string");
23636 @<Write |t| to the file named by |cur_exp|@>;
23640 mp_flush_cur_exp(mp, 0);
23643 @ @<Write |t| to the file named by |cur_exp|@>=
23645 @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if
23646 |cur_exp| must be inserted@>;
23647 if ( mp_str_vs_str(mp, t,mp->eof_line)==0 ) {
23648 @<Record the end of file on |wr_file[n]|@>;
23650 old_setting=mp->selector;
23651 mp->selector=n+write_file;
23652 mp_print_str(mp, t); mp_print_ln(mp);
23653 mp->selector = old_setting;
23657 @ @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if...@>=
23659 char *fn = str(mp->cur_exp);
23661 n0=mp->write_files;
23662 while (mp_xstrcmp(fn,mp->wr_fname[n])!=0) {
23663 if ( n==0 ) { /* bottom reached */
23664 if ( n0==mp->write_files ) {
23665 if ( mp->write_files<mp->max_write_files ) {
23666 incr(mp->write_files);
23671 l = mp->max_write_files + (mp->max_write_files>>2);
23672 wr_file = xmalloc((l+1),sizeof(void *));
23673 wr_fname = xmalloc((l+1),sizeof(char *));
23674 for (k=0;k<=l;k++) {
23675 if (k<=mp->max_write_files) {
23676 wr_file[k]=mp->wr_file[k];
23677 wr_fname[k]=mp->wr_fname[k];
23683 xfree(mp->wr_file); xfree(mp->wr_fname);
23684 mp->max_write_files = l;
23685 mp->wr_file = wr_file;
23686 mp->wr_fname = wr_fname;
23690 mp_open_write_file(mp, fn ,n);
23693 if ( mp->wr_fname[n]==NULL ) n0=n;
23698 @ @<Record the end of file on |wr_file[n]|@>=
23699 { (mp->close_file)(mp,mp->wr_file[n]);
23700 xfree(mp->wr_fname[n]);
23701 if ( n==mp->write_files-1 ) mp->write_files=n;
23705 @* \[42] Writing font metric data.
23706 \TeX\ gets its knowledge about fonts from font metric files, also called
23707 \.{TFM} files; the `\.T' in `\.{TFM}' stands for \TeX,
23708 but other programs know about them too. One of \MP's duties is to
23709 write \.{TFM} files so that the user's fonts can readily be
23710 applied to typesetting.
23711 @:TFM files}{\.{TFM} files@>
23712 @^font metric files@>
23714 The information in a \.{TFM} file appears in a sequence of 8-bit bytes.
23715 Since the number of bytes is always a multiple of~4, we could
23716 also regard the file as a sequence of 32-bit words, but \MP\ uses the
23717 byte interpretation. The format of \.{TFM} files was designed by
23718 Lyle Ramshaw in 1980. The intent is to convey a lot of different kinds
23719 @^Ramshaw, Lyle Harold@>
23720 of information in a compact but useful form.
23723 void * tfm_file; /* the font metric output goes here */
23724 char * metric_file_name; /* full name of the font metric file */
23726 @ The first 24 bytes (6 words) of a \.{TFM} file contain twelve 16-bit
23727 integers that give the lengths of the various subsequent portions
23728 of the file. These twelve integers are, in order:
23729 $$\vbox{\halign{\hfil#&$\null=\null$#\hfil\cr
23730 |lf|&length of the entire file, in words;\cr
23731 |lh|&length of the header data, in words;\cr
23732 |bc|&smallest character code in the font;\cr
23733 |ec|&largest character code in the font;\cr
23734 |nw|&number of words in the width table;\cr
23735 |nh|&number of words in the height table;\cr
23736 |nd|&number of words in the depth table;\cr
23737 |ni|&number of words in the italic correction table;\cr
23738 |nl|&number of words in the lig/kern table;\cr
23739 |nk|&number of words in the kern table;\cr
23740 |ne|&number of words in the extensible character table;\cr
23741 |np|&number of font parameter words.\cr}}$$
23742 They are all nonnegative and less than $2^{15}$. We must have |bc-1<=ec<=255|,
23744 $$\hbox{|lf=6+lh+(ec-bc+1)+nw+nh+nd+ni+nl+nk+ne+np|.}$$
23745 Note that a font may contain as many as 256 characters (if |bc=0| and |ec=255|),
23746 and as few as 0 characters (if |bc=ec+1|).
23748 Incidentally, when two or more 8-bit bytes are combined to form an integer of
23749 16 or more bits, the most significant bytes appear first in the file.
23750 This is called BigEndian order.
23751 @^BigEndian order@>
23753 @ The rest of the \.{TFM} file may be regarded as a sequence of ten data
23756 The most important data type used here is a |fix_word|, which is
23757 a 32-bit representation of a binary fraction. A |fix_word| is a signed
23758 quantity, with the two's complement of the entire word used to represent
23759 negation. Of the 32 bits in a |fix_word|, exactly 12 are to the left of the
23760 binary point; thus, the largest |fix_word| value is $2048-2^{-20}$, and
23761 the smallest is $-2048$. We will see below, however, that all but two of
23762 the |fix_word| values must lie between $-16$ and $+16$.
23764 @ The first data array is a block of header information, which contains
23765 general facts about the font. The header must contain at least two words,
23766 |header[0]| and |header[1]|, whose meaning is explained below. Additional
23767 header information of use to other software routines might also be
23768 included, and \MP\ will generate it if the \.{headerbyte} command occurs.
23769 For example, 16 more words of header information are in use at the Xerox
23770 Palo Alto Research Center; the first ten specify the character coding
23771 scheme used (e.g., `\.{XEROX TEXT}' or `\.{TEX MATHSY}'), the next five
23772 give the font family name (e.g., `\.{HELVETICA}' or `\.{CMSY}'), and the
23773 last gives the ``face byte.''
23775 \yskip\hang|header[0]| is a 32-bit check sum that \MP\ will copy into
23776 the \.{GF} output file. This helps ensure consistency between files,
23777 since \TeX\ records the check sums from the \.{TFM}'s it reads, and these
23778 should match the check sums on actual fonts that are used. The actual
23779 relation between this check sum and the rest of the \.{TFM} file is not
23780 important; the check sum is simply an identification number with the
23781 property that incompatible fonts almost always have distinct check sums.
23784 \yskip\hang|header[1]| is a |fix_word| containing the design size of the
23785 font, in units of \TeX\ points. This number must be at least 1.0; it is
23786 fairly arbitrary, but usually the design size is 10.0 for a ``10 point''
23787 font, i.e., a font that was designed to look best at a 10-point size,
23788 whatever that really means. When a \TeX\ user asks for a font `\.{at}
23789 $\delta$ \.{pt}', the effect is to override the design size and replace it
23790 by $\delta$, and to multiply the $x$ and~$y$ coordinates of the points in
23791 the font image by a factor of $\delta$ divided by the design size. {\sl
23792 All other dimensions in the\/ \.{TFM} file are |fix_word|\kern-1pt\
23793 numbers in design-size units.} Thus, for example, the value of |param[6]|,
23794 which defines the \.{em} unit, is often the |fix_word| value $2^{20}=1.0$,
23795 since many fonts have a design size equal to one em. The other dimensions
23796 must be less than 16 design-size units in absolute value; thus,
23797 |header[1]| and |param[1]| are the only |fix_word| entries in the whole
23798 \.{TFM} file whose first byte might be something besides 0 or 255.
23801 @ Next comes the |char_info| array, which contains one |char_info_word|
23802 per character. Each word in this part of the file contains six fields
23803 packed into four bytes as follows.
23805 \yskip\hang first byte: |width_index| (8 bits)\par
23806 \hang second byte: |height_index| (4 bits) times 16, plus |depth_index|
23808 \hang third byte: |italic_index| (6 bits) times 4, plus |tag|
23810 \hang fourth byte: |remainder| (8 bits)\par
23812 The actual width of a character is \\{width}|[width_index]|, in design-size
23813 units; this is a device for compressing information, since many characters
23814 have the same width. Since it is quite common for many characters
23815 to have the same height, depth, or italic correction, the \.{TFM} format
23816 imposes a limit of 16 different heights, 16 different depths, and
23817 64 different italic corrections.
23819 Incidentally, the relation $\\{width}[0]=\\{height}[0]=\\{depth}[0]=
23820 \\{italic}[0]=0$ should always hold, so that an index of zero implies a
23821 value of zero. The |width_index| should never be zero unless the
23822 character does not exist in the font, since a character is valid if and
23823 only if it lies between |bc| and |ec| and has a nonzero |width_index|.
23825 @ The |tag| field in a |char_info_word| has four values that explain how to
23826 interpret the |remainder| field.
23828 \yskip\hang|tag=0| (|no_tag|) means that |remainder| is unused.\par
23829 \hang|tag=1| (|lig_tag|) means that this character has a ligature/kerning
23830 program starting at location |remainder| in the |lig_kern| array.\par
23831 \hang|tag=2| (|list_tag|) means that this character is part of a chain of
23832 characters of ascending sizes, and not the largest in the chain. The
23833 |remainder| field gives the character code of the next larger character.\par
23834 \hang|tag=3| (|ext_tag|) means that this character code represents an
23835 extensible character, i.e., a character that is built up of smaller pieces
23836 so that it can be made arbitrarily large. The pieces are specified in
23837 |exten[remainder]|.\par
23839 Characters with |tag=2| and |tag=3| are treated as characters with |tag=0|
23840 unless they are used in special circumstances in math formulas. For example,
23841 \TeX's \.{\\sum} operation looks for a |list_tag|, and the \.{\\left}
23842 operation looks for both |list_tag| and |ext_tag|.
23844 @d no_tag 0 /* vanilla character */
23845 @d lig_tag 1 /* character has a ligature/kerning program */
23846 @d list_tag 2 /* character has a successor in a charlist */
23847 @d ext_tag 3 /* character is extensible */
23849 @ The |lig_kern| array contains instructions in a simple programming language
23850 that explains what to do for special letter pairs. Each word in this array is a
23851 |lig_kern_command| of four bytes.
23853 \yskip\hang first byte: |skip_byte|, indicates that this is the final program
23854 step if the byte is 128 or more, otherwise the next step is obtained by
23855 skipping this number of intervening steps.\par
23856 \hang second byte: |next_char|, ``if |next_char| follows the current character,
23857 then perform the operation and stop, otherwise continue.''\par
23858 \hang third byte: |op_byte|, indicates a ligature step if less than~128,
23859 a kern step otherwise.\par
23860 \hang fourth byte: |remainder|.\par
23863 additional space equal to |kern[256*(op_byte-128)+remainder]| is inserted
23864 between the current character and |next_char|. This amount is
23865 often negative, so that the characters are brought closer together
23866 by kerning; but it might be positive.
23868 There are eight kinds of ligature steps, having |op_byte| codes $4a+2b+c$ where
23869 $0\le a\le b+c$ and $0\le b,c\le1$. The character whose code is
23870 |remainder| is inserted between the current character and |next_char|;
23871 then the current character is deleted if $b=0$, and |next_char| is
23872 deleted if $c=0$; then we pass over $a$~characters to reach the next
23873 current character (which may have a ligature/kerning program of its own).
23875 If the very first instruction of the |lig_kern| array has |skip_byte=255|,
23876 the |next_char| byte is the so-called right boundary character of this font;
23877 the value of |next_char| need not lie between |bc| and~|ec|.
23878 If the very last instruction of the |lig_kern| array has |skip_byte=255|,
23879 there is a special ligature/kerning program for a left boundary character,
23880 beginning at location |256*op_byte+remainder|.
23881 The interpretation is that \TeX\ puts implicit boundary characters
23882 before and after each consecutive string of characters from the same font.
23883 These implicit characters do not appear in the output, but they can affect
23884 ligatures and kerning.
23886 If the very first instruction of a character's |lig_kern| program has
23887 |skip_byte>128|, the program actually begins in location
23888 |256*op_byte+remainder|. This feature allows access to large |lig_kern|
23889 arrays, because the first instruction must otherwise
23890 appear in a location |<=255|.
23892 Any instruction with |skip_byte>128| in the |lig_kern| array must satisfy
23894 $$\hbox{|256*op_byte+remainder<nl|.}$$
23895 If such an instruction is encountered during
23896 normal program execution, it denotes an unconditional halt; no ligature
23897 command is performed.
23900 /* value indicating `\.{STOP}' in a lig/kern program */
23901 @d kern_flag (128) /* op code for a kern step */
23902 @d skip_byte(A) mp->lig_kern[(A)].b0
23903 @d next_char(A) mp->lig_kern[(A)].b1
23904 @d op_byte(A) mp->lig_kern[(A)].b2
23905 @d rem_byte(A) mp->lig_kern[(A)].b3
23907 @ Extensible characters are specified by an |extensible_recipe|, which
23908 consists of four bytes called |top|, |mid|, |bot|, and |rep| (in this
23909 order). These bytes are the character codes of individual pieces used to
23910 build up a large symbol. If |top|, |mid|, or |bot| are zero, they are not
23911 present in the built-up result. For example, an extensible vertical line is
23912 like an extensible bracket, except that the top and bottom pieces are missing.
23914 Let $T$, $M$, $B$, and $R$ denote the respective pieces, or an empty box
23915 if the piece isn't present. Then the extensible characters have the form
23916 $TR^kMR^kB$ from top to bottom, for some |k>=0|, unless $M$ is absent;
23917 in the latter case we can have $TR^kB$ for both even and odd values of~|k|.
23918 The width of the extensible character is the width of $R$; and the
23919 height-plus-depth is the sum of the individual height-plus-depths of the
23920 components used, since the pieces are butted together in a vertical list.
23922 @d ext_top(A) mp->exten[(A)].b0 /* |top| piece in a recipe */
23923 @d ext_mid(A) mp->exten[(A)].b1 /* |mid| piece in a recipe */
23924 @d ext_bot(A) mp->exten[(A)].b2 /* |bot| piece in a recipe */
23925 @d ext_rep(A) mp->exten[(A)].b3 /* |rep| piece in a recipe */
23927 @ The final portion of a \.{TFM} file is the |param| array, which is another
23928 sequence of |fix_word| values.
23930 \yskip\hang|param[1]=slant| is the amount of italic slant, which is used
23931 to help position accents. For example, |slant=.25| means that when you go
23932 up one unit, you also go .25 units to the right. The |slant| is a pure
23933 number; it is the only |fix_word| other than the design size itself that is
23934 not scaled by the design size.
23937 \hang|param[2]=space| is the normal spacing between words in text.
23938 Note that character 040 in the font need not have anything to do with
23941 \hang|param[3]=space_stretch| is the amount of glue stretching between words.
23943 \hang|param[4]=space_shrink| is the amount of glue shrinking between words.
23945 \hang|param[5]=x_height| is the size of one ex in the font; it is also
23946 the height of letters for which accents don't have to be raised or lowered.
23948 \hang|param[6]=quad| is the size of one em in the font.
23950 \hang|param[7]=extra_space| is the amount added to |param[2]| at the
23954 If fewer than seven parameters are present, \TeX\ sets the missing parameters
23959 @d space_stretch_code 3
23960 @d space_shrink_code 4
23963 @d extra_space_code 7
23965 @ So that is what \.{TFM} files hold. One of \MP's duties is to output such
23966 information, and it does this all at once at the end of a job.
23967 In order to prepare for such frenetic activity, it squirrels away the
23968 necessary facts in various arrays as information becomes available.
23970 Character dimensions (\&{charwd}, \&{charht}, \&{chardp}, and \&{charic})
23971 are stored respectively in |tfm_width|, |tfm_height|, |tfm_depth|, and
23972 |tfm_ital_corr|. Other information about a character (e.g., about
23973 its ligatures or successors) is accessible via the |char_tag| and
23974 |char_remainder| arrays. Other information about the font as a whole
23975 is kept in additional arrays called |header_byte|, |lig_kern|,
23976 |kern|, |exten|, and |param|.
23978 @d max_tfm_int 32510
23979 @d undefined_label max_tfm_int /* an undefined local label */
23982 #define TFM_ITEMS 257
23984 eight_bits ec; /* smallest and largest character codes shipped out */
23985 scaled tfm_width[TFM_ITEMS]; /* \&{charwd} values */
23986 scaled tfm_height[TFM_ITEMS]; /* \&{charht} values */
23987 scaled tfm_depth[TFM_ITEMS]; /* \&{chardp} values */
23988 scaled tfm_ital_corr[TFM_ITEMS]; /* \&{charic} values */
23989 boolean char_exists[TFM_ITEMS]; /* has this code been shipped out? */
23990 int char_tag[TFM_ITEMS]; /* |remainder| category */
23991 int char_remainder[TFM_ITEMS]; /* the |remainder| byte */
23992 char *header_byte; /* bytes of the \.{TFM} header */
23993 int header_last; /* last initialized \.{TFM} header byte */
23994 int header_size; /* size of the \.{TFM} header */
23995 four_quarters *lig_kern; /* the ligature/kern table */
23996 short nl; /* the number of ligature/kern steps so far */
23997 scaled *kern; /* distinct kerning amounts */
23998 short nk; /* the number of distinct kerns so far */
23999 four_quarters exten[TFM_ITEMS]; /* extensible character recipes */
24000 short ne; /* the number of extensible characters so far */
24001 scaled *param; /* \&{fontinfo} parameters */
24002 short np; /* the largest \&{fontinfo} parameter specified so far */
24003 short nw;short nh;short nd;short ni; /* sizes of \.{TFM} subtables */
24004 short skip_table[TFM_ITEMS]; /* local label status */
24005 boolean lk_started; /* has there been a lig/kern step in this command yet? */
24006 integer bchar; /* right boundary character */
24007 short bch_label; /* left boundary starting location */
24008 short ll;short lll; /* registers used for lig/kern processing */
24009 short label_loc[257]; /* lig/kern starting addresses */
24010 eight_bits label_char[257]; /* characters for |label_loc| */
24011 short label_ptr; /* highest position occupied in |label_loc| */
24013 @ @<Allocate or initialize ...@>=
24014 mp->header_size = 128; /* just for init */
24015 mp->header_byte = xmalloc(mp->header_size, sizeof(char));
24017 @ @<Dealloc variables@>=
24018 xfree(mp->header_byte);
24019 xfree(mp->lig_kern);
24024 for (k=0;k<= 255;k++ ) {
24025 mp->tfm_width[k]=0; mp->tfm_height[k]=0; mp->tfm_depth[k]=0; mp->tfm_ital_corr[k]=0;
24026 mp->char_exists[k]=false; mp->char_tag[k]=no_tag; mp->char_remainder[k]=0;
24027 mp->skip_table[k]=undefined_label;
24029 memset(mp->header_byte,0,mp->header_size);
24030 mp->bc=255; mp->ec=0; mp->nl=0; mp->nk=0; mp->ne=0; mp->np=0;
24031 mp->internal[mp_boundary_char]=-unity;
24032 mp->bch_label=undefined_label;
24033 mp->label_loc[0]=-1; mp->label_ptr=0;
24035 @ @<Declarations@>=
24036 scaled mp_tfm_check (MP mp,small_number m) ;
24038 @ @<Declare the function called |tfm_check|@>=
24039 scaled mp_tfm_check (MP mp,small_number m) {
24040 if ( abs(mp->internal[m])>=fraction_half ) {
24041 print_err("Enormous "); mp_print(mp, mp->int_name[m]);
24042 @.Enormous charwd...@>
24043 @.Enormous chardp...@>
24044 @.Enormous charht...@>
24045 @.Enormous charic...@>
24046 @.Enormous designsize...@>
24047 mp_print(mp, " has been reduced");
24048 help1("Font metric dimensions must be less than 2048pt.");
24049 mp_put_get_error(mp);
24050 if ( mp->internal[m]>0 ) return (fraction_half-1);
24051 else return (1-fraction_half);
24053 return mp->internal[m];
24057 @ @<Store the width information for character code~|c|@>=
24058 if ( c<mp->bc ) mp->bc=c;
24059 if ( c>mp->ec ) mp->ec=c;
24060 mp->char_exists[c]=true;
24061 mp->tfm_width[c]=mp_tfm_check(mp,mp_char_wd);
24062 mp->tfm_height[c]=mp_tfm_check(mp, mp_char_ht);
24063 mp->tfm_depth[c]=mp_tfm_check(mp, mp_char_dp);
24064 mp->tfm_ital_corr[c]=mp_tfm_check(mp, mp_char_ic)
24066 @ Now let's consider \MP's special \.{TFM}-oriented commands.
24068 @<Cases of |do_statement|...@>=
24069 case tfm_command: mp_do_tfm_command(mp); break;
24071 @ @d char_list_code 0
24072 @d lig_table_code 1
24073 @d extensible_code 2
24074 @d header_byte_code 3
24075 @d font_dimen_code 4
24078 mp_primitive(mp, "charlist",tfm_command,char_list_code);
24079 @:char_list_}{\&{charlist} primitive@>
24080 mp_primitive(mp, "ligtable",tfm_command,lig_table_code);
24081 @:lig_table_}{\&{ligtable} primitive@>
24082 mp_primitive(mp, "extensible",tfm_command,extensible_code);
24083 @:extensible_}{\&{extensible} primitive@>
24084 mp_primitive(mp, "headerbyte",tfm_command,header_byte_code);
24085 @:header_byte_}{\&{headerbyte} primitive@>
24086 mp_primitive(mp, "fontdimen",tfm_command,font_dimen_code);
24087 @:font_dimen_}{\&{fontdimen} primitive@>
24089 @ @<Cases of |print_cmd...@>=
24092 case char_list_code:mp_print(mp, "charlist"); break;
24093 case lig_table_code:mp_print(mp, "ligtable"); break;
24094 case extensible_code:mp_print(mp, "extensible"); break;
24095 case header_byte_code:mp_print(mp, "headerbyte"); break;
24096 default: mp_print(mp, "fontdimen"); break;
24100 @ @<Declare action procedures for use by |do_statement|@>=
24101 eight_bits mp_get_code (MP mp) ;
24103 @ @c eight_bits mp_get_code (MP mp) { /* scans a character code value */
24104 integer c; /* the code value found */
24105 mp_get_x_next(mp); mp_scan_expression(mp);
24106 if ( mp->cur_type==mp_known ) {
24107 c=mp_round_unscaled(mp, mp->cur_exp);
24108 if ( c>=0 ) if ( c<256 ) return c;
24109 } else if ( mp->cur_type==mp_string_type ) {
24110 if ( length(mp->cur_exp)==1 ) {
24111 c=mp->str_pool[mp->str_start[mp->cur_exp]];
24115 exp_err("Invalid code has been replaced by 0");
24116 @.Invalid code...@>
24117 help2("I was looking for a number between 0 and 255, or for a")
24118 ("string of length 1. Didn't find it; will use 0 instead.");
24119 mp_put_get_flush_error(mp, 0); c=0;
24123 @ @<Declare action procedures for use by |do_statement|@>=
24124 void mp_set_tag (MP mp,halfword c, small_number t, halfword r) ;
24126 @ @c void mp_set_tag (MP mp,halfword c, small_number t, halfword r) {
24127 if ( mp->char_tag[c]==no_tag ) {
24128 mp->char_tag[c]=t; mp->char_remainder[c]=r;
24130 incr(mp->label_ptr); mp->label_loc[mp->label_ptr]=r;
24131 mp->label_char[mp->label_ptr]=c;
24134 @<Complain about a character tag conflict@>;
24138 @ @<Complain about a character tag conflict@>=
24140 print_err("Character ");
24141 if ( (c>' ')&&(c<127) ) mp_print_char(mp,c);
24142 else if ( c==256 ) mp_print(mp, "||");
24143 else { mp_print(mp, "code "); mp_print_int(mp, c); };
24144 mp_print(mp, " is already ");
24145 @.Character c is already...@>
24146 switch (mp->char_tag[c]) {
24147 case lig_tag: mp_print(mp, "in a ligtable"); break;
24148 case list_tag: mp_print(mp, "in a charlist"); break;
24149 case ext_tag: mp_print(mp, "extensible"); break;
24150 } /* there are no other cases */
24151 help2("It's not legal to label a character more than once.")
24152 ("So I'll not change anything just now.");
24153 mp_put_get_error(mp);
24156 @ @<Declare action procedures for use by |do_statement|@>=
24157 void mp_do_tfm_command (MP mp) ;
24159 @ @c void mp_do_tfm_command (MP mp) {
24160 int c,cc; /* character codes */
24161 int k; /* index into the |kern| array */
24162 int j; /* index into |header_byte| or |param| */
24163 switch (mp->cur_mod) {
24164 case char_list_code:
24166 /* we will store a list of character successors */
24167 while ( mp->cur_cmd==colon ) {
24168 cc=mp_get_code(mp); mp_set_tag(mp, c,list_tag,cc); c=cc;
24171 case lig_table_code:
24172 if (mp->lig_kern==NULL)
24173 mp->lig_kern = xmalloc((max_tfm_int+1),sizeof(four_quarters));
24174 if (mp->kern==NULL)
24175 mp->kern = xmalloc((max_tfm_int+1),sizeof(scaled));
24176 @<Store a list of ligature/kern steps@>;
24178 case extensible_code:
24179 @<Define an extensible recipe@>;
24181 case header_byte_code:
24182 case font_dimen_code:
24183 c=mp->cur_mod; mp_get_x_next(mp);
24184 mp_scan_expression(mp);
24185 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<half_unit) ) {
24186 exp_err("Improper location");
24187 @.Improper location@>
24188 help2("I was looking for a known, positive number.")
24189 ("For safety's sake I'll ignore the present command.");
24190 mp_put_get_error(mp);
24192 j=mp_round_unscaled(mp, mp->cur_exp);
24193 if ( mp->cur_cmd!=colon ) {
24194 mp_missing_err(mp, ":");
24196 help1("A colon should follow a headerbyte or fontinfo location.");
24199 if ( c==header_byte_code ) {
24200 @<Store a list of header bytes@>;
24202 if (mp->param==NULL)
24203 mp->param = xmalloc((max_tfm_int+1),sizeof(scaled));
24204 @<Store a list of font dimensions@>;
24208 } /* there are no other cases */
24211 @ @<Store a list of ligature/kern steps@>=
24213 mp->lk_started=false;
24216 if ((mp->cur_cmd==skip_to)&& mp->lk_started )
24217 @<Process a |skip_to| command and |goto done|@>;
24218 if ( mp->cur_cmd==bchar_label ) { c=256; mp->cur_cmd=colon; }
24219 else { mp_back_input(mp); c=mp_get_code(mp); };
24220 if ((mp->cur_cmd==colon)||(mp->cur_cmd==double_colon)) {
24221 @<Record a label in a lig/kern subprogram and |goto continue|@>;
24223 if ( mp->cur_cmd==lig_kern_token ) {
24224 @<Compile a ligature/kern command@>;
24226 print_err("Illegal ligtable step");
24227 @.Illegal ligtable step@>
24228 help1("I was looking for `=:' or `kern' here.");
24229 mp_back_error(mp); next_char(mp->nl)=qi(0);
24230 op_byte(mp->nl)=qi(0); rem_byte(mp->nl)=qi(0);
24231 skip_byte(mp->nl)=stop_flag+1; /* this specifies an unconditional stop */
24233 if ( mp->nl==max_tfm_int) mp_fatal_error(mp, "ligtable too large");
24235 if ( mp->cur_cmd==comma ) goto CONTINUE;
24236 if ( skip_byte(mp->nl-1)<stop_flag ) skip_byte(mp->nl-1)=stop_flag;
24241 mp_primitive(mp, "=:",lig_kern_token,0);
24242 @:=:_}{\.{=:} primitive@>
24243 mp_primitive(mp, "=:|",lig_kern_token,1);
24244 @:=:/_}{\.{=:\char'174} primitive@>
24245 mp_primitive(mp, "=:|>",lig_kern_token,5);
24246 @:=:/>_}{\.{=:\char'174>} primitive@>
24247 mp_primitive(mp, "|=:",lig_kern_token,2);
24248 @:=:/_}{\.{\char'174=:} primitive@>
24249 mp_primitive(mp, "|=:>",lig_kern_token,6);
24250 @:=:/>_}{\.{\char'174=:>} primitive@>
24251 mp_primitive(mp, "|=:|",lig_kern_token,3);
24252 @:=:/_}{\.{\char'174=:\char'174} primitive@>
24253 mp_primitive(mp, "|=:|>",lig_kern_token,7);
24254 @:=:/>_}{\.{\char'174=:\char'174>} primitive@>
24255 mp_primitive(mp, "|=:|>>",lig_kern_token,11);
24256 @:=:/>_}{\.{\char'174=:\char'174>>} primitive@>
24257 mp_primitive(mp, "kern",lig_kern_token,128);
24258 @:kern_}{\&{kern} primitive@>
24260 @ @<Cases of |print_cmd...@>=
24261 case lig_kern_token:
24263 case 0:mp_print(mp, "=:"); break;
24264 case 1:mp_print(mp, "=:|"); break;
24265 case 2:mp_print(mp, "|=:"); break;
24266 case 3:mp_print(mp, "|=:|"); break;
24267 case 5:mp_print(mp, "=:|>"); break;
24268 case 6:mp_print(mp, "|=:>"); break;
24269 case 7:mp_print(mp, "|=:|>"); break;
24270 case 11:mp_print(mp, "|=:|>>"); break;
24271 default: mp_print(mp, "kern"); break;
24275 @ Local labels are implemented by maintaining the |skip_table| array,
24276 where |skip_table[c]| is either |undefined_label| or the address of the
24277 most recent lig/kern instruction that skips to local label~|c|. In the
24278 latter case, the |skip_byte| in that instruction will (temporarily)
24279 be zero if there were no prior skips to this label, or it will be the
24280 distance to the prior skip.
24282 We may need to cancel skips that span more than 127 lig/kern steps.
24284 @d cancel_skips(A) mp->ll=(A);
24286 mp->lll=qo(skip_byte(mp->ll));
24287 skip_byte(mp->ll)=stop_flag; mp->ll=mp->ll-mp->lll;
24288 } while (mp->lll!=0)
24289 @d skip_error(A) { print_err("Too far to skip");
24290 @.Too far to skip@>
24291 help1("At most 127 lig/kern steps can separate skipto1 from 1::.");
24292 mp_error(mp); cancel_skips((A));
24295 @<Process a |skip_to| command and |goto done|@>=
24298 if ( mp->nl-mp->skip_table[c]>128 ) {
24299 skip_error(mp->skip_table[c]); mp->skip_table[c]=undefined_label;
24301 if ( mp->skip_table[c]==undefined_label ) skip_byte(mp->nl-1)=qi(0);
24302 else skip_byte(mp->nl-1)=qi(mp->nl-mp->skip_table[c]-1);
24303 mp->skip_table[c]=mp->nl-1; goto DONE;
24306 @ @<Record a label in a lig/kern subprogram and |goto continue|@>=
24308 if ( mp->cur_cmd==colon ) {
24309 if ( c==256 ) mp->bch_label=mp->nl;
24310 else mp_set_tag(mp, c,lig_tag,mp->nl);
24311 } else if ( mp->skip_table[c]<undefined_label ) {
24312 mp->ll=mp->skip_table[c]; mp->skip_table[c]=undefined_label;
24314 mp->lll=qo(skip_byte(mp->ll));
24315 if ( mp->nl-mp->ll>128 ) {
24316 skip_error(mp->ll); goto CONTINUE;
24318 skip_byte(mp->ll)=qi(mp->nl-mp->ll-1); mp->ll=mp->ll-mp->lll;
24319 } while (mp->lll!=0);
24324 @ @<Compile a ligature/kern...@>=
24326 next_char(mp->nl)=qi(c); skip_byte(mp->nl)=qi(0);
24327 if ( mp->cur_mod<128 ) { /* ligature op */
24328 op_byte(mp->nl)=qi(mp->cur_mod); rem_byte(mp->nl)=qi(mp_get_code(mp));
24330 mp_get_x_next(mp); mp_scan_expression(mp);
24331 if ( mp->cur_type!=mp_known ) {
24332 exp_err("Improper kern");
24334 help2("The amount of kern should be a known numeric value.")
24335 ("I'm zeroing this one. Proceed, with fingers crossed.");
24336 mp_put_get_flush_error(mp, 0);
24338 mp->kern[mp->nk]=mp->cur_exp;
24340 while ( mp->kern[k]!=mp->cur_exp ) incr(k);
24342 if ( mp->nk==max_tfm_int ) mp_fatal_error(mp, "too many TFM kerns");
24345 op_byte(mp->nl)=kern_flag+(k / 256);
24346 rem_byte(mp->nl)=qi((k % 256));
24348 mp->lk_started=true;
24351 @ @d missing_extensible_punctuation(A)
24352 { mp_missing_err(mp, (A));
24353 @.Missing `\char`\#'@>
24354 help1("I'm processing `extensible c: t,m,b,r'."); mp_back_error(mp);
24357 @<Define an extensible recipe@>=
24359 if ( mp->ne==256 ) mp_fatal_error(mp, "too many extensible recipies");
24360 c=mp_get_code(mp); mp_set_tag(mp, c,ext_tag,mp->ne);
24361 if ( mp->cur_cmd!=colon ) missing_extensible_punctuation(":");
24362 ext_top(mp->ne)=qi(mp_get_code(mp));
24363 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
24364 ext_mid(mp->ne)=qi(mp_get_code(mp));
24365 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
24366 ext_bot(mp->ne)=qi(mp_get_code(mp));
24367 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
24368 ext_rep(mp->ne)=qi(mp_get_code(mp));
24372 @ The header could contain ASCII zeroes, so can't use |strdup|.
24374 @<Store a list of header bytes@>=
24376 if ( j>=mp->header_size ) {
24377 int l = mp->header_size + (mp->header_size >> 2);
24378 char *t = xmalloc(l,sizeof(char));
24380 memcpy(t,mp->header_byte,mp->header_size);
24381 xfree (mp->header_byte);
24382 mp->header_byte = t;
24383 mp->header_size = l;
24385 mp->header_byte[j]=mp_get_code(mp);
24386 incr(j); incr(mp->header_last);
24387 } while (mp->cur_cmd==comma)
24389 @ @<Store a list of font dimensions@>=
24391 if ( j>max_tfm_int ) mp_fatal_error(mp, "too many fontdimens");
24392 while ( j>mp->np ) { incr(mp->np); mp->param[mp->np]=0; };
24393 mp_get_x_next(mp); mp_scan_expression(mp);
24394 if ( mp->cur_type!=mp_known ){
24395 exp_err("Improper font parameter");
24396 @.Improper font parameter@>
24397 help1("I'm zeroing this one. Proceed, with fingers crossed.");
24398 mp_put_get_flush_error(mp, 0);
24400 mp->param[j]=mp->cur_exp; incr(j);
24401 } while (mp->cur_cmd==comma)
24403 @ OK: We've stored all the data that is needed for the \.{TFM} file.
24404 All that remains is to output it in the correct format.
24406 An interesting problem needs to be solved in this connection, because
24407 the \.{TFM} format allows at most 256~widths, 16~heights, 16~depths,
24408 and 64~italic corrections. If the data has more distinct values than
24409 this, we want to meet the necessary restrictions by perturbing the
24410 given values as little as possible.
24412 \MP\ solves this problem in two steps. First the values of a given
24413 kind (widths, heights, depths, or italic corrections) are sorted;
24414 then the list of sorted values is perturbed, if necessary.
24416 The sorting operation is facilitated by having a special node of
24417 essentially infinite |value| at the end of the current list.
24419 @<Initialize table entries...@>=
24420 value(inf_val)=fraction_four;
24422 @ Straight linear insertion is good enough for sorting, since the lists
24423 are usually not terribly long. As we work on the data, the current list
24424 will start at |link(temp_head)| and end at |inf_val|; the nodes in this
24425 list will be in increasing order of their |value| fields.
24427 Given such a list, the |sort_in| function takes a value and returns a pointer
24428 to where that value can be found in the list. The value is inserted in
24429 the proper place, if necessary.
24431 At the time we need to do these operations, most of \MP's work has been
24432 completed, so we will have plenty of memory to play with. The value nodes
24433 that are allocated for sorting will never be returned to free storage.
24435 @d clear_the_list link(temp_head)=inf_val
24437 @c pointer mp_sort_in (MP mp,scaled v) {
24438 pointer p,q,r; /* list manipulation registers */
24442 if ( v<=value(q) ) break;
24445 if ( v<value(q) ) {
24446 r=mp_get_node(mp, value_node_size); value(r)=v; link(r)=q; link(p)=r;
24451 @ Now we come to the interesting part, where we reduce the list if necessary
24452 until it has the required size. The |min_cover| routine is basic to this
24453 process; it computes the minimum number~|m| such that the values of the
24454 current sorted list can be covered by |m|~intervals of width~|d|. It
24455 also sets the global value |perturbation| to the smallest value $d'>d$
24456 such that the covering found by this algorithm would be different.
24458 In particular, |min_cover(0)| returns the number of distinct values in the
24459 current list and sets |perturbation| to the minimum distance between
24462 @c integer mp_min_cover (MP mp,scaled d) {
24463 pointer p; /* runs through the current list */
24464 scaled l; /* the least element covered by the current interval */
24465 integer m; /* lower bound on the size of the minimum cover */
24466 m=0; p=link(temp_head); mp->perturbation=el_gordo;
24467 while ( p!=inf_val ){
24468 incr(m); l=value(p);
24469 do { p=link(p); } while (value(p)<=l+d);
24470 if ( value(p)-l<mp->perturbation )
24471 mp->perturbation=value(p)-l;
24477 scaled perturbation; /* quantity related to \.{TFM} rounding */
24478 integer excess; /* the list is this much too long */
24480 @ The smallest |d| such that a given list can be covered with |m| intervals
24481 is determined by the |threshold| routine, which is sort of an inverse
24482 to |min_cover|. The idea is to increase the interval size rapidly until
24483 finding the range, then to go sequentially until the exact borderline has
24486 @c scaled mp_threshold (MP mp,integer m) {
24487 scaled d; /* lower bound on the smallest interval size */
24488 mp->excess=mp_min_cover(mp, 0)-m;
24489 if ( mp->excess<=0 ) {
24493 d=mp->perturbation;
24494 } while (mp_min_cover(mp, d+d)>m);
24495 while ( mp_min_cover(mp, d)>m )
24496 d=mp->perturbation;
24501 @ The |skimp| procedure reduces the current list to at most |m| entries,
24502 by changing values if necessary. It also sets |info(p):=k| if |value(p)|
24503 is the |k|th distinct value on the resulting list, and it sets
24504 |perturbation| to the maximum amount by which a |value| field has
24505 been changed. The size of the resulting list is returned as the
24508 @c integer mp_skimp (MP mp,integer m) {
24509 scaled d; /* the size of intervals being coalesced */
24510 pointer p,q,r; /* list manipulation registers */
24511 scaled l; /* the least value in the current interval */
24512 scaled v; /* a compromise value */
24513 d=mp_threshold(mp, m); mp->perturbation=0;
24514 q=temp_head; m=0; p=link(temp_head);
24515 while ( p!=inf_val ) {
24516 incr(m); l=value(p); info(p)=m;
24517 if ( value(link(p))<=l+d ) {
24518 @<Replace an interval of values by its midpoint@>;
24525 @ @<Replace an interval...@>=
24528 p=link(p); info(p)=m;
24529 decr(mp->excess); if ( mp->excess==0 ) d=0;
24530 } while (value(link(p))<=l+d);
24531 v=l+halfp(value(p)-l);
24532 if ( value(p)-v>mp->perturbation )
24533 mp->perturbation=value(p)-v;
24536 r=link(r); value(r)=v;
24538 link(q)=p; /* remove duplicate values from the current list */
24541 @ A warning message is issued whenever something is perturbed by
24542 more than 1/16\thinspace pt.
24544 @c void mp_tfm_warning (MP mp,small_number m) {
24545 mp_print_nl(mp, "(some ");
24546 mp_print(mp, mp->int_name[m]);
24547 @.some charwds...@>
24548 @.some chardps...@>
24549 @.some charhts...@>
24550 @.some charics...@>
24551 mp_print(mp, " values had to be adjusted by as much as ");
24552 mp_print_scaled(mp, mp->perturbation); mp_print(mp, "pt)");
24555 @ Here's an example of how we use these routines.
24556 The width data needs to be perturbed only if there are 256 distinct
24557 widths, but \MP\ must check for this case even though it is
24560 An integer variable |k| will be defined when we use this code.
24561 The |dimen_head| array will contain pointers to the sorted
24562 lists of dimensions.
24564 @<Massage the \.{TFM} widths@>=
24566 for (k=mp->bc;k<=mp->ec;k++) {
24567 if ( mp->char_exists[k] )
24568 mp->tfm_width[k]=mp_sort_in(mp, mp->tfm_width[k]);
24570 mp->nw=mp_skimp(mp, 255)+1; mp->dimen_head[1]=link(temp_head);
24571 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_wd)
24574 pointer dimen_head[5]; /* lists of \.{TFM} dimensions */
24576 @ Heights, depths, and italic corrections are different from widths
24577 not only because their list length is more severely restricted, but
24578 also because zero values do not need to be put into the lists.
24580 @<Massage the \.{TFM} heights, depths, and italic corrections@>=
24582 for (k=mp->bc;k<=mp->ec;k++) {
24583 if ( mp->char_exists[k] ) {
24584 if ( mp->tfm_height[k]==0 ) mp->tfm_height[k]=zero_val;
24585 else mp->tfm_height[k]=mp_sort_in(mp, mp->tfm_height[k]);
24588 mp->nh=mp_skimp(mp, 15)+1; mp->dimen_head[2]=link(temp_head);
24589 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_ht);
24591 for (k=mp->bc;k<=mp->ec;k++) {
24592 if ( mp->char_exists[k] ) {
24593 if ( mp->tfm_depth[k]==0 ) mp->tfm_depth[k]=zero_val;
24594 else mp->tfm_depth[k]=mp_sort_in(mp, mp->tfm_depth[k]);
24597 mp->nd=mp_skimp(mp, 15)+1; mp->dimen_head[3]=link(temp_head);
24598 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_dp);
24600 for (k=mp->bc;k<=mp->ec;k++) {
24601 if ( mp->char_exists[k] ) {
24602 if ( mp->tfm_ital_corr[k]==0 ) mp->tfm_ital_corr[k]=zero_val;
24603 else mp->tfm_ital_corr[k]=mp_sort_in(mp, mp->tfm_ital_corr[k]);
24606 mp->ni=mp_skimp(mp, 63)+1; mp->dimen_head[4]=link(temp_head);
24607 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_ic)
24609 @ @<Initialize table entries...@>=
24610 value(zero_val)=0; info(zero_val)=0;
24612 @ Bytes 5--8 of the header are set to the design size, unless the user has
24613 some crazy reason for specifying them differently.
24616 Error messages are not allowed at the time this procedure is called,
24617 so a warning is printed instead.
24619 The value of |max_tfm_dimen| is calculated so that
24620 $$\hbox{|make_scaled(16*max_tfm_dimen,internal[mp_design_size])|}
24621 < \\{three\_bytes}.$$
24623 @d three_bytes 0100000000 /* $2^{24}$ */
24626 void mp_fix_design_size (MP mp) {
24627 scaled d; /* the design size */
24628 d=mp->internal[mp_design_size];
24629 if ( (d<unity)||(d>=fraction_half) ) {
24631 mp_print_nl(mp, "(illegal design size has been changed to 128pt)");
24632 @.illegal design size...@>
24633 d=040000000; mp->internal[mp_design_size]=d;
24635 if ( mp->header_byte[4]<0 ) if ( mp->header_byte[5]<0 )
24636 if ( mp->header_byte[6]<0 ) if ( mp->header_byte[7]<0 ) {
24637 mp->header_byte[4]=d / 04000000;
24638 mp->header_byte[5]=(d / 4096) % 256;
24639 mp->header_byte[6]=(d / 16) % 256;
24640 mp->header_byte[7]=(d % 16)*16;
24642 mp->max_tfm_dimen=16*mp->internal[mp_design_size]-1-mp->internal[mp_design_size] / 010000000;
24643 if ( mp->max_tfm_dimen>=fraction_half ) mp->max_tfm_dimen=fraction_half-1;
24646 @ The |dimen_out| procedure computes a |fix_word| relative to the
24647 design size. If the data was out of range, it is corrected and the
24648 global variable |tfm_changed| is increased by~one.
24650 @c integer mp_dimen_out (MP mp,scaled x) {
24651 if ( abs(x)>mp->max_tfm_dimen ) {
24652 incr(mp->tfm_changed);
24653 if ( x>0 ) x=mp->max_tfm_dimen; else x=-mp->max_tfm_dimen;
24655 x=mp_make_scaled(mp, x*16,mp->internal[mp_design_size]);
24660 scaled max_tfm_dimen; /* bound on widths, heights, kerns, etc. */
24661 integer tfm_changed; /* the number of data entries that were out of bounds */
24663 @ If the user has not specified any of the first four header bytes,
24664 the |fix_check_sum| procedure replaces them by a ``check sum'' computed
24665 from the |tfm_width| data relative to the design size.
24668 @c void mp_fix_check_sum (MP mp) {
24669 eight_bits k; /* runs through character codes */
24670 eight_bits B1,B2,B3,B4; /* bytes of the check sum */
24671 integer x; /* hash value used in check sum computation */
24672 if ( mp->header_byte[0]==0 && mp->header_byte[1]==0 &&
24673 mp->header_byte[2]==0 && mp->header_byte[3]==0 ) {
24674 @<Compute a check sum in |(b1,b2,b3,b4)|@>;
24675 mp->header_byte[0]=B1; mp->header_byte[1]=B2;
24676 mp->header_byte[2]=B3; mp->header_byte[3]=B4;
24681 @ @<Compute a check sum in |(b1,b2,b3,b4)|@>=
24682 B1=mp->bc; B2=mp->ec; B3=mp->bc; B4=mp->ec; mp->tfm_changed=0;
24683 for (k=mp->bc;k<=mp->ec;k++) {
24684 if ( mp->char_exists[k] ) {
24685 x=mp_dimen_out(mp, value(mp->tfm_width[k]))+(k+4)*020000000; /* this is positive */
24686 B1=(B1+B1+x) % 255;
24687 B2=(B2+B2+x) % 253;
24688 B3=(B3+B3+x) % 251;
24689 B4=(B4+B4+x) % 247;
24693 @ Finally we're ready to actually write the \.{TFM} information.
24694 Here are some utility routines for this purpose.
24696 @d tfm_out(A) do { /* output one byte to |tfm_file| */
24697 unsigned char s=(A);
24698 (mp->write_binary_file)(mp,mp->tfm_file,(void *)&s,1);
24701 @c void mp_tfm_two (MP mp,integer x) { /* output two bytes to |tfm_file| */
24702 tfm_out(x / 256); tfm_out(x % 256);
24704 void mp_tfm_four (MP mp,integer x) { /* output four bytes to |tfm_file| */
24705 if ( x>=0 ) tfm_out(x / three_bytes);
24707 x=x+010000000000; /* use two's complement for negative values */
24709 tfm_out((x / three_bytes) + 128);
24711 x=x % three_bytes; tfm_out(x / unity);
24712 x=x % unity; tfm_out(x / 0400);
24715 void mp_tfm_qqqq (MP mp,four_quarters x) { /* output four quarterwords to |tfm_file| */
24716 tfm_out(qo(x.b0)); tfm_out(qo(x.b1));
24717 tfm_out(qo(x.b2)); tfm_out(qo(x.b3));
24720 @ @<Finish the \.{TFM} file@>=
24721 if ( mp->job_name==NULL ) mp_open_log_file(mp);
24722 mp_pack_job_name(mp, ".tfm");
24723 while ( ! mp_b_open_out(mp, &mp->tfm_file, mp_filetype_metrics) )
24724 mp_prompt_file_name(mp, "file name for font metrics",".tfm");
24725 mp->metric_file_name=xstrdup(mp->name_of_file);
24726 @<Output the subfile sizes and header bytes@>;
24727 @<Output the character information bytes, then
24728 output the dimensions themselves@>;
24729 @<Output the ligature/kern program@>;
24730 @<Output the extensible character recipes and the font metric parameters@>;
24731 if ( mp->internal[mp_tracing_stats]>0 )
24732 @<Log the subfile sizes of the \.{TFM} file@>;
24733 mp_print_nl(mp, "Font metrics written on ");
24734 mp_print(mp, mp->metric_file_name); mp_print_char(mp, '.');
24735 @.Font metrics written...@>
24736 (mp->close_file)(mp,mp->tfm_file)
24738 @ Integer variables |lh|, |k|, and |lk_offset| will be defined when we use
24741 @<Output the subfile sizes and header bytes@>=
24743 LH=(k+3) / 4; /* this is the number of header words */
24744 if ( mp->bc>mp->ec ) mp->bc=1; /* if there are no characters, |ec=0| and |bc=1| */
24745 @<Compute the ligature/kern program offset and implant the
24746 left boundary label@>;
24747 mp_tfm_two(mp,6+LH+(mp->ec-mp->bc+1)+mp->nw+mp->nh+mp->nd+mp->ni+mp->nl
24748 +lk_offset+mp->nk+mp->ne+mp->np);
24749 /* this is the total number of file words that will be output */
24750 mp_tfm_two(mp, LH); mp_tfm_two(mp, mp->bc); mp_tfm_two(mp, mp->ec);
24751 mp_tfm_two(mp, mp->nw); mp_tfm_two(mp, mp->nh);
24752 mp_tfm_two(mp, mp->nd); mp_tfm_two(mp, mp->ni); mp_tfm_two(mp, mp->nl+lk_offset);
24753 mp_tfm_two(mp, mp->nk); mp_tfm_two(mp, mp->ne);
24754 mp_tfm_two(mp, mp->np);
24755 for (k=0;k< 4*LH;k++) {
24756 tfm_out(mp->header_byte[k]);
24759 @ @<Output the character information bytes...@>=
24760 for (k=mp->bc;k<=mp->ec;k++) {
24761 if ( ! mp->char_exists[k] ) {
24762 mp_tfm_four(mp, 0);
24764 tfm_out(info(mp->tfm_width[k])); /* the width index */
24765 tfm_out((info(mp->tfm_height[k]))*16+info(mp->tfm_depth[k]));
24766 tfm_out((info(mp->tfm_ital_corr[k]))*4+mp->char_tag[k]);
24767 tfm_out(mp->char_remainder[k]);
24771 for (k=1;k<=4;k++) {
24772 mp_tfm_four(mp, 0); p=mp->dimen_head[k];
24773 while ( p!=inf_val ) {
24774 mp_tfm_four(mp, mp_dimen_out(mp, value(p))); p=link(p);
24779 @ We need to output special instructions at the beginning of the
24780 |lig_kern| array in order to specify the right boundary character
24781 and/or to handle starting addresses that exceed 255. The |label_loc|
24782 and |label_char| arrays have been set up to record all the
24783 starting addresses; we have $-1=|label_loc|[0]<|label_loc|[1]\le\cdots
24784 \le|label_loc|[|label_ptr]|$.
24786 @<Compute the ligature/kern program offset...@>=
24787 mp->bchar=mp_round_unscaled(mp, mp->internal[mp_boundary_char]);
24788 if ((mp->bchar<0)||(mp->bchar>255))
24789 { mp->bchar=-1; mp->lk_started=false; lk_offset=0; }
24790 else { mp->lk_started=true; lk_offset=1; };
24791 @<Find the minimum |lk_offset| and adjust all remainders@>;
24792 if ( mp->bch_label<undefined_label )
24793 { skip_byte(mp->nl)=qi(255); next_char(mp->nl)=qi(0);
24794 op_byte(mp->nl)=qi(((mp->bch_label+lk_offset)/ 256));
24795 rem_byte(mp->nl)=qi(((mp->bch_label+lk_offset)% 256));
24796 incr(mp->nl); /* possibly |nl=lig_table_size+1| */
24799 @ @<Find the minimum |lk_offset|...@>=
24800 k=mp->label_ptr; /* pointer to the largest unallocated label */
24801 if ( mp->label_loc[k]+lk_offset>255 ) {
24802 lk_offset=0; mp->lk_started=false; /* location 0 can do double duty */
24804 mp->char_remainder[mp->label_char[k]]=lk_offset;
24805 while ( mp->label_loc[k-1]==mp->label_loc[k] ) {
24806 decr(k); mp->char_remainder[mp->label_char[k]]=lk_offset;
24808 incr(lk_offset); decr(k);
24809 } while (! (lk_offset+mp->label_loc[k]<256));
24810 /* N.B.: |lk_offset=256| satisfies this when |k=0| */
24812 if ( lk_offset>0 ) {
24814 mp->char_remainder[mp->label_char[k]]
24815 =mp->char_remainder[mp->label_char[k]]+lk_offset;
24820 @ @<Output the ligature/kern program@>=
24821 for (k=0;k<= 255;k++ ) {
24822 if ( mp->skip_table[k]<undefined_label ) {
24823 mp_print_nl(mp, "(local label "); mp_print_int(mp, k); mp_print(mp, ":: was missing)");
24824 @.local label l:: was missing@>
24825 cancel_skips(mp->skip_table[k]);
24828 if ( mp->lk_started ) { /* |lk_offset=1| for the special |bchar| */
24829 tfm_out(255); tfm_out(mp->bchar); mp_tfm_two(mp, 0);
24831 for (k=1;k<=lk_offset;k++) {/* output the redirection specs */
24832 mp->ll=mp->label_loc[mp->label_ptr];
24833 if ( mp->bchar<0 ) { tfm_out(254); tfm_out(0); }
24834 else { tfm_out(255); tfm_out(mp->bchar); };
24835 mp_tfm_two(mp, mp->ll+lk_offset);
24837 decr(mp->label_ptr);
24838 } while (! (mp->label_loc[mp->label_ptr]<mp->ll));
24841 for (k=0;k<=mp->nl-1;k++) mp_tfm_qqqq(mp, mp->lig_kern[k]);
24842 for (k=0;k<=mp->nk-1;k++) mp_tfm_four(mp, mp_dimen_out(mp, mp->kern[k]))
24844 @ @<Output the extensible character recipes...@>=
24845 for (k=0;k<=mp->ne-1;k++)
24846 mp_tfm_qqqq(mp, mp->exten[k]);
24847 for (k=1;k<=mp->np;k++) {
24849 if ( abs(mp->param[1])<fraction_half ) {
24850 mp_tfm_four(mp, mp->param[1]*16);
24852 incr(mp->tfm_changed);
24853 if ( mp->param[1]>0 ) mp_tfm_four(mp, el_gordo);
24854 else mp_tfm_four(mp, -el_gordo);
24857 mp_tfm_four(mp, mp_dimen_out(mp, mp->param[k]));
24860 if ( mp->tfm_changed>0 ) {
24861 if ( mp->tfm_changed==1 ) mp_print_nl(mp, "(a font metric dimension");
24862 @.a font metric dimension...@>
24864 mp_print_nl(mp, "("); mp_print_int(mp, mp->tfm_changed);
24865 @.font metric dimensions...@>
24866 mp_print(mp, " font metric dimensions");
24868 mp_print(mp, " had to be decreased)");
24871 @ @<Log the subfile sizes of the \.{TFM} file@>=
24875 if ( mp->bch_label<undefined_label ) decr(mp->nl);
24876 mp_snprintf(s,128,"(You used %iw,%ih,%id,%ii,%il,%ik,%ie,%ip metric file positions)",
24877 mp->nw, mp->nh, mp->nd, mp->ni, mp->nl, mp->nk, mp->ne,mp->np);
24881 @* \[43] Reading font metric data.
24883 \MP\ isn't a typesetting program but it does need to find the bounding box
24884 of a sequence of typeset characters. Thus it needs to read \.{TFM} files as
24885 well as write them.
24890 @ All the width, height, and depth information is stored in an array called
24891 |font_info|. This array is allocated sequentially and each font is stored
24892 as a series of |char_info| words followed by the width, height, and depth
24893 tables. Since |font_name| entries are permanent, their |str_ref| values are
24894 set to |max_str_ref|.
24897 typedef unsigned int font_number; /* |0..font_max| */
24899 @ The |font_info| array is indexed via a group directory arrays.
24900 For example, the |char_info| data for character~|c| in font~|f| will be
24901 in |font_info[char_base[f]+c].qqqq|.
24904 font_number font_max; /* maximum font number for included text fonts */
24905 size_t font_mem_size; /* number of words for \.{TFM} information for text fonts */
24906 memory_word *font_info; /* height, width, and depth data */
24907 char **font_enc_name; /* encoding names, if any */
24908 boolean *font_ps_name_fixed; /* are the postscript names fixed already? */
24909 int next_fmem; /* next unused entry in |font_info| */
24910 font_number last_fnum; /* last font number used so far */
24911 scaled *font_dsize; /* 16 times the ``design'' size in \ps\ points */
24912 char **font_name; /* name as specified in the \&{infont} command */
24913 char **font_ps_name; /* PostScript name for use when |internal[mp_prologues]>0| */
24914 font_number last_ps_fnum; /* last valid |font_ps_name| index */
24915 eight_bits *font_bc;
24916 eight_bits *font_ec; /* first and last character code */
24917 int *char_base; /* base address for |char_info| */
24918 int *width_base; /* index for zeroth character width */
24919 int *height_base; /* index for zeroth character height */
24920 int *depth_base; /* index for zeroth character depth */
24921 pointer *font_sizes;
24923 @ @<Allocate or initialize ...@>=
24924 mp->font_mem_size = 10000;
24925 mp->font_info = xmalloc ((mp->font_mem_size+1),sizeof(memory_word));
24926 memset (mp->font_info,0,sizeof(memory_word)*(mp->font_mem_size+1));
24927 mp->last_fnum = null_font;
24929 @ @<Dealloc variables@>=
24930 for (k=1;k<=(int)mp->last_fnum;k++) {
24931 xfree(mp->font_enc_name[k]);
24932 xfree(mp->font_name[k]);
24933 xfree(mp->font_ps_name[k]);
24935 xfree(mp->font_info);
24936 xfree(mp->font_enc_name);
24937 xfree(mp->font_ps_name_fixed);
24938 xfree(mp->font_dsize);
24939 xfree(mp->font_name);
24940 xfree(mp->font_ps_name);
24941 xfree(mp->font_bc);
24942 xfree(mp->font_ec);
24943 xfree(mp->char_base);
24944 xfree(mp->width_base);
24945 xfree(mp->height_base);
24946 xfree(mp->depth_base);
24947 xfree(mp->font_sizes);
24951 void mp_reallocate_fonts (MP mp, font_number l) {
24953 XREALLOC(mp->font_enc_name, l, char *);
24954 XREALLOC(mp->font_ps_name_fixed, l, boolean);
24955 XREALLOC(mp->font_dsize, l, scaled);
24956 XREALLOC(mp->font_name, l, char *);
24957 XREALLOC(mp->font_ps_name, l, char *);
24958 XREALLOC(mp->font_bc, l, eight_bits);
24959 XREALLOC(mp->font_ec, l, eight_bits);
24960 XREALLOC(mp->char_base, l, int);
24961 XREALLOC(mp->width_base, l, int);
24962 XREALLOC(mp->height_base, l, int);
24963 XREALLOC(mp->depth_base, l, int);
24964 XREALLOC(mp->font_sizes, l, pointer);
24965 for (f=(mp->last_fnum+1);f<=l;f++) {
24966 mp->font_enc_name[f]=NULL;
24967 mp->font_ps_name_fixed[f] = false;
24968 mp->font_name[f]=NULL;
24969 mp->font_ps_name[f]=NULL;
24970 mp->font_sizes[f]=null;
24975 @ @<Declare |mp_reallocate| functions@>=
24976 void mp_reallocate_fonts (MP mp, font_number l);
24979 @ A |null_font| containing no characters is useful for error recovery. Its
24980 |font_name| entry starts out empty but is reset each time an erroneous font is
24981 found. This helps to cut down on the number of duplicate error messages without
24982 wasting a lot of space.
24984 @d null_font 0 /* the |font_number| for an empty font */
24986 @<Set initial...@>=
24987 mp->font_dsize[null_font]=0;
24988 mp->font_bc[null_font]=1;
24989 mp->font_ec[null_font]=0;
24990 mp->char_base[null_font]=0;
24991 mp->width_base[null_font]=0;
24992 mp->height_base[null_font]=0;
24993 mp->depth_base[null_font]=0;
24995 mp->last_fnum=null_font;
24996 mp->last_ps_fnum=null_font;
24997 mp->font_name[null_font]=(char *)"nullfont";
24998 mp->font_ps_name[null_font]=(char *)"";
24999 mp->font_ps_name_fixed[null_font] = false;
25000 mp->font_enc_name[null_font]=NULL;
25001 mp->font_sizes[null_font]=null;
25003 @ Each |char_info| word is of type |four_quarters|. The |b0| field contains
25004 the |width index|; the |b1| field contains the height
25005 index; the |b2| fields contains the depth index, and the |b3| field used only
25006 for temporary storage. (It is used to keep track of which characters occur in
25007 an edge structure that is being shipped out.)
25008 The corresponding words in the width, height, and depth tables are stored as
25009 |scaled| values in units of \ps\ points.
25011 With the macros below, the |char_info| word for character~|c| in font~|f| is
25012 |char_info(f,c)| and the width is
25013 $$\hbox{|char_width(f,char_info(f,c)).sc|.}$$
25015 @d char_info(A,B) mp->font_info[mp->char_base[(A)]+(B)].qqqq
25016 @d char_width(A,B) mp->font_info[mp->width_base[(A)]+(B).b0].sc
25017 @d char_height(A,B) mp->font_info[mp->height_base[(A)]+(B).b1].sc
25018 @d char_depth(A,B) mp->font_info[mp->depth_base[(A)]+(B).b2].sc
25019 @d ichar_exists(A) ((A).b0>0)
25021 @ The |font_ps_name| for a built-in font should be what PostScript expects.
25022 A preliminary name is obtained here from the \.{TFM} name as given in the
25023 |fname| argument. This gets updated later from an external table if necessary.
25025 @<Declare text measuring subroutines@>=
25026 @<Declare subroutines for parsing file names@>
25027 font_number mp_read_font_info (MP mp, char *fname) {
25028 boolean file_opened; /* has |tfm_infile| been opened? */
25029 font_number n; /* the number to return */
25030 halfword lf,tfm_lh,bc,ec,nw,nh,nd; /* subfile size parameters */
25031 size_t whd_size; /* words needed for heights, widths, and depths */
25032 int i,ii; /* |font_info| indices */
25033 int jj; /* counts bytes to be ignored */
25034 scaled z; /* used to compute the design size */
25036 /* height, width, or depth as a fraction of design size times $2^{-8}$ */
25037 eight_bits h_and_d; /* height and depth indices being unpacked */
25038 unsigned char tfbyte; /* a byte read from the file */
25040 @<Open |tfm_infile| for input@>;
25041 @<Read data from |tfm_infile|; if there is no room, say so and |goto done|;
25042 otherwise |goto bad_tfm| or |goto done| as appropriate@>;
25044 @<Complain that the \.{TFM} file is bad@>;
25046 if ( file_opened ) (mp->close_file)(mp,mp->tfm_infile);
25047 if ( n!=null_font ) {
25048 mp->font_ps_name[n]=mp_xstrdup(mp,fname);
25049 mp->font_name[n]=mp_xstrdup(mp,fname);
25054 @ \MP\ doesn't bother to check the entire \.{TFM} file for errors or explain
25055 precisely what is wrong if it does find a problem. Programs called \.{TFtoPL}
25056 @.TFtoPL@> @.PLtoTF@>
25057 and \.{PLtoTF} can be used to debug \.{TFM} files.
25059 @<Complain that the \.{TFM} file is bad@>=
25060 print_err("Font ");
25061 mp_print(mp, fname);
25062 if ( file_opened ) mp_print(mp, " not usable: TFM file is bad");
25063 else mp_print(mp, " not usable: TFM file not found");
25064 help3("I wasn't able to read the size data for this font so this")
25065 ("`infont' operation won't produce anything. If the font name")
25066 ("is right, you might ask an expert to make a TFM file");
25068 mp->help_line[0]="is right, try asking an expert to fix the TFM file";
25071 @ @<Read data from |tfm_infile|; if there is no room, say so...@>=
25072 @<Read the \.{TFM} size fields@>;
25073 @<Use the size fields to allocate space in |font_info|@>;
25074 @<Read the \.{TFM} header@>;
25075 @<Read the character data and the width, height, and depth tables and
25078 @ A bad \.{TFM} file can be shorter than it claims to be. The code given here
25079 might try to read past the end of the file if this happens. Changes will be
25080 needed if it causes a system error to refer to |tfm_infile^| or call
25081 |get_tfm_infile| when |eof(tfm_infile)| is true. For example, the definition
25082 @^system dependencies@>
25083 of |tfget| could be changed to
25084 ``|begin get(tfm_infile); if eof(tfm_infile) then goto bad_tfm; end|.''
25088 void *tfbyte_ptr = &tfbyte;
25089 (mp->read_binary_file)(mp,mp->tfm_infile,&tfbyte_ptr,&wanted);
25090 if (wanted==0) goto BAD_TFM;
25092 @d read_two(A) { (A)=tfbyte;
25093 if ( (A)>127 ) goto BAD_TFM;
25094 tfget; (A)=(A)*0400+tfbyte;
25096 @d tf_ignore(A) { for (jj=(A);jj>=1;jj--) tfget; }
25098 @<Read the \.{TFM} size fields@>=
25099 tfget; read_two(lf);
25100 tfget; read_two(tfm_lh);
25101 tfget; read_two(bc);
25102 tfget; read_two(ec);
25103 if ( (bc>1+ec)||(ec>255) ) goto BAD_TFM;
25104 tfget; read_two(nw);
25105 tfget; read_two(nh);
25106 tfget; read_two(nd);
25107 whd_size=(ec+1-bc)+nw+nh+nd;
25108 if ( lf<(int)(6+tfm_lh+whd_size) ) goto BAD_TFM;
25111 @ Offsets are added to |char_base[n]| and |width_base[n]| so that is not
25112 necessary to apply the |so| and |qo| macros when looking up the width of a
25113 character in the string pool. In order to ensure nonnegative |char_base|
25114 values when |bc>0|, it may be necessary to reserve a few unused |font_info|
25117 @<Use the size fields to allocate space in |font_info|@>=
25118 if ( mp->next_fmem<bc) mp->next_fmem=bc; /* ensure nonnegative |char_base| */
25119 if (mp->last_fnum==mp->font_max)
25120 mp_reallocate_fonts(mp,(mp->font_max+(mp->font_max>>2)));
25121 while (mp->next_fmem+whd_size>=mp->font_mem_size) {
25122 size_t l = mp->font_mem_size+(mp->font_mem_size>>2);
25123 memory_word *font_info;
25124 font_info = xmalloc ((l+1),sizeof(memory_word));
25125 memset (font_info,0,sizeof(memory_word)*(l+1));
25126 memcpy (font_info,mp->font_info,sizeof(memory_word)*(mp->font_mem_size+1));
25127 xfree(mp->font_info);
25128 mp->font_info = font_info;
25129 mp->font_mem_size = l;
25131 incr(mp->last_fnum);
25135 mp->char_base[n]=mp->next_fmem-bc;
25136 mp->width_base[n]=mp->next_fmem+ec-bc+1;
25137 mp->height_base[n]=mp->width_base[n]+nw;
25138 mp->depth_base[n]=mp->height_base[n]+nh;
25139 mp->next_fmem=mp->next_fmem+whd_size;
25142 @ @<Read the \.{TFM} header@>=
25143 if ( tfm_lh<2 ) goto BAD_TFM;
25145 tfget; read_two(z);
25146 tfget; z=z*0400+tfbyte;
25147 tfget; z=z*0400+tfbyte; /* now |z| is 16 times the design size */
25148 mp->font_dsize[n]=mp_take_fraction(mp, z,267432584);
25149 /* times ${72\over72.27}2^{28}$ to convert from \TeX\ points */
25150 tf_ignore(4*(tfm_lh-2))
25152 @ @<Read the character data and the width, height, and depth tables...@>=
25153 ii=mp->width_base[n];
25154 i=mp->char_base[n]+bc;
25156 tfget; mp->font_info[i].qqqq.b0=qi(tfbyte);
25157 tfget; h_and_d=tfbyte;
25158 mp->font_info[i].qqqq.b1=h_and_d / 16;
25159 mp->font_info[i].qqqq.b2=h_and_d % 16;
25163 while ( i<mp->next_fmem ) {
25164 @<Read a four byte dimension, scale it by the design size, store it in
25165 |font_info[i]|, and increment |i|@>;
25169 @ The raw dimension read into |d| should have magnitude at most $2^{24}$ when
25170 interpreted as an integer, and this includes a scale factor of $2^{20}$. Thus
25171 we can multiply it by sixteen and think of it as a |fraction| that has been
25172 divided by sixteen. This cancels the extra scale factor contained in
25175 @<Read a four byte dimension, scale it by the design size, store it in...@>=
25178 if ( d>=0200 ) d=d-0400;
25179 tfget; d=d*0400+tfbyte;
25180 tfget; d=d*0400+tfbyte;
25181 tfget; d=d*0400+tfbyte;
25182 mp->font_info[i].sc=mp_take_fraction(mp, d*16,mp->font_dsize[n]);
25186 @ This function does no longer use the file name parser, because |fname| is
25187 a C string already.
25188 @<Open |tfm_infile| for input@>=
25190 mp_ptr_scan_file(mp, fname);
25191 if ( strlen(mp->cur_area)==0 ) { xfree(mp->cur_area); }
25192 if ( strlen(mp->cur_ext)==0 ) { xfree(mp->cur_ext); mp->cur_ext=xstrdup(".tfm"); }
25194 mp->tfm_infile = (mp->open_file)(mp, mp->name_of_file, "r",mp_filetype_metrics);
25195 if ( !mp->tfm_infile ) goto BAD_TFM;
25198 @ When we have a font name and we don't know whether it has been loaded yet,
25199 we scan the |font_name| array before calling |read_font_info|.
25201 @<Declare text measuring subroutines@>=
25202 font_number mp_find_font (MP mp, char *f) {
25204 for (n=0;n<=mp->last_fnum;n++) {
25205 if (mp_xstrcmp(f,mp->font_name[n])==0 ) {
25210 n = mp_read_font_info(mp, f);
25215 @ This is an interface function for getting the width of character,
25216 as a double in ps units
25218 @c double mp_get_char_dimension (MP mp, char *fname, int c, int t) {
25223 for (n=0;n<=mp->last_fnum;n++) {
25224 if (mp_xstrcmp(fname,mp->font_name[n])==0 ) {
25231 cc = char_info(f,c);
25232 if (! ichar_exists(cc) )
25235 w = char_width(f,cc);
25237 w = char_height(f,cc);
25239 w = char_depth(f,cc);
25240 return w/655.35*(72.27/72);
25243 @ @<Exported function ...@>=
25244 double mp_get_char_dimension (MP mp, char *fname, int n, int t);
25247 @ One simple application of |find_font| is the implementation of the |font_size|
25248 operator that gets the design size for a given font name.
25250 @<Find the design size of the font whose name is |cur_exp|@>=
25251 mp_flush_cur_exp(mp, (mp->font_dsize[mp_find_font(mp, str(mp->cur_exp))]+8) / 16)
25253 @ If we discover that the font doesn't have a requested character, we omit it
25254 from the bounding box computation and expect the \ps\ interpreter to drop it.
25255 This routine issues a warning message if the user has asked for it.
25257 @<Declare text measuring subroutines@>=
25258 void mp_lost_warning (MP mp,font_number f, pool_pointer k) {
25259 if ( mp->internal[mp_tracing_lost_chars]>0 ) {
25260 mp_begin_diagnostic(mp);
25261 if ( mp->selector==log_only ) incr(mp->selector);
25262 mp_print_nl(mp, "Missing character: There is no ");
25263 @.Missing character@>
25264 mp_print_str(mp, mp->str_pool[k]);
25265 mp_print(mp, " in font ");
25266 mp_print(mp, mp->font_name[f]); mp_print_char(mp, '!');
25267 mp_end_diagnostic(mp, false);
25271 @ The whole purpose of saving the height, width, and depth information is to be
25272 able to find the bounding box of an item of text in an edge structure. The
25273 |set_text_box| procedure takes a text node and adds this information.
25275 @<Declare text measuring subroutines@>=
25276 void mp_set_text_box (MP mp,pointer p) {
25277 font_number f; /* |font_n(p)| */
25278 ASCII_code bc,ec; /* range of valid characters for font |f| */
25279 pool_pointer k,kk; /* current character and character to stop at */
25280 four_quarters cc; /* the |char_info| for the current character */
25281 scaled h,d; /* dimensions of the current character */
25283 height_val(p)=-el_gordo;
25284 depth_val(p)=-el_gordo;
25288 kk=str_stop(text_p(p));
25289 k=mp->str_start[text_p(p)];
25291 @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>;
25293 @<Set the height and depth to zero if the bounding box is empty@>;
25296 @ @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>=
25298 if ( (mp->str_pool[k]<bc)||(mp->str_pool[k]>ec) ) {
25299 mp_lost_warning(mp, f,k);
25301 cc=char_info(f,mp->str_pool[k]);
25302 if ( ! ichar_exists(cc) ) {
25303 mp_lost_warning(mp, f,k);
25305 width_val(p)=width_val(p)+char_width(f,cc);
25306 h=char_height(f,cc);
25307 d=char_depth(f,cc);
25308 if ( h>height_val(p) ) height_val(p)=h;
25309 if ( d>depth_val(p) ) depth_val(p)=d;
25315 @ Let's hope modern compilers do comparisons correctly when the difference would
25318 @<Set the height and depth to zero if the bounding box is empty@>=
25319 if ( height_val(p)<-depth_val(p) ) {
25324 @ The new primitives fontmapfile and fontmapline.
25326 @<Declare action procedures for use by |do_statement|@>=
25327 void mp_do_mapfile (MP mp) ;
25328 void mp_do_mapline (MP mp) ;
25330 @ @c void mp_do_mapfile (MP mp) {
25331 mp_get_x_next(mp); mp_scan_expression(mp);
25332 if ( mp->cur_type!=mp_string_type ) {
25333 @<Complain about improper map operation@>;
25335 mp_map_file(mp,mp->cur_exp);
25338 void mp_do_mapline (MP mp) {
25339 mp_get_x_next(mp); mp_scan_expression(mp);
25340 if ( mp->cur_type!=mp_string_type ) {
25341 @<Complain about improper map operation@>;
25343 mp_map_line(mp,mp->cur_exp);
25347 @ @<Complain about improper map operation@>=
25349 exp_err("Unsuitable expression");
25350 help1("Only known strings can be map files or map lines.");
25351 mp_put_get_error(mp);
25354 @ To print |scaled| value to PDF output we need some subroutines to ensure
25357 @d max_integer 0x7FFFFFFF /* $2^{31}-1$ */
25360 scaled one_bp; /* scaled value corresponds to 1bp */
25361 scaled one_hundred_bp; /* scaled value corresponds to 100bp */
25362 scaled one_hundred_inch; /* scaled value corresponds to 100in */
25363 integer ten_pow[10]; /* $10^0..10^9$ */
25364 integer scaled_out; /* amount of |scaled| that was taken out in |divide_scaled| */
25367 mp->one_bp = 65782; /* 65781.76 */
25368 mp->one_hundred_bp = 6578176;
25369 mp->one_hundred_inch = 473628672;
25370 mp->ten_pow[0] = 1;
25371 for (i = 1;i<= 9; i++ ) {
25372 mp->ten_pow[i] = 10*mp->ten_pow[i - 1];
25375 @ The following function divides |s| by |m|. |dd| is number of decimal digits.
25377 @c scaled mp_divide_scaled (MP mp,scaled s, scaled m, integer dd) {
25381 if ( s < 0 ) { sign = -sign; s = -s; }
25382 if ( m < 0 ) { sign = -sign; m = -m; }
25384 mp_confusion(mp, "arithmetic: divided by zero");
25385 else if ( m >= (max_integer / 10) )
25386 mp_confusion(mp, "arithmetic: number too big");
25389 for (i = 1;i<=dd;i++) {
25390 q = 10*q + (10*r) / m;
25393 if ( 2*r >= m ) { incr(q); r = r - m; }
25394 mp->scaled_out = sign*(s - (r / mp->ten_pow[dd]));
25398 @* \[44] Shipping pictures out.
25399 The |ship_out| procedure, to be described below, is given a pointer to
25400 an edge structure. Its mission is to output a file containing the \ps\
25401 description of an edge structure.
25403 @ Each time an edge structure is shipped out we write a new \ps\ output
25404 file named according to the current \&{charcode}.
25405 @:char_code_}{\&{charcode} primitive@>
25407 This is the only backend function that remains in the main |mpost.w| file.
25408 There are just too many variable accesses needed for status reporting
25409 etcetera to make it worthwile to move the code to |psout.w|.
25411 @<Internal library declarations@>=
25412 void mp_open_output_file (MP mp) ;
25415 char *mp_set_output_file_name (MP mp, integer c) {
25416 char *ss = NULL; /* filename extension proposal */
25417 char *nn = NULL; /* temp string for str() */
25418 int old_setting; /* previous |selector| setting */
25419 pool_pointer i; /* indexes into |filename_template| */
25420 integer cc; /* a temporary integer for template building */
25421 integer f,g=0; /* field widths */
25422 if ( mp->job_name==NULL ) mp_open_log_file(mp);
25423 if ( mp->filename_template==0 ) {
25424 char *s; /* a file extension derived from |c| */
25428 @<Use |c| to compute the file extension |s|@>;
25429 mp_pack_job_name(mp, s);
25431 ss = xstrdup(mp->name_of_file);
25432 } else { /* initializations */
25433 str_number s, n; /* a file extension derived from |c| */
25434 old_setting=mp->selector;
25435 mp->selector=new_string;
25437 i = mp->str_start[mp->filename_template];
25438 n = rts(""); /* initialize */
25439 while ( i<str_stop(mp->filename_template) ) {
25440 if ( mp->str_pool[i]=='%' ) {
25443 if ( i<str_stop(mp->filename_template) ) {
25444 if ( mp->str_pool[i]=='j' ) {
25445 mp_print(mp, mp->job_name);
25446 } else if ( mp->str_pool[i]=='d' ) {
25447 cc= mp_round_unscaled(mp, mp->internal[mp_day]);
25448 print_with_leading_zeroes(cc);
25449 } else if ( mp->str_pool[i]=='m' ) {
25450 cc= mp_round_unscaled(mp, mp->internal[mp_month]);
25451 print_with_leading_zeroes(cc);
25452 } else if ( mp->str_pool[i]=='y' ) {
25453 cc= mp_round_unscaled(mp, mp->internal[mp_year]);
25454 print_with_leading_zeroes(cc);
25455 } else if ( mp->str_pool[i]=='H' ) {
25456 cc= mp_round_unscaled(mp, mp->internal[mp_time]) / 60;
25457 print_with_leading_zeroes(cc);
25458 } else if ( mp->str_pool[i]=='M' ) {
25459 cc= mp_round_unscaled(mp, mp->internal[mp_time]) % 60;
25460 print_with_leading_zeroes(cc);
25461 } else if ( mp->str_pool[i]=='c' ) {
25462 if ( c<0 ) mp_print(mp, "ps");
25463 else print_with_leading_zeroes(c);
25464 } else if ( (mp->str_pool[i]>='0') &&
25465 (mp->str_pool[i]<='9') ) {
25467 f = (f*10) + mp->str_pool[i]-'0';
25470 mp_print_str(mp, mp->str_pool[i]);
25474 if ( mp->str_pool[i]=='.' )
25476 n = mp_make_string(mp);
25477 mp_print_str(mp, mp->str_pool[i]);
25481 s = mp_make_string(mp);
25482 mp->selector= old_setting;
25483 if (length(n)==0) {
25489 mp_pack_file_name(mp, nn,"",ss);
25497 char * mp_get_output_file_name (MP mp) {
25499 char *saved_name; /* saved |name_of_file| */
25500 saved_name = xstrdup(mp->name_of_file);
25501 f = xstrdup(mp_set_output_file_name(mp, mp_round_unscaled(mp, mp->internal[mp_char_code])));
25502 mp_pack_file_name(mp, saved_name,NULL,NULL);
25507 void mp_open_output_file (MP mp) {
25508 char *ss; /* filename extension proposal */
25509 integer c; /* \&{charcode} rounded to the nearest integer */
25510 c=mp_round_unscaled(mp, mp->internal[mp_char_code]);
25511 ss = mp_set_output_file_name(mp, c);
25512 while ( ! mp_a_open_out(mp, (void *)&mp->ps_file, mp_filetype_postscript) )
25513 mp_prompt_file_name(mp, "file name for output",ss);
25515 @<Store the true output file name if appropriate@>;
25518 @ The file extension created here could be up to five characters long in
25519 extreme cases so it may have to be shortened on some systems.
25520 @^system dependencies@>
25522 @<Use |c| to compute the file extension |s|@>=
25525 mp_snprintf(s,7,".%i",(int)c);
25528 @ The user won't want to see all the output file names so we only save the
25529 first and last ones and a count of how many there were. For this purpose
25530 files are ordered primarily by \&{charcode} and secondarily by order of
25532 @:char_code_}{\&{charcode} primitive@>
25534 @<Store the true output file name if appropriate@>=
25535 if ((c<mp->first_output_code)&&(mp->first_output_code>=0)) {
25536 mp->first_output_code=c;
25537 xfree(mp->first_file_name);
25538 mp->first_file_name=xstrdup(mp->name_of_file);
25540 if ( c>=mp->last_output_code ) {
25541 mp->last_output_code=c;
25542 xfree(mp->last_file_name);
25543 mp->last_file_name=xstrdup(mp->name_of_file);
25547 char * first_file_name;
25548 char * last_file_name; /* full file names */
25549 integer first_output_code;integer last_output_code; /* rounded \&{charcode} values */
25550 @:char_code_}{\&{charcode} primitive@>
25551 integer total_shipped; /* total number of |ship_out| operations completed */
25554 mp->first_file_name=xstrdup("");
25555 mp->last_file_name=xstrdup("");
25556 mp->first_output_code=32768;
25557 mp->last_output_code=-32768;
25558 mp->total_shipped=0;
25560 @ @<Dealloc variables@>=
25561 xfree(mp->first_file_name);
25562 xfree(mp->last_file_name);
25564 @ @<Begin the progress report for the output of picture~|c|@>=
25565 if ( (int)mp->term_offset>mp->max_print_line-6 ) mp_print_ln(mp);
25566 else if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_char(mp, ' ');
25567 mp_print_char(mp, '[');
25568 if ( c>=0 ) mp_print_int(mp, c)
25570 @ @<End progress report@>=
25571 mp_print_char(mp, ']');
25573 incr(mp->total_shipped)
25575 @ @<Explain what output files were written@>=
25576 if ( mp->total_shipped>0 ) {
25577 mp_print_nl(mp, "");
25578 mp_print_int(mp, mp->total_shipped);
25579 if (mp->noninteractive) {
25580 mp_print(mp, " figure");
25581 if ( mp->total_shipped>1 ) mp_print_char(mp, 's');
25582 mp_print(mp, " created.");
25584 mp_print(mp, " output file");
25585 if ( mp->total_shipped>1 ) mp_print_char(mp, 's');
25586 mp_print(mp, " written: ");
25587 mp_print(mp, mp->first_file_name);
25588 if ( mp->total_shipped>1 ) {
25589 if ( 31+strlen(mp->first_file_name)+
25590 strlen(mp->last_file_name)> (unsigned)mp->max_print_line)
25592 mp_print(mp, " .. ");
25593 mp_print(mp, mp->last_file_name);
25598 @ @<Internal library declarations@>=
25599 boolean mp_has_font_size(MP mp, font_number f );
25602 boolean mp_has_font_size(MP mp, font_number f ) {
25603 return (mp->font_sizes[f]!=null);
25606 @ The \&{special} command saves up lines of text to be printed during the next
25607 |ship_out| operation. The saved items are stored as a list of capsule tokens.
25610 pointer last_pending; /* the last token in a list of pending specials */
25613 mp->last_pending=spec_head;
25615 @ @<Cases of |do_statement|...@>=
25616 case special_command:
25617 if ( mp->cur_mod==0 ) mp_do_special(mp); else
25618 if ( mp->cur_mod==1 ) mp_do_mapfile(mp); else
25622 @ @<Declare action procedures for use by |do_statement|@>=
25623 void mp_do_special (MP mp) ;
25625 @ @c void mp_do_special (MP mp) {
25626 mp_get_x_next(mp); mp_scan_expression(mp);
25627 if ( mp->cur_type!=mp_string_type ) {
25628 @<Complain about improper special operation@>;
25630 link(mp->last_pending)=mp_stash_cur_exp(mp);
25631 mp->last_pending=link(mp->last_pending);
25632 link(mp->last_pending)=null;
25636 @ @<Complain about improper special operation@>=
25638 exp_err("Unsuitable expression");
25639 help1("Only known strings are allowed for output as specials.");
25640 mp_put_get_error(mp);
25643 @ On the export side, we need an extra object type for special strings.
25645 @<Graphical object codes@>=
25648 @ @<Export pending specials@>=
25650 while ( p!=null ) {
25651 mp_special_object *tp;
25652 tp = (mp_special_object *)mp_new_graphic_object(mp,mp_special_code);
25653 gr_pre_script(tp) = str(value(p));
25654 if (hh->body==NULL) hh->body = (mp_graphic_object *)tp;
25655 else gr_link(hp) = (mp_graphic_object *)tp;
25656 hp = (mp_graphic_object *)tp;
25659 mp_flush_token_list(mp, link(spec_head));
25660 link(spec_head)=null;
25661 mp->last_pending=spec_head
25663 @ We are now ready for the main output procedure. Note that the |selector|
25664 setting is saved in a global variable so that |begin_diagnostic| can access it.
25666 @<Declare the \ps\ output procedures@>=
25667 void mp_ship_out (MP mp, pointer h) ;
25669 @ Once again, the |gr_XXXX| macros are defined in |mppsout.h|
25671 @d export_color(q,p)
25672 if ( color_model(p)==mp_uninitialized_model ) {
25673 gr_color_model(q) = (mp->internal[mp_default_color_model]>>16);
25674 gr_cyan_val(q) = 0;
25675 gr_magenta_val(q) = 0;
25676 gr_yellow_val(q) = 0;
25677 gr_black_val(q) = (gr_color_model(q)==mp_cmyk_model ? unity : 0);
25679 gr_color_model(q) = color_model(p);
25680 gr_cyan_val(q) = cyan_val(p);
25681 gr_magenta_val(q) = magenta_val(p);
25682 gr_yellow_val(q) = yellow_val(p);
25683 gr_black_val(q) = black_val(p);
25686 @d export_scripts(q,p)
25687 if (pre_script(p)!=null) gr_pre_script(q) = str(pre_script(p));
25688 if (post_script(p)!=null) gr_post_script(q) = str(post_script(p));
25691 struct mp_edge_object *mp_gr_export(MP mp, pointer h) {
25692 pointer p; /* the current graphical object */
25693 integer t; /* a temporary value */
25694 integer c; /* a rounded charcode */
25695 scaled d_width; /* the current pen width */
25696 mp_edge_object *hh; /* the first graphical object */
25697 struct mp_graphic_object *hq; /* something |hp| points to */
25698 struct mp_text_object *tt;
25699 struct mp_fill_object *tf;
25700 struct mp_stroked_object *ts;
25701 struct mp_clip_object *tc;
25702 struct mp_bounds_object *tb;
25703 struct mp_graphic_object *hp = NULL; /* the current graphical object */
25704 mp_set_bbox(mp, h, true);
25705 hh = mp_xmalloc(mp,1,sizeof(mp_edge_object));
25709 hh->_minx = minx_val(h);
25710 hh->_miny = miny_val(h);
25711 hh->_maxx = maxx_val(h);
25712 hh->_maxy = maxy_val(h);
25713 hh->_filename = mp_get_output_file_name(mp);
25714 c = mp_round_unscaled(mp,mp->internal[mp_char_code]);
25716 hh->_width = mp->internal[mp_char_wd];
25717 hh->_height = mp->internal[mp_char_ht];
25718 hh->_depth = mp->internal[mp_char_dp];
25719 hh->_ital_corr = mp->internal[mp_char_ic];
25720 @<Export pending specials@>;
25721 p=link(dummy_loc(h));
25722 while ( p!=null ) {
25723 hq = mp_new_graphic_object(mp,type(p));
25726 tf = (mp_fill_object *)hq;
25727 gr_pen_p(tf) = mp_export_knot_list(mp,pen_p(p));
25728 d_width = mp_get_pen_scale(mp, pen_p(p));
25729 if ((pen_p(p)==null) || pen_is_elliptical(pen_p(p))) {
25730 gr_path_p(tf) = mp_export_knot_list(mp,path_p(p));
25733 pc = mp_copy_path(mp, path_p(p));
25734 pp = mp_make_envelope(mp, pc, pen_p(p),ljoin_val(p),0,miterlim_val(p));
25735 gr_path_p(tf) = mp_export_knot_list(mp,pp);
25736 mp_toss_knot_list(mp, pp);
25737 pc = mp_htap_ypoc(mp, path_p(p));
25738 pp = mp_make_envelope(mp, pc, pen_p(p),ljoin_val(p),0,miterlim_val(p));
25739 gr_htap_p(tf) = mp_export_knot_list(mp,pp);
25740 mp_toss_knot_list(mp, pp);
25742 export_color(tf,p) ;
25743 export_scripts(tf,p);
25744 gr_ljoin_val(tf) = ljoin_val(p);
25745 gr_miterlim_val(tf) = miterlim_val(p);
25747 case mp_stroked_code:
25748 ts = (mp_stroked_object *)hq;
25749 gr_pen_p(ts) = mp_export_knot_list(mp,pen_p(p));
25750 d_width = mp_get_pen_scale(mp, pen_p(p));
25751 if (pen_is_elliptical(pen_p(p))) {
25752 gr_path_p(ts) = mp_export_knot_list(mp,path_p(p));
25755 pc=mp_copy_path(mp, path_p(p));
25757 if ( left_type(pc)!=mp_endpoint ) {
25758 left_type(mp_insert_knot(mp, pc,x_coord(pc),y_coord(pc)))=mp_endpoint;
25759 right_type(pc)=mp_endpoint;
25763 pc=mp_make_envelope(mp,pc,pen_p(p),ljoin_val(p),t,miterlim_val(p));
25764 gr_path_p(ts) = mp_export_knot_list(mp,pc);
25765 mp_toss_knot_list(mp, pc);
25767 export_color(ts,p) ;
25768 export_scripts(ts,p);
25769 gr_ljoin_val(ts) = ljoin_val(p);
25770 gr_miterlim_val(ts) = miterlim_val(p);
25771 gr_lcap_val(ts) = lcap_val(p);
25772 gr_dash_p(ts) = mp_export_dashes(mp,p,&d_width);
25775 tt = (mp_text_object *)hq;
25776 gr_text_p(tt) = str(text_p(p));
25777 gr_font_n(tt) = font_n(p);
25778 gr_font_name(tt) = mp_xstrdup(mp,mp->font_name[font_n(p)]);
25779 gr_font_dsize(tt) = mp->font_dsize[font_n(p)];
25780 export_color(tt,p) ;
25781 export_scripts(tt,p);
25782 gr_width_val(tt) = width_val(p);
25783 gr_height_val(tt) = height_val(p);
25784 gr_depth_val(tt) = depth_val(p);
25785 gr_tx_val(tt) = tx_val(p);
25786 gr_ty_val(tt) = ty_val(p);
25787 gr_txx_val(tt) = txx_val(p);
25788 gr_txy_val(tt) = txy_val(p);
25789 gr_tyx_val(tt) = tyx_val(p);
25790 gr_tyy_val(tt) = tyy_val(p);
25792 case mp_start_clip_code:
25793 tc = (mp_clip_object *)hq;
25794 gr_path_p(tc) = mp_export_knot_list(mp,path_p(p));
25796 case mp_start_bounds_code:
25797 tb = (mp_bounds_object *)hq;
25798 gr_path_p(tb) = mp_export_knot_list(mp,path_p(p));
25800 case mp_stop_clip_code:
25801 case mp_stop_bounds_code:
25802 /* nothing to do here */
25805 if (hh->body==NULL) hh->body=hq; else gr_link(hp) = hq;
25812 @ @<Exported function ...@>=
25813 struct mp_edge_object *mp_gr_export(MP mp, int h);
25815 @ This function is now nearly trivial.
25818 void mp_ship_out (MP mp, pointer h) { /* output edge structure |h| */
25819 integer c; /* \&{charcode} rounded to the nearest integer */
25820 c=mp_round_unscaled(mp, mp->internal[mp_char_code]);
25821 @<Begin the progress report for the output of picture~|c|@>;
25822 (mp->shipout_backend) (mp, h);
25823 @<End progress report@>;
25824 if ( mp->internal[mp_tracing_output]>0 )
25825 mp_print_edges(mp, h," (just shipped out)",true);
25828 @ @<Declarations@>=
25829 void mp_shipout_backend (MP mp, pointer h);
25832 void mp_shipout_backend (MP mp, pointer h) {
25833 mp_edge_object *hh; /* the first graphical object */
25834 hh = mp_gr_export(mp,h);
25835 (void)mp_gr_ship_out (hh,
25836 (mp->internal[mp_prologues]>>16),
25837 (mp->internal[mp_procset]>>16),
25839 mp_gr_toss_objects(hh);
25842 @ @<Exported types@>=
25843 typedef void (*mp_backend_writer)(MP, int);
25845 @ @<Option variables@>=
25846 mp_backend_writer shipout_backend;
25848 @ Now that we've finished |ship_out|, let's look at the other commands
25849 by which a user can send things to the \.{GF} file.
25851 @ @<Determine if a character has been shipped out@>=
25853 mp->cur_exp=mp_round_unscaled(mp, mp->cur_exp) % 256;
25854 if ( mp->cur_exp<0 ) mp->cur_exp=mp->cur_exp+256;
25855 boolean_reset(mp->char_exists[mp->cur_exp]);
25856 mp->cur_type=mp_boolean_type;
25862 @ @<Allocate or initialize ...@>=
25863 mp_backend_initialize(mp);
25866 mp_backend_free(mp);
25869 @* \[45] Dumping and undumping the tables.
25870 After \.{INIMP} has seen a collection of macros, it
25871 can write all the necessary information on an auxiliary file so
25872 that production versions of \MP\ are able to initialize their
25873 memory at high speed. The present section of the program takes
25874 care of such output and input. We shall consider simultaneously
25875 the processes of storing and restoring,
25876 so that the inverse relation between them is clear.
25879 The global variable |mem_ident| is a string that is printed right
25880 after the |banner| line when \MP\ is ready to start. For \.{INIMP} this
25881 string says simply `\.{(INIMP)}'; for other versions of \MP\ it says,
25882 for example, `\.{(mem=plain 1990.4.14)}', showing the year,
25883 month, and day that the mem file was created. We have |mem_ident=0|
25884 before \MP's tables are loaded.
25890 mp->mem_ident=NULL;
25892 @ @<Initialize table entries...@>=
25893 mp->mem_ident=xstrdup(" (INIMP)");
25895 @ @<Declare act...@>=
25896 void mp_store_mem_file (MP mp) ;
25898 @ @c void mp_store_mem_file (MP mp) {
25899 integer k; /* all-purpose index */
25900 pointer p,q; /* all-purpose pointers */
25901 integer x; /* something to dump */
25902 four_quarters w; /* four ASCII codes */
25904 @<Create the |mem_ident|, open the mem file,
25905 and inform the user that dumping has begun@>;
25906 @<Dump constants for consistency check@>;
25907 @<Dump the string pool@>;
25908 @<Dump the dynamic memory@>;
25909 @<Dump the table of equivalents and the hash table@>;
25910 @<Dump a few more things and the closing check word@>;
25911 @<Close the mem file@>;
25914 @ Corresponding to the procedure that dumps a mem file, we also have a function
25915 that reads~one~in. The function returns |false| if the dumped mem is
25916 incompatible with the present \MP\ table sizes, etc.
25918 @d too_small(A) { wake_up_terminal;
25919 wterm_ln("---! Must increase the "); wterm((A));
25920 @.Must increase the x@>
25925 boolean mp_load_mem_file (MP mp) {
25926 integer k; /* all-purpose index */
25927 pointer p,q; /* all-purpose pointers */
25928 integer x; /* something undumped */
25929 str_number s; /* some temporary string */
25930 four_quarters w; /* four ASCII codes */
25932 /* |@<Undump constants for consistency check@>;| read earlier */
25933 @<Undump the string pool@>;
25934 @<Undump the dynamic memory@>;
25935 @<Undump the table of equivalents and the hash table@>;
25936 @<Undump a few more things and the closing check word@>;
25937 return true; /* it worked! */
25940 wterm_ln("(Fatal mem file error; I'm stymied)\n");
25941 @.Fatal mem file error@>
25945 @ @<Declarations@>=
25946 boolean mp_load_mem_file (MP mp) ;
25948 @ Mem files consist of |memory_word| items, and we use the following
25949 macros to dump words of different types:
25951 @d dump_wd(A) { WW=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
25952 @d dump_int(A) { int cint=(A); (mp->write_binary_file)(mp,mp->mem_file,&cint,sizeof(cint)); }
25953 @d dump_hh(A) { WW.hh=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
25954 @d dump_qqqq(A) { WW.qqqq=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
25955 @d dump_string(A) { dump_int(strlen(A)+1);
25956 (mp->write_binary_file)(mp,mp->mem_file,A,strlen(A)+1); }
25959 void * mem_file; /* for input or output of mem information */
25961 @ The inverse macros are slightly more complicated, since we need to check
25962 the range of the values we are reading in. We say `|undump(a)(b)(x)|' to
25963 read an integer value |x| that is supposed to be in the range |a<=x<=b|.
25966 size_t wanted = sizeof(A);
25968 (mp->read_binary_file)(mp, mp->mem_file,&A_ptr,&wanted);
25969 if (wanted!=sizeof(A)) goto OFF_BASE;
25973 size_t wanted = sizeof(A);
25975 (mp->read_binary_file)(mp, mp->mem_file,&A_ptr,&wanted);
25976 if (wanted!=sizeof(A)) goto OFF_BASE;
25979 @d undump_wd(A) { mgetw(WW); A=WW; }
25980 @d undump_int(A) { int cint; mgeti(cint); A=cint; }
25981 @d undump_hh(A) { mgetw(WW); A=WW.hh; }
25982 @d undump_qqqq(A) { mgetw(WW); A=WW.qqqq; }
25983 @d undump_strings(A,B,C) {
25984 undump_int(x); if ( (x<(A)) || (x>(B)) ) goto OFF_BASE; else C=str(x); }
25985 @d undump(A,B,C) { undump_int(x); if ( (x<(A)) || (x>(int)(B)) ) goto OFF_BASE; else C=x; }
25986 @d undump_size(A,B,C,D) { undump_int(x);
25987 if (x<(A)) goto OFF_BASE;
25988 if (x>(B)) { too_small((C)); } else { D=x;} }
25989 @d undump_string(A) do {
25995 the_string = xmalloc(XX,sizeof(char));
25996 (mp->read_binary_file)(mp,mp->mem_file,&the_string,&the_wanted);
25997 A = (char *)the_string;
25998 if (the_wanted!=(size_t)XX) goto OFF_BASE;
26001 @ The next few sections of the program should make it clear how we use the
26002 dump/undump macros.
26004 @<Dump constants for consistency check@>=
26005 dump_int(mp->mem_top);
26006 dump_int(mp->hash_size);
26007 dump_int(mp->hash_prime)
26008 dump_int(mp->param_size);
26009 dump_int(mp->max_in_open);
26011 @ Sections of a \.{WEB} program that are ``commented out'' still contribute
26012 strings to the string pool; therefore \.{INIMP} and \MP\ will have
26013 the same strings. (And it is, of course, a good thing that they do.)
26017 @<Undump constants for consistency check@>=
26018 undump_int(x); mp->mem_top = x;
26019 undump_int(x); mp->hash_size = x;
26020 undump_int(x); mp->hash_prime = x;
26021 undump_int(x); mp->param_size = x;
26022 undump_int(x); mp->max_in_open = x;
26024 @ We do string pool compaction to avoid dumping unused strings.
26027 w.b0=qi(mp->str_pool[k]); w.b1=qi(mp->str_pool[k+1]);
26028 w.b2=qi(mp->str_pool[k+2]); w.b3=qi(mp->str_pool[k+3]);
26031 @<Dump the string pool@>=
26032 mp_do_compaction(mp, mp->pool_size);
26033 dump_int(mp->pool_ptr);
26034 dump_int(mp->max_str_ptr);
26035 dump_int(mp->str_ptr);
26037 while ( (mp->next_str[k]==k+1) && (k<=mp->max_str_ptr) )
26040 while ( k<=mp->max_str_ptr ) {
26041 dump_int(mp->next_str[k]); incr(k);
26045 dump_int(mp->str_start[k]); /* TODO: valgrind warning here */
26046 if ( k==mp->str_ptr ) {
26053 while (k+4<mp->pool_ptr ) {
26054 dump_four_ASCII; k=k+4;
26056 k=mp->pool_ptr-4; dump_four_ASCII;
26057 mp_print_ln(mp); mp_print(mp, "at most "); mp_print_int(mp, mp->max_str_ptr);
26058 mp_print(mp, " strings of total length ");
26059 mp_print_int(mp, mp->pool_ptr)
26061 @ @d undump_four_ASCII
26063 mp->str_pool[k]=qo(w.b0); mp->str_pool[k+1]=qo(w.b1);
26064 mp->str_pool[k+2]=qo(w.b2); mp->str_pool[k+3]=qo(w.b3)
26066 @<Undump the string pool@>=
26067 undump_int(mp->pool_ptr);
26068 mp_reallocate_pool(mp, mp->pool_ptr) ;
26069 undump_int(mp->max_str_ptr);
26070 mp_reallocate_strings (mp,mp->max_str_ptr) ;
26071 undump(0,mp->max_str_ptr,mp->str_ptr);
26072 undump(0,mp->max_str_ptr+1,s);
26073 for (k=0;k<=s-1;k++)
26074 mp->next_str[k]=k+1;
26075 for (k=s;k<=mp->max_str_ptr;k++)
26076 undump(s+1,mp->max_str_ptr+1,mp->next_str[k]);
26077 mp->fixed_str_use=0;
26080 undump(0,mp->pool_ptr,mp->str_start[k]);
26081 if ( k==mp->str_ptr ) break;
26082 mp->str_ref[k]=max_str_ref;
26083 incr(mp->fixed_str_use);
26084 mp->last_fixed_str=k; k=mp->next_str[k];
26087 while ( k+4<mp->pool_ptr ) {
26088 undump_four_ASCII; k=k+4;
26090 k=mp->pool_ptr-4; undump_four_ASCII;
26091 mp->init_str_use=mp->fixed_str_use; mp->init_pool_ptr=mp->pool_ptr;
26092 mp->max_pool_ptr=mp->pool_ptr;
26093 mp->strs_used_up=mp->fixed_str_use;
26094 mp->pool_in_use=mp->str_start[mp->str_ptr]; mp->strs_in_use=mp->fixed_str_use;
26095 mp->max_pl_used=mp->pool_in_use; mp->max_strs_used=mp->strs_in_use;
26096 mp->pact_count=0; mp->pact_chars=0; mp->pact_strs=0;
26098 @ By sorting the list of available spaces in the variable-size portion of
26099 |mem|, we are usually able to get by without having to dump very much
26100 of the dynamic memory.
26102 We recompute |var_used| and |dyn_used|, so that \.{INIMP} dumps valid
26103 information even when it has not been gathering statistics.
26105 @<Dump the dynamic memory@>=
26106 mp_sort_avail(mp); mp->var_used=0;
26107 dump_int(mp->lo_mem_max); dump_int(mp->rover);
26108 p=0; q=mp->rover; x=0;
26110 for (k=p;k<= q+1;k++)
26111 dump_wd(mp->mem[k]);
26112 x=x+q+2-p; mp->var_used=mp->var_used+q-p;
26113 p=q+node_size(q); q=rlink(q);
26114 } while (q!=mp->rover);
26115 mp->var_used=mp->var_used+mp->lo_mem_max-p;
26116 mp->dyn_used=mp->mem_end+1-mp->hi_mem_min;
26117 for (k=p;k<= mp->lo_mem_max;k++ )
26118 dump_wd(mp->mem[k]);
26119 x=x+mp->lo_mem_max+1-p;
26120 dump_int(mp->hi_mem_min); dump_int(mp->avail);
26121 for (k=mp->hi_mem_min;k<=mp->mem_end;k++ )
26122 dump_wd(mp->mem[k]);
26123 x=x+mp->mem_end+1-mp->hi_mem_min;
26125 while ( p!=null ) {
26126 decr(mp->dyn_used); p=link(p);
26128 dump_int(mp->var_used); dump_int(mp->dyn_used);
26129 mp_print_ln(mp); mp_print_int(mp, x);
26130 mp_print(mp, " memory locations dumped; current usage is ");
26131 mp_print_int(mp, mp->var_used); mp_print_char(mp, '&'); mp_print_int(mp, mp->dyn_used)
26133 @ @<Undump the dynamic memory@>=
26134 undump(lo_mem_stat_max+1000,hi_mem_stat_min-1,mp->lo_mem_max);
26135 undump(lo_mem_stat_max+1,mp->lo_mem_max,mp->rover);
26138 for (k=p;k<= q+1; k++)
26139 undump_wd(mp->mem[k]);
26141 if ( (p>mp->lo_mem_max)||((q>=rlink(q))&&(rlink(q)!=mp->rover)) )
26144 } while (q!=mp->rover);
26145 for (k=p;k<=mp->lo_mem_max;k++ )
26146 undump_wd(mp->mem[k]);
26147 undump(mp->lo_mem_max+1,hi_mem_stat_min,mp->hi_mem_min);
26148 undump(null,mp->mem_top,mp->avail); mp->mem_end=mp->mem_top;
26149 mp->last_pending=spec_head;
26150 for (k=mp->hi_mem_min;k<= mp->mem_end;k++)
26151 undump_wd(mp->mem[k]);
26152 undump_int(mp->var_used); undump_int(mp->dyn_used)
26154 @ A different scheme is used to compress the hash table, since its lower region
26155 is usually sparse. When |text(p)<>0| for |p<=hash_used|, we output three
26156 words: |p|, |hash[p]|, and |eqtb[p]|. The hash table is, of course, densely
26157 packed for |p>=hash_used|, so the remaining entries are output in~a~block.
26159 @<Dump the table of equivalents and the hash table@>=
26160 dump_int(mp->hash_used);
26161 mp->st_count=frozen_inaccessible-1-mp->hash_used;
26162 for (p=1;p<=mp->hash_used;p++) {
26163 if ( text(p)!=0 ) {
26164 dump_int(p); dump_hh(mp->hash[p]); dump_hh(mp->eqtb[p]); incr(mp->st_count);
26167 for (p=mp->hash_used+1;p<=(int)hash_end;p++) {
26168 dump_hh(mp->hash[p]); dump_hh(mp->eqtb[p]);
26170 dump_int(mp->st_count);
26171 mp_print_ln(mp); mp_print_int(mp, mp->st_count); mp_print(mp, " symbolic tokens")
26173 @ @<Undump the table of equivalents and the hash table@>=
26174 undump(1,frozen_inaccessible,mp->hash_used);
26177 undump(p+1,mp->hash_used,p);
26178 undump_hh(mp->hash[p]); undump_hh(mp->eqtb[p]);
26179 } while (p!=mp->hash_used);
26180 for (p=mp->hash_used+1;p<=(int)hash_end;p++ ) {
26181 undump_hh(mp->hash[p]); undump_hh(mp->eqtb[p]);
26183 undump_int(mp->st_count)
26185 @ We have already printed a lot of statistics, so we set |mp_tracing_stats:=0|
26186 to prevent them appearing again.
26188 @<Dump a few more things and the closing check word@>=
26189 dump_int(mp->max_internal);
26190 dump_int(mp->int_ptr);
26191 for (k=1;k<= mp->int_ptr;k++ ) {
26192 dump_int(mp->internal[k]);
26193 dump_string(mp->int_name[k]);
26195 dump_int(mp->start_sym);
26196 dump_int(mp->interaction);
26197 dump_string(mp->mem_ident);
26198 dump_int(mp->bg_loc); dump_int(mp->eg_loc); dump_int(mp->serial_no); dump_int(69073);
26199 mp->internal[mp_tracing_stats]=0
26201 @ @<Undump a few more things and the closing check word@>=
26203 if (x>mp->max_internal) mp_grow_internals(mp,x);
26204 undump_int(mp->int_ptr);
26205 for (k=1;k<= mp->int_ptr;k++) {
26206 undump_int(mp->internal[k]);
26207 undump_string(mp->int_name[k]);
26209 undump(0,frozen_inaccessible,mp->start_sym);
26210 if (mp->interaction==mp_unspecified_mode) {
26211 undump(mp_unspecified_mode,mp_error_stop_mode,mp->interaction);
26213 undump(mp_unspecified_mode,mp_error_stop_mode,x);
26215 undump_string(mp->mem_ident);
26216 undump(1,hash_end,mp->bg_loc);
26217 undump(1,hash_end,mp->eg_loc);
26218 undump_int(mp->serial_no);
26220 if (x!=69073) goto OFF_BASE
26222 @ @<Create the |mem_ident|...@>=
26224 xfree(mp->mem_ident);
26225 mp->mem_ident = xmalloc(256,1);
26226 char *tmp = xmalloc(11,1);
26227 sprintf(tmp,"%04d.%02d.%02d",
26228 (int)mp_round_unscaled(mp, mp->internal[mp_year]),
26229 (int)mp_round_unscaled(mp, mp->internal[mp_month]),
26230 (int)mp_round_unscaled(mp, mp->internal[mp_day]));
26231 mp_snprintf(mp->mem_ident,256," (mem=%s %s)",mp->job_name, tmp);
26233 mp_pack_job_name(mp, ".mem");
26234 while (! mp_w_open_out(mp, &mp->mem_file) )
26235 mp_prompt_file_name(mp, "mem file name", ".mem");
26236 mp_print_nl(mp, "Beginning to dump on file ");
26237 @.Beginning to dump...@>
26238 mp_print(mp, mp->name_of_file);
26239 mp_print_nl(mp, mp->mem_ident);
26242 @ @<Dealloc variables@>=
26243 xfree(mp->mem_ident);
26245 @ @<Close the mem file@>=
26246 (mp->close_file)(mp,mp->mem_file)
26248 @* \[46] The main program.
26249 This is it: the part of \MP\ that executes all those procedures we have
26252 Well---almost. We haven't put the parsing subroutines into the
26253 program yet; and we'd better leave space for a few more routines that may
26254 have been forgotten.
26256 @c @<Declare the basic parsing subroutines@>
26257 @<Declare miscellaneous procedures that were declared |forward|@>
26258 @<Last-minute procedures@>
26260 @ We've noted that there are two versions of \MP. One, called \.{INIMP},
26262 has to be run first; it initializes everything from scratch, without
26263 reading a mem file, and it has the capability of dumping a mem file.
26264 The other one is called `\.{VIRMP}'; it is a ``virgin'' program that needs
26266 to input a mem file in order to get started. \.{VIRMP} typically has
26267 a bit more memory capacity than \.{INIMP}, because it does not need the
26268 space consumed by the dumping/undumping routines and the numerous calls on
26271 The \.{VIRMP} program cannot read a mem file instantaneously, of course;
26272 the best implementations therefore allow for production versions of \MP\ that
26273 not only avoid the loading routine for object code, they also have
26274 a mem file pre-loaded.
26276 @ @<Option variables@>=
26277 int ini_version; /* are we iniMP? */
26279 @ @<Set |ini_version|@>=
26280 mp->ini_version = (opt->ini_version ? true : false);
26282 @ The code below make the final chosen hash size the next larger
26283 multiple of 2 from the requested size, and this array is a list of
26284 suitable prime numbers to go with such values.
26286 The top limit is chosen such that it is definately lower than
26287 |max_halfword-3*param_size|, because |param_size| cannot be larger
26288 than |max_halfword/sizeof(pointer)|.
26291 static int mp_prime_choices[] =
26292 { 12289, 24593, 49157, 98317,
26293 196613, 393241, 786433, 1572869,
26294 3145739, 6291469, 12582917, 25165843,
26295 50331653, 100663319 };
26297 @ @<Find constant sizes@>=
26298 if (mp->ini_version) {
26300 set_value(mp->mem_top,opt->main_memory,5000);
26301 mp->mem_max = mp->mem_top;
26302 set_value(mp->param_size,opt->param_size,150);
26303 set_value(mp->max_in_open,opt->max_in_open,10);
26304 if (opt->hash_size>0x8000000)
26305 opt->hash_size=0x8000000;
26306 set_value(mp->hash_size,(2*opt->hash_size-1),16384);
26307 mp->hash_size = mp->hash_size>>i;
26308 while (mp->hash_size>=2) {
26309 mp->hash_size /= 2;
26312 mp->hash_size = mp->hash_size << i;
26313 if (mp->hash_size>0x8000000)
26314 mp->hash_size=0x8000000;
26315 mp->hash_prime=mp_prime_choices[(i-14)];
26318 if (mp->command_line != NULL && *(mp->command_line) == '&') {
26320 char *cmd = mp->command_line+1;
26321 xfree(mp->mem_name); /* just in case */
26322 mp->mem_name = mp_xstrdup(mp,cmd);
26323 while (*cmd && *cmd!=' ') cmd++;
26324 if (*cmd==' ') *cmd++ = '\0';
26326 s = mp_xstrdup(mp,cmd);
26328 xfree(mp->command_line);
26329 mp->command_line = s;
26331 if (mp->mem_name == NULL) {
26332 mp->mem_name = mp_xstrdup(mp,"plain");
26334 if (mp_open_mem_file(mp)) {
26335 @<Undump constants for consistency check@>;
26336 set_value(mp->mem_max,opt->main_memory,mp->mem_top);
26340 wterm_ln("(Fatal mem file error; I'm stymied)\n");
26341 mp->history = mp_fatal_error_stop;
26347 @ Here we do whatever is needed to complete \MP's job gracefully on the
26348 local operating system. The code here might come into play after a fatal
26349 error; it must therefore consist entirely of ``safe'' operations that
26350 cannot produce error messages. For example, it would be a mistake to call
26351 |str_room| or |make_string| at this time, because a call on |overflow|
26352 might lead to an infinite loop.
26353 @^system dependencies@>
26355 This program doesn't bother to close the input files that may still be open.
26357 @ @<Last-minute...@>=
26358 void mp_close_files_and_terminate (MP mp) {
26359 integer k; /* all-purpose index */
26360 integer LH; /* the length of the \.{TFM} header, in words */
26361 int lk_offset; /* extra words inserted at beginning of |lig_kern| array */
26362 pointer p; /* runs through a list of \.{TFM} dimensions */
26363 @<Close all open files in the |rd_file| and |wr_file| arrays@>;
26364 if ( mp->internal[mp_tracing_stats]>0 )
26365 @<Output statistics about this job@>;
26367 @<Do all the finishing work on the \.{TFM} file@>;
26368 @<Explain what output files were written@>;
26369 if ( mp->log_opened && ! mp->noninteractive ){
26371 (mp->close_file)(mp,mp->log_file);
26372 mp->selector=mp->selector-2;
26373 if ( mp->selector==term_only ) {
26374 mp_print_nl(mp, "Transcript written on ");
26375 @.Transcript written...@>
26376 mp_print(mp, mp->log_name); mp_print_char(mp, '.');
26380 mp->finished = true;
26383 @ @<Declarations@>=
26384 void mp_close_files_and_terminate (MP mp) ;
26386 @ @<Close all open files in the |rd_file| and |wr_file| arrays@>=
26387 if (mp->rd_fname!=NULL) {
26388 for (k=0;k<=(int)mp->read_files-1;k++ ) {
26389 if ( mp->rd_fname[k]!=NULL ) {
26390 (mp->close_file)(mp,mp->rd_file[k]);
26391 xfree(mp->rd_fname[k]);
26395 if (mp->wr_fname!=NULL) {
26396 for (k=0;k<=(int)mp->write_files-1;k++) {
26397 if ( mp->wr_fname[k]!=NULL ) {
26398 (mp->close_file)(mp,mp->wr_file[k]);
26399 xfree(mp->wr_fname[k]);
26405 for (k=0;k<(int)mp->max_read_files;k++ ) {
26406 if ( mp->rd_fname[k]!=NULL ) {
26407 (mp->close_file)(mp,mp->rd_file[k]);
26408 xfree(mp->rd_fname[k]);
26411 xfree(mp->rd_file);
26412 xfree(mp->rd_fname);
26413 for (k=0;k<(int)mp->max_write_files;k++) {
26414 if ( mp->wr_fname[k]!=NULL ) {
26415 (mp->close_file)(mp,mp->wr_file[k]);
26416 xfree(mp->wr_fname[k]);
26419 xfree(mp->wr_file);
26420 xfree(mp->wr_fname);
26423 @ We want to produce a \.{TFM} file if and only if |mp_fontmaking| is positive.
26425 We reclaim all of the variable-size memory at this point, so that
26426 there is no chance of another memory overflow after the memory capacity
26427 has already been exceeded.
26429 @<Do all the finishing work on the \.{TFM} file@>=
26430 if ( mp->internal[mp_fontmaking]>0 ) {
26431 @<Make the dynamic memory into one big available node@>;
26432 @<Massage the \.{TFM} widths@>;
26433 mp_fix_design_size(mp); mp_fix_check_sum(mp);
26434 @<Massage the \.{TFM} heights, depths, and italic corrections@>;
26435 mp->internal[mp_fontmaking]=0; /* avoid loop in case of fatal error */
26436 @<Finish the \.{TFM} file@>;
26439 @ @<Make the dynamic memory into one big available node@>=
26440 mp->rover=lo_mem_stat_max+1; link(mp->rover)=empty_flag; mp->lo_mem_max=mp->hi_mem_min-1;
26441 if ( mp->lo_mem_max-mp->rover>max_halfword ) mp->lo_mem_max=max_halfword+mp->rover;
26442 node_size(mp->rover)=mp->lo_mem_max-mp->rover;
26443 llink(mp->rover)=mp->rover; rlink(mp->rover)=mp->rover;
26444 link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null
26446 @ The present section goes directly to the log file instead of using
26447 |print| commands, because there's no need for these strings to take
26448 up |str_pool| memory when a non-{\bf stat} version of \MP\ is being used.
26450 @<Output statistics...@>=
26451 if ( mp->log_opened ) {
26454 wlog_ln("Here is how much of MetaPost's memory you used:");
26455 @.Here is how much...@>
26456 mp_snprintf(s,128," %i string%s out of %i",(int)mp->max_strs_used-mp->init_str_use,
26457 (mp->max_strs_used!=mp->init_str_use+1 ? "s" : ""),
26458 (int)(mp->max_strings-1-mp->init_str_use));
26460 mp_snprintf(s,128," %i string characters out of %i",
26461 (int)mp->max_pl_used-mp->init_pool_ptr,
26462 (int)mp->pool_size-mp->init_pool_ptr);
26464 mp_snprintf(s,128," %i words of memory out of %i",
26465 (int)mp->lo_mem_max+mp->mem_end-mp->hi_mem_min+2,
26468 mp_snprintf(s,128," %i symbolic tokens out of %i", (int)mp->st_count, (int)mp->hash_size);
26470 mp_snprintf(s,128," %ii,%in,%ip,%ib stack positions out of %ii,%in,%ip,%ib",
26471 (int)mp->max_in_stack,(int)mp->int_ptr,
26472 (int)mp->max_param_stack,(int)mp->max_buf_stack+1,
26473 (int)mp->stack_size,(int)mp->max_internal,(int)mp->param_size,(int)mp->buf_size);
26475 mp_snprintf(s,128," %i string compactions (moved %i characters, %i strings)",
26476 (int)mp->pact_count,(int)mp->pact_chars,(int)mp->pact_strs);
26480 @ It is nice to have have some of the stats available from the API.
26482 @<Exported function ...@>=
26483 int mp_memory_usage (MP mp );
26484 int mp_hash_usage (MP mp );
26485 int mp_param_usage (MP mp );
26486 int mp_open_usage (MP mp );
26489 int mp_memory_usage (MP mp ) {
26490 return (int)mp->lo_mem_max+mp->mem_end-mp->hi_mem_min+2;
26492 int mp_hash_usage (MP mp ) {
26493 return (int)mp->st_count;
26495 int mp_param_usage (MP mp ) {
26496 return (int)mp->max_param_stack;
26498 int mp_open_usage (MP mp ) {
26499 return (int)mp->max_in_stack;
26502 @ We get to the |final_cleanup| routine when \&{end} or \&{dump} has
26505 @<Last-minute...@>=
26506 void mp_final_cleanup (MP mp) {
26507 small_number c; /* 0 for \&{end}, 1 for \&{dump} */
26509 if ( mp->job_name==NULL ) mp_open_log_file(mp);
26510 while ( mp->input_ptr>0 ) {
26511 if ( token_state ) mp_end_token_list(mp);
26512 else mp_end_file_reading(mp);
26514 while ( mp->loop_ptr!=null ) mp_stop_iteration(mp);
26515 while ( mp->open_parens>0 ) {
26516 mp_print(mp, " )"); decr(mp->open_parens);
26518 while ( mp->cond_ptr!=null ) {
26519 mp_print_nl(mp, "(end occurred when ");
26520 @.end occurred...@>
26521 mp_print_cmd_mod(mp, fi_or_else,mp->cur_if);
26522 /* `\.{if}' or `\.{elseif}' or `\.{else}' */
26523 if ( mp->if_line!=0 ) {
26524 mp_print(mp, " on line "); mp_print_int(mp, mp->if_line);
26526 mp_print(mp, " was incomplete)");
26527 mp->if_line=if_line_field(mp->cond_ptr);
26528 mp->cur_if=name_type(mp->cond_ptr); mp->cond_ptr=link(mp->cond_ptr);
26530 if ( mp->history!=mp_spotless )
26531 if ( ((mp->history==mp_warning_issued)||(mp->interaction<mp_error_stop_mode)) )
26532 if ( mp->selector==term_and_log ) {
26533 mp->selector=term_only;
26534 mp_print_nl(mp, "(see the transcript file for additional information)");
26535 @.see the transcript file...@>
26536 mp->selector=term_and_log;
26539 if (mp->ini_version) {
26540 mp_store_mem_file(mp); return;
26542 mp_print_nl(mp, "(dump is performed only by INIMP)"); return;
26543 @.dump...only by INIMP@>
26547 @ @<Declarations@>=
26548 void mp_final_cleanup (MP mp) ;
26549 void mp_init_prim (MP mp) ;
26550 void mp_init_tab (MP mp) ;
26552 @ @<Last-minute...@>=
26553 void mp_init_prim (MP mp) { /* initialize all the primitives */
26557 void mp_init_tab (MP mp) { /* initialize other tables */
26558 integer k; /* all-purpose index */
26559 @<Initialize table entries (done by \.{INIMP} only)@>;
26563 @ When we begin the following code, \MP's tables may still contain garbage;
26564 thus we must proceed cautiously to get bootstrapped in.
26566 But when we finish this part of the program, \MP\ is ready to call on the
26567 |main_control| routine to do its work.
26569 @<Get the first line...@>=
26571 @<Initialize the input routines@>;
26572 if (mp->mem_ident==NULL) {
26573 if ( ! mp_load_mem_file(mp) ) {
26574 (mp->close_file)(mp, mp->mem_file);
26575 mp->history = mp_fatal_error_stop;
26578 (mp->close_file)(mp, mp->mem_file);
26580 @<Initializations following first line@>;
26583 @ @<Initializations following first line@>=
26584 mp->buffer[limit]='%';
26585 mp_fix_date_and_time(mp);
26586 if (mp->random_seed==0)
26587 mp->random_seed = (mp->internal[mp_time] / unity)+mp->internal[mp_day];
26588 mp_init_randoms(mp, mp->random_seed);
26589 @<Initialize the print |selector|...@>;
26590 if ( loc<limit ) if ( mp->buffer[loc]!='\\' )
26591 mp_start_input(mp); /* \&{input} assumed */
26593 @ @<Run inimpost commands@>=
26595 mp_get_strings_started(mp);
26596 mp_init_tab(mp); /* initialize the tables */
26597 mp_init_prim(mp); /* call |primitive| for each primitive */
26598 mp->init_str_use=mp->str_ptr; mp->init_pool_ptr=mp->pool_ptr;
26599 mp->max_str_ptr=mp->str_ptr; mp->max_pool_ptr=mp->pool_ptr;
26600 mp_fix_date_and_time(mp);
26603 @ Saving the filename template
26605 @<Save the filename template@>=
26607 if ( mp->filename_template!=0 ) delete_str_ref(mp->filename_template);
26608 if ( length(mp->cur_exp)==0 ) mp->filename_template=0;
26610 mp->filename_template=mp->cur_exp; add_str_ref(mp->filename_template);
26614 @* \[47] Debugging.
26617 @* \[48] System-dependent changes.
26618 This section should be replaced, if necessary, by any special
26619 modification of the program
26620 that are necessary to make \MP\ work at a particular installation.
26621 It is usually best to design your change file so that all changes to
26622 previous sections preserve the section numbering; then everybody's version
26623 will be consistent with the published program. More extensive changes,
26624 which introduce new sections, can be inserted here; then only the index
26625 itself will get a new section number.
26626 @^system dependencies@>
26629 Here is where you can find all uses of each identifier in the program,
26630 with underlined entries pointing to where the identifier was defined.
26631 If the identifier is only one letter long, however, you get to see only
26632 the underlined entries. {\sl All references are to section numbers instead of
26635 This index also lists error messages and other aspects of the program
26636 that you might want to look up some day. For example, the entry
26637 for ``system dependencies'' lists all sections that should receive
26638 special attention from people who are installing \MP\ in a new
26639 operating environment. A list of various things that can't happen appears
26640 under ``this can't happen''.
26641 Approximately 25 sections are listed under ``inner loop''; these account
26642 for more than 60\pct! of \MP's running time, exclusive of input and output.