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.085" /* printed when \MP\ starts */
92 @d metapost_version "1.085"
93 @d metapost_magic (('M'*256) + 'P')*65536 + 1085
98 @ The external library header for \MP\ is |mplib.h|. It contains a
99 few typedefs and the header defintions for the externally used
102 The most important of the typedefs is the definition of the structure
103 |MP_options|, that acts as a small, configurable front-end to the fairly
104 large |MP_instance| structure.
107 typedef struct MP_instance * MP;
109 typedef struct MP_options {
112 @<Exported function headers@>
114 @ The internal header file is much longer: it not only lists the complete
115 |MP_instance|, but also a lot of functions that have to be available to
116 the \ps\ backend, that is defined in a separate \.{WEB} file.
118 The variables from |MP_options| are included inside the |MP_instance|
123 typedef struct psout_data_struct * psout_data;
131 @<Types in the outer block@>
132 @<Constants in the outer block@>
133 # ifndef LIBAVL_ALLOCATOR
134 # define LIBAVL_ALLOCATOR
135 struct libavl_allocator {
136 void *(*libavl_malloc) (struct libavl_allocator *, size_t libavl_size);
137 void (*libavl_free) (struct libavl_allocator *, void *libavl_block);
140 typedef struct MP_instance {
144 @<Internal library declarations@>
154 #include <unistd.h> /* for access() */
156 #include <time.h> /* for struct tm \& co */
158 #include "psout.h" /* external header */
159 #include "mpmp.h" /* internal header */
160 #include "mppsout.h" /* internal header */
161 #include "mptfmin.h" /* mp_read_font_info */
164 @<Basic printing procedures@>
165 @<Error handling procedures@>
167 @ Here are the functions that set up the \MP\ instance.
170 MP_options *mp_options (void);
171 MP mp_initialize (MP_options *opt);
174 MP_options *mp_options (void) {
176 size_t l = sizeof(MP_options);
180 opt->ini_version = true;
185 @ @<Internal library declarations@>=
186 @<Declare subroutines for parsing file names@>
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 static MP mp_do_new (jmp_buf *buf) {
198 MP mp = malloc(sizeof(MP_instance));
203 memset(mp,0,sizeof(MP_instance));
209 static void mp_free (MP mp) {
210 int k; /* loop variable */
211 @<Dealloc variables@>
212 if (mp->noninteractive) {
213 @<Finish non-interactive use@>;
220 static void mp_do_initialize ( MP mp) {
221 @<Local variables for initialization@>
222 @<Set initial values of key variables@>
225 @ This procedure gets things started properly.
227 MP mp_initialize (MP_options *opt) {
229 jmp_buf *buf = malloc(sizeof(jmp_buf));
230 if (buf == NULL || setjmp(*buf) != 0)
235 mp->userdata=opt->userdata;
236 @<Set |ini_version|@>;
237 mp->noninteractive=opt->noninteractive;
238 set_callback_option(find_file);
239 set_callback_option(open_file);
240 set_callback_option(read_ascii_file);
241 set_callback_option(read_binary_file);
242 set_callback_option(close_file);
243 set_callback_option(eof_file);
244 set_callback_option(flush_file);
245 set_callback_option(write_ascii_file);
246 set_callback_option(write_binary_file);
247 set_callback_option(shipout_backend);
248 if (opt->banner && *(opt->banner)) {
249 mp->banner = xstrdup(opt->banner);
251 mp->banner = xstrdup(default_banner);
253 if (opt->command_line && *(opt->command_line))
254 mp->command_line = xstrdup(opt->command_line);
255 if (mp->noninteractive) {
256 @<Prepare function pointers for non-interactive use@>;
258 /* open the terminal for output */
260 @<Find constant sizes@>;
261 @<Allocate or initialize variables@>
262 mp_reallocate_memory(mp,mp->mem_max);
263 mp_reallocate_paths(mp,1000);
264 mp_reallocate_fonts(mp,8);
265 mp->history=mp_fatal_error_stop; /* in case we quit during initialization */
266 @<Check the ``constant'' values...@>;
269 mp_snprintf(ss,256,"Ouch---my internal constants have been clobbered!\n"
270 "---case %i",(int)mp->bad);
271 do_fprintf(mp->err_out,(char *)ss);
275 mp_do_initialize(mp); /* erase preloaded mem */
276 if (mp->ini_version) {
277 @<Run inimpost commands@>;
279 if (!mp->noninteractive) {
280 @<Initialize the output routines@>;
281 @<Get the first line of input and prepare to start@>;
282 @<Initializations after first line is read@>;
284 mp->history=mp_spotless;
289 @ @<Initializations after first line is read@>=
291 mp_init_map_file(mp, mp->troff_mode);
292 mp->history=mp_spotless; /* ready to go! */
293 if (mp->troff_mode) {
294 mp->internal[mp_gtroffmode]=unity;
295 mp->internal[mp_prologues]=unity;
297 if ( mp->start_sym>0 ) { /* insert the `\&{everyjob}' symbol */
298 mp->cur_sym=mp->start_sym; mp_back_input(mp);
301 @ @<Exported function headers@>=
302 extern MP_options *mp_options (void);
303 extern MP mp_initialize (MP_options *opt) ;
304 extern int mp_status(MP mp);
305 extern void *mp_userdata(MP mp);
308 int mp_status(MP mp) { return mp->history; }
311 void *mp_userdata(MP mp) { return mp->userdata; }
313 @ The overall \MP\ program begins with the heading just shown, after which
314 comes a bunch of procedure declarations and function declarations.
315 Finally we will get to the main program, which begins with the
316 comment `|start_here|'. If you want to skip down to the
317 main program now, you can look up `|start_here|' in the index.
318 But the author suggests that the best way to understand this program
319 is to follow pretty much the order of \MP's components as they appear in the
320 \.{WEB} description you are now reading, since the present ordering is
321 intended to combine the advantages of the ``bottom up'' and ``top down''
322 approaches to the problem of understanding a somewhat complicated system.
324 @ Some of the code below is intended to be used only when diagnosing the
325 strange behavior that sometimes occurs when \MP\ is being installed or
326 when system wizards are fooling around with \MP\ without quite knowing
327 what they are doing. Such code will not normally be compiled; it is
328 delimited by the preprocessor test `|#ifdef DEBUG .. #endif|'.
330 @ This program has two important variations: (1) There is a long and slow
331 version called \.{INIMP}, which does the extra calculations needed to
333 initialize \MP's internal tables; and (2)~there is a shorter and faster
334 production version, which cuts the initialization to a bare minimum.
336 Which is which is decided at runtime.
338 @ The following parameters can be changed at compile time to extend or
339 reduce \MP's capacity. They may have different values in \.{INIMP} and
340 in production versions of \MP.
342 @^system dependencies@>
345 #define file_name_size 255 /* file names shouldn't be longer than this */
346 #define bistack_size 1500 /* size of stack for bisection algorithms;
347 should probably be left at this value */
349 @ Like the preceding parameters, the following quantities can be changed
350 to extend or reduce \MP's capacity. But if they are changed,
351 it is necessary to rerun the initialization program \.{INIMP}
353 to generate new tables for the production \MP\ program.
354 One can't simply make helter-skelter changes to the following constants,
355 since certain rather complex initialization
356 numbers are computed from them.
359 int max_strings; /* maximum number of strings; must not exceed |max_halfword| */
360 int pool_size; /* maximum number of characters in strings, including all
361 error messages and help texts, and the names of all identifiers */
362 int mem_max; /* greatest index in \MP's internal |mem| array;
363 must be strictly less than |max_halfword|;
364 must be equal to |mem_top| in \.{INIMP}, otherwise |>=mem_top| */
365 int mem_top; /* largest index in the |mem| array dumped by \.{INIMP};
366 must not be greater than |mem_max| */
367 int hash_prime; /* a prime number equal to about 85\pct! of |hash_size| */
369 @ @<Option variables@>=
370 int error_line; /* width of context lines on terminal error messages */
371 int half_error_line; /* width of first lines of contexts in terminal
372 error messages; should be between 30 and |error_line-15| */
373 int max_print_line; /* width of longest text lines output; should be at least 60 */
374 unsigned hash_size; /* maximum number of symbolic tokens,
375 must be less than |max_halfword-3*param_size| */
376 int param_size; /* maximum number of simultaneous macro parameters */
377 int max_in_open; /* maximum number of input files and error insertions that
378 can be going on simultaneously */
379 int main_memory; /* only for options, to set up |mem_max| and |mem_top| */
380 void *userdata; /* this allows the calling application to setup local */
381 char *banner; /* the banner that is printed to the screen and log */
383 @ @<Dealloc variables@>=
387 @d set_value(a,b,c) do { a=c; if (b>c) a=b; } while (0)
392 set_value(mp->error_line,opt->error_line,79);
393 set_value(mp->half_error_line,opt->half_error_line,50);
394 if (mp->half_error_line>mp->error_line-15 )
395 mp->half_error_line = mp->error_line-15;
396 set_value(mp->max_print_line,opt->max_print_line,100);
398 @ In case somebody has inadvertently made bad settings of the ``constants,''
399 \MP\ checks them using a global variable called |bad|.
401 This is the second of many sections of \MP\ where global variables are
405 integer bad; /* is some ``constant'' wrong? */
407 @ Later on we will say `\ignorespaces|if (mem_max>=max_halfword) bad=10;|',
408 or something similar. (We can't do that until |max_halfword| has been defined.)
410 In case you are wondering about the non-consequtive values of |bad|: some
411 of the things that used to be WEB constants are now runtime variables
412 with checking at assignment time.
414 @<Check the ``constant'' values for consistency@>=
416 if ( mp->mem_top<=1100 ) mp->bad=4;
418 @ Some |goto| labels are used by the following definitions. The label
419 `|restart|' is occasionally used at the very beginning of a procedure; and
420 the label `|reswitch|' is occasionally used just prior to a |case|
421 statement in which some cases change the conditions and we wish to branch
422 to the newly applicable case. Loops that are set up with the |loop|
423 construction defined below are commonly exited by going to `|done|' or to
424 `|found|' or to `|not_found|', and they are sometimes repeated by going to
425 `|continue|'. If two or more parts of a subroutine start differently but
426 end up the same, the shared code may be gathered together at
429 @ Here are some macros for common programming idioms.
431 @d incr(A) (A)=(A)+1 /* increase a variable by unity */
432 @d decr(A) (A)=(A)-1 /* decrease a variable by unity */
433 @d negate(A) (A)=-(A) /* change the sign of a variable */
434 @d double(A) (A)=(A)+(A)
436 @d do_nothing /* empty statement */
438 @* \[2] The character set.
439 In order to make \MP\ readily portable to a wide variety of
440 computers, all of its input text is converted to an internal eight-bit
441 code that includes standard ASCII, the ``American Standard Code for
442 Information Interchange.'' This conversion is done immediately when each
443 character is read in. Conversely, characters are converted from ASCII to
444 the user's external representation just before they are output to a
448 Such an internal code is relevant to users of \MP\ only with respect to
449 the \&{char} and \&{ASCII} operations, and the comparison of strings.
451 @ Characters of text that have been converted to \MP's internal form
452 are said to be of type |ASCII_code|, which is a subrange of the integers.
455 typedef unsigned char ASCII_code; /* eight-bit numbers */
457 @ The present specification of \MP\ has been written under the assumption
458 that the character set contains at least the letters and symbols associated
459 with ASCII codes 040 through 0176; all of these characters are now
460 available on most computer terminals.
463 typedef unsigned char text_char; /* the data type of characters in text files */
465 @ @<Local variables for init...@>=
468 @ The \MP\ processor converts between ASCII code and
469 the user's external character set by means of arrays |xord| and |xchr|
470 that are analogous to Pascal's |ord| and |chr| functions.
472 @d xchr(A) mp->xchr[(A)]
473 @d xord(A) mp->xord[(A)]
476 ASCII_code xord[256]; /* specifies conversion of input characters */
477 text_char xchr[256]; /* specifies conversion of output characters */
479 @ The core system assumes all 8-bit is acceptable. If it is not,
480 a change file has to alter the below section.
481 @^system dependencies@>
483 Additionally, people with extended character sets can
484 assign codes arbitrarily, giving an |xchr| equivalent to whatever
485 characters the users of \MP\ are allowed to have in their input files.
486 Appropriate changes to \MP's |char_class| table should then be made.
487 (Unlike \TeX, each installation of \MP\ has a fixed assignment of category
488 codes, called the |char_class|.) Such changes make portability of programs
489 more difficult, so they should be introduced cautiously if at all.
490 @^character set dependencies@>
491 @^system dependencies@>
494 for (i=0;i<=0377;i++) { xchr(i)=(text_char)i; }
496 @ The following system-independent code makes the |xord| array contain a
497 suitable inverse to the information in |xchr|. Note that if |xchr[i]=xchr[j]|
498 where |i<j<0177|, the value of |xord[xchr[i]]| will turn out to be
499 |j| or more; hence, standard ASCII code numbers will be used instead of
500 codes below 040 in case there is a coincidence.
503 for (i=0;i<=255;i++) {
506 for (i=0200;i<=0377;i++) { xord(xchr(i))=(ASCII_code)i;}
507 for (i=0;i<=0176;i++) { xord(xchr(i))=(ASCII_code)i;}
509 @* \[3] Input and output.
510 The bane of portability is the fact that different operating systems treat
511 input and output quite differently, perhaps because computer scientists
512 have not given sufficient attention to this problem. People have felt somehow
513 that input and output are not part of ``real'' programming. Well, it is true
514 that some kinds of programming are more fun than others. With existing
515 input/output conventions being so diverse and so messy, the only sources of
516 joy in such parts of the code are the rare occasions when one can find a
517 way to make the program a little less bad than it might have been. We have
518 two choices, either to attack I/O now and get it over with, or to postpone
519 I/O until near the end. Neither prospect is very attractive, so let's
522 The basic operations we need to do are (1)~inputting and outputting of
523 text, to or from a file or the user's terminal; (2)~inputting and
524 outputting of eight-bit bytes, to or from a file; (3)~instructing the
525 operating system to initiate (``open'') or to terminate (``close'') input or
526 output from a specified file; (4)~testing whether the end of an input
527 file has been reached; (5)~display of bits on the user's screen.
528 The bit-display operation will be discussed in a later section; we shall
529 deal here only with more traditional kinds of I/O.
531 @ Finding files happens in a slightly roundabout fashion: the \MP\
532 instance object contains a field that holds a function pointer that finds a
533 file, and returns its name, or NULL. For this, it receives three
534 parameters: the non-qualified name |fname|, the intended |fopen|
535 operation type |fmode|, and the type of the file |ftype|.
537 The file types that are passed on in |ftype| can be used to
538 differentiate file searches if a library like kpathsea is used,
539 the fopen mode is passed along for the same reason.
542 typedef unsigned char eight_bits ; /* unsigned one-byte quantity */
544 @ @<Exported types@>=
546 mp_filetype_terminal = 0, /* the terminal */
547 mp_filetype_error, /* the terminal */
548 mp_filetype_program , /* \MP\ language input */
549 mp_filetype_log, /* the log file */
550 mp_filetype_postscript, /* the postscript output */
551 mp_filetype_memfile, /* memory dumps */
552 mp_filetype_metrics, /* TeX font metric files */
553 mp_filetype_fontmap, /* PostScript font mapping files */
554 mp_filetype_font, /* PostScript type1 font programs */
555 mp_filetype_encoding, /* PostScript font encoding files */
556 mp_filetype_text /* first text file for readfrom and writeto primitives */
558 typedef char *(*mp_file_finder)(MP, const char *, const char *, int);
559 typedef void *(*mp_file_opener)(MP, const char *, const char *, int);
560 typedef char *(*mp_file_reader)(MP, void *, size_t *);
561 typedef void (*mp_binfile_reader)(MP, void *, void **, size_t *);
562 typedef void (*mp_file_closer)(MP, void *);
563 typedef int (*mp_file_eoftest)(MP, void *);
564 typedef void (*mp_file_flush)(MP, void *);
565 typedef void (*mp_file_writer)(MP, void *, const char *);
566 typedef void (*mp_binfile_writer)(MP, void *, void *, size_t);
568 @ @<Option variables@>=
569 mp_file_finder find_file;
570 mp_file_opener open_file;
571 mp_file_reader read_ascii_file;
572 mp_binfile_reader read_binary_file;
573 mp_file_closer close_file;
574 mp_file_eoftest eof_file;
575 mp_file_flush flush_file;
576 mp_file_writer write_ascii_file;
577 mp_binfile_writer write_binary_file;
579 @ The default function for finding files is |mp_find_file|. It is
580 pretty stupid: it will only find files in the current directory.
582 This function may disappear altogether, it is currently only
583 used for the default font map file.
586 static char *mp_find_file (MP mp, const char *fname, const char *fmode, int ftype) {
588 if (fmode[0] != 'r' || (! access (fname,R_OK)) || ftype) {
589 return mp_strdup(fname);
594 @ Because |mp_find_file| is used so early, it has to be in the helpers
598 static char *mp_find_file (MP mp, const char *fname, const char *fmode, int ftype) ;
599 static void *mp_open_file (MP mp , const char *fname, const char *fmode, int ftype) ;
600 static char *mp_read_ascii_file (MP mp, void *f, size_t *size) ;
601 static void mp_read_binary_file (MP mp, void *f, void **d, size_t *size) ;
602 static void mp_close_file (MP mp, void *f) ;
603 static int mp_eof_file (MP mp, void *f) ;
604 static void mp_flush_file (MP mp, void *f) ;
605 static void mp_write_ascii_file (MP mp, void *f, const char *s) ;
606 static void mp_write_binary_file (MP mp, void *f, void *s, size_t t) ;
608 @ The function to open files can now be very short.
611 void *mp_open_file(MP mp, const char *fname, const char *fmode, int ftype) {
614 realmode[0] = *fmode;
617 if (ftype==mp_filetype_terminal) {
618 return (fmode[0] == 'r' ? stdin : stdout);
619 } else if (ftype==mp_filetype_error) {
621 } else if (fname != NULL && (fmode[0] != 'r' || (! access (fname,R_OK)))) {
622 return (void *)fopen(fname, realmode);
627 @ This is a legacy interface: (almost) all file names pass through |name_of_file|.
630 char name_of_file[file_name_size+1]; /* the name of a system file */
631 int name_length;/* this many characters are actually
632 relevant in |name_of_file| (the rest are blank) */
634 @ @<Option variables@>=
635 int print_found_names; /* configuration parameter */
637 @ If this parameter is true, the terminal and log will report the found
638 file names for input files instead of the requested ones.
639 It is off by default because it creates an extra filename lookup.
641 @<Allocate or initialize ...@>=
642 mp->print_found_names = (opt->print_found_names>0 ? true : false);
644 @ \MP's file-opening procedures return |false| if no file identified by
645 |name_of_file| could be opened.
647 The |OPEN_FILE| macro takes care of the |print_found_names| parameter.
648 It is not used for opening a mem file for read, because that file name
652 if (mp->print_found_names) {
653 char *s = (mp->find_file)(mp,mp->name_of_file,A,ftype);
655 *f = (mp->open_file)(mp,mp->name_of_file,A, ftype);
656 strncpy(mp->name_of_file,s,file_name_size);
662 *f = (mp->open_file)(mp,mp->name_of_file,A, ftype);
665 return (*f ? true : false)
668 static boolean mp_a_open_in (MP mp, void **f, int ftype) {
669 /* open a text file for input */
673 boolean mp_w_open_in (MP mp, void **f) {
674 /* open a word file for input */
675 *f = (mp->open_file)(mp,mp->name_of_file,"r",mp_filetype_memfile);
676 return (*f ? true : false);
679 static boolean mp_a_open_out (MP mp, void **f, int ftype) {
680 /* open a text file for output */
684 static boolean mp_b_open_out (MP mp, void **f, int ftype) {
685 /* open a binary file for output */
689 static boolean mp_w_open_out (MP mp, void **f) {
690 /* open a word file for output */
691 int ftype = mp_filetype_memfile;
696 static char *mp_read_ascii_file (MP mp, void *ff, size_t *size) {
698 size_t len = 0, lim = 128;
700 FILE *f = (FILE *)ff;
702 (void) mp; /* for -Wunused */
709 if (s==NULL) return NULL;
710 while (c!=EOF && c!='\n' && c!='\r') {
712 s =realloc(s, (lim+(lim>>2)));
713 if (s==NULL) return NULL;
721 if (c!=EOF && c!='\n')
730 void mp_write_ascii_file (MP mp, void *f, const char *s) {
738 void mp_read_binary_file (MP mp, void *f, void **data, size_t *size) {
742 len = fread(*data,1,*size,(FILE *)f);
747 void mp_write_binary_file (MP mp, void *f, void *s, size_t size) {
750 (void)fwrite(s,size,1,(FILE *)f);
755 void mp_close_file (MP mp, void *f) {
762 int mp_eof_file (MP mp, void *f) {
765 return feof((FILE *)f);
771 void mp_flush_file (MP mp, void *f) {
777 @ Input from text files is read one line at a time, using a routine called
778 |input_ln|. This function is defined in terms of global variables called
779 |buffer|, |first|, and |last| that will be described in detail later; for
780 now, it suffices for us to know that |buffer| is an array of |ASCII_code|
781 values, and that |first| and |last| are indices into this array
782 representing the beginning and ending of a line of text.
785 size_t buf_size; /* maximum number of characters simultaneously present in
786 current lines of open files */
787 ASCII_code *buffer; /* lines of characters being read */
788 size_t first; /* the first unused position in |buffer| */
789 size_t last; /* end of the line just input to |buffer| */
790 size_t max_buf_stack; /* largest index used in |buffer| */
792 @ @<Allocate or initialize ...@>=
794 mp->buffer = xmalloc((mp->buf_size+1),sizeof(ASCII_code));
796 @ @<Dealloc variables@>=
800 static void mp_reallocate_buffer(MP mp, size_t l) {
802 if (l>max_halfword) {
803 mp_confusion(mp,"buffer size"); /* can't happen (I hope) */
805 buffer = xmalloc((l+1),sizeof(ASCII_code));
806 memcpy(buffer,mp->buffer,(mp->buf_size+1));
808 mp->buffer = buffer ;
812 @ The |input_ln| function brings the next line of input from the specified
813 field into available positions of the buffer array and returns the value
814 |true|, unless the file has already been entirely read, in which case it
815 returns |false| and sets |last:=first|. In general, the |ASCII_code|
816 numbers that represent the next line of the file are input into
817 |buffer[first]|, |buffer[first+1]|, \dots, |buffer[last-1]|; and the
818 global variable |last| is set equal to |first| plus the length of the
819 line. Trailing blanks are removed from the line; thus, either |last=first|
820 (in which case the line was entirely blank) or |buffer[last-1]<>" "|.
823 The variable |max_buf_stack|, which is used to keep track of how large
824 the |buf_size| parameter must be to accommodate the present job, is
825 also kept up to date by |input_ln|.
828 static boolean mp_input_ln (MP mp, void *f ) {
829 /* inputs the next line or returns |false| */
832 mp->last=mp->first; /* cf.\ Matthew 19\thinspace:\thinspace30 */
833 s = (mp->read_ascii_file)(mp,f, &size);
837 mp->last = mp->first+size;
838 if ( mp->last>=mp->max_buf_stack ) {
839 mp->max_buf_stack=mp->last+1;
840 while ( mp->max_buf_stack>=mp->buf_size ) {
841 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
844 memcpy((mp->buffer+mp->first),s,size);
845 /* while ( mp->buffer[mp->last]==' ' ) mp->last--; */
851 @ The user's terminal acts essentially like other files of text, except
852 that it is used both for input and for output. When the terminal is
853 considered an input file, the file variable is called |term_in|, and when it
854 is considered an output file the file variable is |term_out|.
855 @^system dependencies@>
858 void * term_in; /* the terminal as an input file */
859 void * term_out; /* the terminal as an output file */
860 void * err_out; /* the terminal as an output file */
862 @ Here is how to open the terminal files. In the default configuration,
863 nothing happens except that the command line (if there is one) is copied
864 to the input buffer. The variable |command_line| will be filled by the
865 |main| procedure. The copying can not be done earlier in the program
866 logic because in the |INI| version, the |buffer| is also used for primitive
869 @d t_open_out do {/* open the terminal for text output */
870 mp->term_out = (mp->open_file)(mp,"terminal", "w", mp_filetype_terminal);
871 mp->err_out = (mp->open_file)(mp,"error", "w", mp_filetype_error);
873 @d t_open_in do { /* open the terminal for text input */
874 mp->term_in = (mp->open_file)(mp,"terminal", "r", mp_filetype_terminal);
875 if (mp->command_line!=NULL) {
876 mp->last = strlen(mp->command_line);
877 strncpy((char *)mp->buffer,mp->command_line,mp->last);
878 xfree(mp->command_line);
884 @<Option variables@>=
887 @ Sometimes it is necessary to synchronize the input/output mixture that
888 happens on the user's terminal, and three system-dependent
889 procedures are used for this
890 purpose. The first of these, |update_terminal|, is called when we want
891 to make sure that everything we have output to the terminal so far has
892 actually left the computer's internal buffers and been sent.
893 The second, |clear_terminal|, is called when we wish to cancel any
894 input that the user may have typed ahead (since we are about to
895 issue an unexpected error message). The third, |wake_up_terminal|,
896 is supposed to revive the terminal if the user has disabled it by
897 some instruction to the operating system. The following macros show how
898 these operations can be specified:
899 @^system dependencies@>
901 @d update_terminal (mp->flush_file)(mp,mp->term_out) /* empty the terminal output buffer */
902 @d clear_terminal do_nothing /* clear the terminal input buffer */
903 @d wake_up_terminal (mp->flush_file)(mp,mp->term_out)
904 /* cancel the user's cancellation of output */
906 @ We need a special routine to read the first line of \MP\ input from
907 the user's terminal. This line is different because it is read before we
908 have opened the transcript file; there is sort of a ``chicken and
909 egg'' problem here. If the user types `\.{input cmr10}' on the first
910 line, or if some macro invoked by that line does such an \.{input},
911 the transcript file will be named `\.{cmr10.log}'; but if no \.{input}
912 commands are performed during the first line of terminal input, the transcript
913 file will acquire its default name `\.{mpout.log}'. (The transcript file
914 will not contain error messages generated by the first line before the
915 first \.{input} command.)
917 The first line is even more special. It's nice to let the user start
918 running a \MP\ job by typing a command line like `\.{MP cmr10}'; in
919 such a case, \MP\ will operate as if the first line of input were
920 `\.{cmr10}', i.e., the first line will consist of the remainder of the
921 command line, after the part that invoked \MP.
923 @ Different systems have different ways to get started. But regardless of
924 what conventions are adopted, the routine that initializes the terminal
925 should satisfy the following specifications:
927 \yskip\textindent{1)}It should open file |term_in| for input from the
928 terminal. (The file |term_out| will already be open for output to the
931 \textindent{2)}If the user has given a command line, this line should be
932 considered the first line of terminal input. Otherwise the
933 user should be prompted with `\.{**}', and the first line of input
934 should be whatever is typed in response.
936 \textindent{3)}The first line of input, which might or might not be a
937 command line, should appear in locations |first| to |last-1| of the
940 \textindent{4)}The global variable |loc| should be set so that the
941 character to be read next by \MP\ is in |buffer[loc]|. This
942 character should not be blank, and we should have |loc<last|.
944 \yskip\noindent(It may be necessary to prompt the user several times
945 before a non-blank line comes in. The prompt is `\.{**}' instead of the
946 later `\.*' because the meaning is slightly different: `\.{input}' need
947 not be typed immediately after~`\.{**}'.)
949 @d loc mp->cur_input.loc_field /* location of first unread character in |buffer| */
952 boolean mp_init_terminal (MP mp) { /* gets the terminal input started */
955 loc = 0; mp->first = 0;
959 if (!mp->noninteractive) {
960 wake_up_terminal; do_fprintf(mp->term_out,"**"); update_terminal;
963 if ( ! mp_input_ln(mp, mp->term_in ) ) { /* this shouldn't happen */
964 do_fprintf(mp->term_out,"\n! End of file on the terminal... why?");
965 @.End of file on the terminal@>
968 loc=(halfword)mp->first;
969 while ( (loc<(int)mp->last)&&(mp->buffer[loc]==' ') )
971 if ( loc<(int)mp->last ) {
972 return true; /* return unless the line was all blank */
974 if (!mp->noninteractive) {
975 do_fprintf(mp->term_out,"Please type the name of your input file.\n");
981 static boolean mp_init_terminal (MP mp) ;
984 @* \[4] String handling.
985 Symbolic token names and diagnostic messages are variable-length strings
986 of eight-bit characters. Many strings \MP\ uses are simply literals
987 in the compiled source, like the error messages and the names of the
988 internal parameters. Other strings are used or defined from the \MP\ input
989 language, and these have to be interned.
991 \MP\ uses strings more extensively than \MF\ does, but the necessary
992 operations can still be handled with a fairly simple data structure.
993 The array |str_pool| contains all of the (eight-bit) ASCII codes in all
994 of the strings, and the array |str_start| contains indices of the starting
995 points of each string. Strings are referred to by integer numbers, so that
996 string number |s| comprises the characters |str_pool[j]| for
997 |str_start[s]<=j<str_start[ss]| where |ss=next_str[s]|. The string pool
998 is allocated sequentially and |str_pool[pool_ptr]| is the next unused
999 location. The first string number not currently in use is |str_ptr|
1000 and |next_str[str_ptr]| begins a list of free string numbers. String
1001 pool entries |str_start[str_ptr]| up to |pool_ptr| are reserved for a
1002 string currently being constructed.
1004 String numbers 0 to 255 are reserved for strings that correspond to single
1005 ASCII characters. This is in accordance with the conventions of \.{WEB},
1007 which converts single-character strings into the ASCII code number of the
1008 single character involved, while it converts other strings into integers
1009 and builds a string pool file. Thus, when the string constant \.{"."} appears
1010 in the program below, \.{WEB} converts it into the integer 46, which is the
1011 ASCII code for a period, while \.{WEB} will convert a string like \.{"hello"}
1012 into some integer greater than~255. String number 46 will presumably be the
1013 single character `\..'\thinspace; but some ASCII codes have no standard visible
1014 representation, and \MP\ may need to be able to print an arbitrary
1015 ASCII character, so the first 256 strings are used to specify exactly what
1016 should be printed for each of the 256 possibilities.
1019 typedef int pool_pointer; /* for variables that point into |str_pool| */
1020 typedef int str_number; /* for variables that point into |str_start| */
1023 ASCII_code *str_pool; /* the characters */
1024 pool_pointer *str_start; /* the starting pointers */
1025 str_number *next_str; /* for linking strings in order */
1026 pool_pointer pool_ptr; /* first unused position in |str_pool| */
1027 str_number str_ptr; /* number of the current string being created */
1028 pool_pointer init_pool_ptr; /* the starting value of |pool_ptr| */
1029 str_number init_str_use; /* the initial number of strings in use */
1030 pool_pointer max_pool_ptr; /* the maximum so far of |pool_ptr| */
1031 str_number max_str_ptr; /* the maximum so far of |str_ptr| */
1033 @ @<Allocate or initialize ...@>=
1034 mp->str_pool = xmalloc ((mp->pool_size +1),sizeof(ASCII_code));
1035 mp->str_start = xmalloc ((mp->max_strings+1),sizeof(pool_pointer));
1036 mp->next_str = xmalloc ((mp->max_strings+1),sizeof(str_number));
1038 @ @<Dealloc variables@>=
1039 xfree(mp->str_pool);
1040 xfree(mp->str_start);
1041 xfree(mp->next_str);
1043 @ Most printing is done from |char *|s, but sometimes not. Here are
1044 functions that convert an internal string into a |char *| for use
1045 by the printing routines, and vice versa.
1047 @d str(A) mp_str(mp,A)
1048 @d rts(A) mp_rts(mp,A)
1052 int mp_xstrcmp (const char *a, const char *b);
1053 char * mp_str (MP mp, str_number s);
1056 static str_number mp_rts (MP mp, const char *s);
1057 static str_number mp_make_string (MP mp);
1060 int mp_xstrcmp (const char *a, const char *b) {
1061 if (a==NULL && b==NULL)
1070 @ The attempt to catch interrupted strings that is in |mp_rts|, is not
1071 very good: it does not handle nesting over more than one level.
1074 char * mp_str (MP mp, str_number ss) {
1077 if (ss==mp->str_ptr) {
1080 len = (size_t)length(ss);
1081 s = xmalloc(len+1,sizeof(char));
1082 strncpy(s,(char *)(mp->str_pool+(mp->str_start[ss])),len);
1087 str_number mp_rts (MP mp, const char *s) {
1088 int r; /* the new string */
1089 int old; /* a possible string in progress */
1093 } else if (strlen(s)==1) {
1097 str_room((integer)strlen(s));
1098 if (mp->str_start[mp->str_ptr]<mp->pool_ptr)
1099 old = mp_make_string(mp);
1104 r = mp_make_string(mp);
1106 str_room(length(old));
1107 while (i<length(old)) {
1108 append_char((mp->str_start[old]+i));
1110 mp_flush_string(mp,old);
1116 @ Except for |strs_used_up|, the following string statistics are only
1117 maintained when code between |stat| $\ldots$ |tats| delimiters is not
1121 integer strs_used_up; /* strings in use or unused but not reclaimed */
1122 integer pool_in_use; /* total number of cells of |str_pool| actually in use */
1123 integer strs_in_use; /* total number of strings actually in use */
1124 integer max_pl_used; /* maximum |pool_in_use| so far */
1125 integer max_strs_used; /* maximum |strs_in_use| so far */
1127 @ Several of the elementary string operations are performed using \.{WEB}
1128 macros instead of functions, because many of the
1129 operations are done quite frequently and we want to avoid the
1130 overhead of procedure calls. For example, here is
1131 a simple macro that computes the length of a string.
1134 @d str_stop(A) mp->str_start[mp->next_str[(A)]] /* one cell past the end of string \# */
1135 @d length(A) (str_stop((A))-mp->str_start[(A)]) /* the number of characters in string \# */
1137 @ The length of the current string is called |cur_length|. If we decide that
1138 the current string is not needed, |flush_cur_string| resets |pool_ptr| so that
1139 |cur_length| becomes zero.
1141 @d cur_length (mp->pool_ptr - mp->str_start[mp->str_ptr])
1142 @d flush_cur_string mp->pool_ptr=mp->str_start[mp->str_ptr]
1144 @ Strings are created by appending character codes to |str_pool|.
1145 The |append_char| macro, defined here, does not check to see if the
1146 value of |pool_ptr| has gotten too high; this test is supposed to be
1147 made before |append_char| is used.
1149 To test if there is room to append |l| more characters to |str_pool|,
1150 we shall write |str_room(l)|, which tries to make sure there is enough room
1151 by compacting the string pool if necessary. If this does not work,
1152 |do_compaction| aborts \MP\ and gives an apologetic error message.
1154 @d append_char(A) /* put |ASCII_code| \# at the end of |str_pool| */
1155 { mp->str_pool[mp->pool_ptr]=(ASCII_code)(A); incr(mp->pool_ptr);
1157 @d str_room(A) /* make sure that the pool hasn't overflowed */
1158 { if ( mp->pool_ptr+(A) > mp->max_pool_ptr ) {
1159 if ( mp->pool_ptr+(A) > mp->pool_size ) mp_do_compaction(mp, (A));
1160 else mp->max_pool_ptr=mp->pool_ptr+(A); }
1163 @ The following routine is similar to |str_room(1)| but it uses the
1164 argument |mp->pool_size| to prevent |do_compaction| from aborting when
1165 string space is exhausted.
1168 static void mp_unit_str_room (MP mp);
1171 void mp_unit_str_room (MP mp) {
1172 if ( mp->pool_ptr>=mp->pool_size ) mp_do_compaction(mp, mp->pool_size);
1173 if ( mp->pool_ptr>=mp->max_pool_ptr ) mp->max_pool_ptr=mp->pool_ptr+1;
1176 @ \MP's string expressions are implemented in a brute-force way: Every
1177 new string or substring that is needed is simply copied into the string pool.
1178 Space is eventually reclaimed by a procedure called |do_compaction| with
1179 the aid of a simple system system of reference counts.
1180 @^reference counts@>
1182 The number of references to string number |s| will be |str_ref[s]|. The
1183 special value |str_ref[s]=max_str_ref=127| is used to denote an unknown
1184 positive number of references; such strings will never be recycled. If
1185 a string is ever referred to more than 126 times, simultaneously, we
1186 put it in this category. Hence a single byte suffices to store each |str_ref|.
1188 @d max_str_ref 127 /* ``infinite'' number of references */
1189 @d add_str_ref(A) { if ( mp->str_ref[(A)]<max_str_ref ) incr(mp->str_ref[(A)]); }
1194 @ @<Allocate or initialize ...@>=
1195 mp->str_ref = xmalloc ((mp->max_strings+1),sizeof(int));
1197 @ @<Dealloc variables@>=
1200 @ Here's what we do when a string reference disappears:
1202 @d delete_str_ref(A) {
1203 if ( mp->str_ref[(A)]<max_str_ref ) {
1204 if ( mp->str_ref[(A)]>1 ) decr(mp->str_ref[(A)]);
1205 else mp_flush_string(mp, (A));
1210 static void mp_flush_string (MP mp,str_number s) ;
1212 @ We can't flush the first set of static strings at all, so there
1213 is no point in trying
1216 void mp_flush_string (MP mp,str_number s) {
1218 mp->pool_in_use=mp->pool_in_use-length(s);
1219 decr(mp->strs_in_use);
1220 if ( mp->next_str[s]!=mp->str_ptr ) {
1224 decr(mp->strs_used_up);
1226 mp->pool_ptr=mp->str_start[mp->str_ptr];
1230 @ C literals cannot be simply added, they need to be set so they can't
1233 @d intern(A) mp_intern(mp,(A))
1236 str_number mp_intern (MP mp, const char *s) {
1239 mp->str_ref[r] = max_str_ref;
1244 static str_number mp_intern (MP mp, const char *s);
1247 @ Once a sequence of characters has been appended to |str_pool|, it
1248 officially becomes a string when the function |make_string| is called.
1249 This function returns the identification number of the new string as its
1252 When getting the next unused string number from the linked list, we pretend
1254 $$ \hbox{|max_str_ptr+1|, |max_str_ptr+2|, $\ldots$, |mp->max_strings|} $$
1255 are linked sequentially even though the |next_str| entries have not been
1256 initialized yet. We never allow |str_ptr| to reach |mp->max_strings|;
1257 |do_compaction| is responsible for making sure of this.
1260 static str_number mp_make_string (MP mp);
1263 str_number mp_make_string (MP mp) { /* current string enters the pool */
1264 str_number s; /* the new string */
1267 mp->str_ptr=mp->next_str[s];
1268 if ( mp->str_ptr>mp->max_str_ptr ) {
1269 if ( mp->str_ptr==mp->max_strings ) {
1271 mp_do_compaction(mp, 0);
1274 mp->max_str_ptr=mp->str_ptr;
1275 mp->next_str[mp->str_ptr]=mp->max_str_ptr+1;
1279 mp->str_start[mp->str_ptr]=mp->pool_ptr;
1280 incr(mp->strs_used_up);
1281 incr(mp->strs_in_use);
1282 mp->pool_in_use=mp->pool_in_use+length(s);
1283 if ( mp->pool_in_use>mp->max_pl_used )
1284 mp->max_pl_used=mp->pool_in_use;
1285 if ( mp->strs_in_use>mp->max_strs_used )
1286 mp->max_strs_used=mp->strs_in_use;
1290 @ The most interesting string operation is string pool compaction. The idea
1291 is to recover unused space in the |str_pool| array by recopying the strings
1292 to close the gaps created when some strings become unused. All string
1293 numbers~$k$ where |str_ref[k]=0| are to be linked into the list of free string
1294 numbers after |str_ptr|. If this fails to free enough pool space we issue an
1295 |overflow| error unless |needed=mp->pool_size|. Calling |do_compaction|
1296 with |needed=mp->pool_size| supresses all overflow tests.
1298 The compaction process starts with |last_fixed_str| because all lower numbered
1299 strings are permanently allocated with |max_str_ref| in their |str_ref| entries.
1302 str_number last_fixed_str; /* last permanently allocated string */
1303 str_number fixed_str_use; /* number of permanently allocated strings */
1306 static void mp_do_compaction (MP mp, pool_pointer needed) ;
1309 void mp_do_compaction (MP mp, pool_pointer needed) {
1310 str_number str_use; /* a count of strings in use */
1311 str_number r,s,t; /* strings being manipulated */
1312 pool_pointer p,q; /* destination and source for copying string characters */
1313 @<Advance |last_fixed_str| as far as possible and set |str_use|@>;
1314 r=mp->last_fixed_str;
1317 while ( s!=mp->str_ptr ) {
1318 while ( mp->str_ref[s]==0 ) {
1319 @<Advance |s| and add the old |s| to the list of free string numbers;
1320 then |break| if |s=str_ptr|@>;
1322 r=s; s=mp->next_str[s];
1324 @<Move string |r| back so that |str_start[r]=p|; make |p| the location
1325 after the end of the string@>;
1328 @<Move the current string back so that it starts at |p|@>;
1329 if ( needed<mp->pool_size ) {
1330 @<Make sure that there is room for another string with |needed| characters@>;
1332 @<Account for the compaction and make sure the statistics agree with the
1334 mp->strs_used_up=str_use;
1337 @ @<Advance |last_fixed_str| as far as possible and set |str_use|@>=
1338 t=mp->next_str[mp->last_fixed_str];
1339 while (t!=mp->str_ptr && mp->str_ref[t]==max_str_ref) {
1340 incr(mp->fixed_str_use);
1341 mp->last_fixed_str=t;
1344 str_use=mp->fixed_str_use
1346 @ Because of the way |flush_string| has been written, it should never be
1347 necessary to |break| here. The extra line of code seems worthwhile to
1348 preserve the generality of |do_compaction|.
1350 @<Advance |s| and add the old |s| to the list of free string numbers;...@>=
1355 mp->next_str[t]=mp->next_str[mp->str_ptr];
1356 mp->next_str[mp->str_ptr]=t;
1357 if ( s==mp->str_ptr ) goto DONE;
1360 @ The string currently starts at |str_start[r]| and ends just before
1361 |str_start[s]|. We don't change |str_start[s]| because it might be needed
1362 to locate the next string.
1364 @<Move string |r| back so that |str_start[r]=p|; make |p| the location...@>=
1367 while ( q<mp->str_start[s] ) {
1368 mp->str_pool[p]=mp->str_pool[q];
1372 @ Pointers |str_start[str_ptr]| and |pool_ptr| have not been updated. When
1373 we do this, anything between them should be moved.
1375 @ @<Move the current string back so that it starts at |p|@>=
1376 q=mp->str_start[mp->str_ptr];
1377 mp->str_start[mp->str_ptr]=p;
1378 while ( q<mp->pool_ptr ) {
1379 mp->str_pool[p]=mp->str_pool[q];
1384 @ We must remember that |str_ptr| is not allowed to reach |mp->max_strings|.
1386 @<Make sure that there is room for another string with |needed| char...@>=
1387 if ( str_use>=mp->max_strings-1 )
1388 mp_reallocate_strings (mp,str_use);
1389 if ( mp->pool_ptr+needed>mp->max_pool_ptr ) {
1390 mp_reallocate_pool(mp, mp->pool_ptr+needed);
1391 mp->max_pool_ptr=mp->pool_ptr+needed;
1395 static void mp_reallocate_strings (MP mp, str_number str_use) ;
1396 static void mp_reallocate_pool(MP mp, pool_pointer needed) ;
1399 void mp_reallocate_strings (MP mp, str_number str_use) {
1400 while ( str_use>=mp->max_strings-1 ) {
1401 int l = mp->max_strings + (mp->max_strings/4);
1402 XREALLOC (mp->str_ref, l, int);
1403 XREALLOC (mp->str_start, l, pool_pointer);
1404 XREALLOC (mp->next_str, l, str_number);
1405 mp->max_strings = l;
1408 void mp_reallocate_pool(MP mp, pool_pointer needed) {
1409 while ( needed>mp->pool_size ) {
1410 int l = mp->pool_size + (mp->pool_size/4);
1411 XREALLOC (mp->str_pool, l, ASCII_code);
1416 @ @<Account for the compaction and make sure the statistics agree with...@>=
1417 if ( (mp->str_start[mp->str_ptr]!=mp->pool_in_use)||(str_use!=mp->strs_in_use) )
1418 mp_confusion(mp, "string");
1419 @:this can't happen string}{\quad string@>
1420 incr(mp->pact_count);
1421 mp->pact_chars=mp->pact_chars+mp->pool_ptr-str_stop(mp->last_fixed_str);
1422 mp->pact_strs=mp->pact_strs+str_use-mp->fixed_str_use;
1424 @ A few more global variables are needed to keep track of statistics when
1425 |stat| $\ldots$ |tats| blocks are not commented out.
1428 integer pact_count; /* number of string pool compactions so far */
1429 integer pact_chars; /* total number of characters moved during compactions */
1430 integer pact_strs; /* total number of strings moved during compactions */
1432 @ @<Initialize compaction statistics@>=
1437 @ The following subroutine compares string |s| with another string of the
1438 same length that appears in |buffer| starting at position |k|;
1439 the result is |true| if and only if the strings are equal.
1442 static boolean mp_str_eq_buf (MP mp,str_number s, integer k) {
1443 /* test equality of strings */
1444 pool_pointer j; /* running index */
1446 while ( j<str_stop(s) ) {
1447 if ( mp->str_pool[j++]!=mp->buffer[k++] )
1453 @ Here is a similar routine, but it compares two strings in the string pool,
1454 and it does not assume that they have the same length. If the first string
1455 is lexicographically greater than, less than, or equal to the second,
1456 the result is respectively positive, negative, or zero.
1459 static integer mp_str_vs_str (MP mp, str_number s, str_number t) {
1460 /* test equality of strings */
1461 pool_pointer j,k; /* running indices */
1462 integer ls,lt; /* lengths */
1463 integer l; /* length remaining to test */
1464 ls=length(s); lt=length(t);
1465 if ( ls<=lt ) l=ls; else l=lt;
1466 j=mp->str_start[s]; k=mp->str_start[t];
1468 if ( mp->str_pool[j]!=mp->str_pool[k] ) {
1469 return (mp->str_pool[j]-mp->str_pool[k]);
1476 @ The initial values of |str_pool|, |str_start|, |pool_ptr|,
1477 and |str_ptr| are computed by the \.{INIMP} program, based in part
1478 on the information that \.{WEB} has output while processing \MP.
1483 void mp_get_strings_started (MP mp) {
1484 /* initializes the string pool,
1485 but returns |false| if something goes wrong */
1486 int k; /* small indices or counters */
1487 str_number g; /* a new string */
1488 mp->pool_ptr=0; mp->str_ptr=0; mp->max_pool_ptr=0; mp->max_str_ptr=0;
1491 mp->pool_in_use=0; mp->strs_in_use=0;
1492 mp->max_pl_used=0; mp->max_strs_used=0;
1493 @<Initialize compaction statistics@>;
1495 @<Make the first 256 strings@>;
1496 g=mp_make_string(mp); /* string 256 == "" */
1497 mp->str_ref[g]=max_str_ref;
1498 mp->last_fixed_str=mp->str_ptr-1;
1499 mp->fixed_str_use=mp->str_ptr;
1504 static void mp_get_strings_started (MP mp);
1506 @ The first 256 strings will consist of a single character only.
1508 @<Make the first 256...@>=
1509 for (k=0;k<=255;k++) {
1511 g=mp_make_string(mp);
1512 mp->str_ref[g]=max_str_ref;
1515 @ The first 128 strings will contain 95 standard ASCII characters, and the
1516 other 33 characters will be printed in three-symbol form like `\.{\^\^A}'
1517 unless a system-dependent change is made here. Installations that have
1518 an extended character set, where for example |xchr[032]=@t\.{'^^Z'}@>|,
1519 would like string 032 to be printed as the single character 032 instead
1520 of the three characters 0136, 0136, 0132 (\.{\^\^Z}). On the other hand,
1521 even people with an extended character set will want to represent string
1522 015 by \.{\^\^M}, since 015 is ASCII's ``carriage return'' code; the idea is
1523 to produce visible strings instead of tabs or line-feeds or carriage-returns
1524 or bell-rings or characters that are treated anomalously in text files.
1526 The boolean expression defined here should be |true| unless \MP\ internal
1527 code number~|k| corresponds to a non-troublesome visible symbol in the
1528 local character set.
1529 If character |k| cannot be printed, and |k<0200|, then character |k+0100| or
1530 |k-0100| must be printable; moreover, ASCII codes |[060..071, 0141..0146]|
1532 @^character set dependencies@>
1533 @^system dependencies@>
1535 @<Character |k| cannot be printed@>=
1538 @* \[5] On-line and off-line printing.
1539 Messages that are sent to a user's terminal and to the transcript-log file
1540 are produced by several `|print|' procedures. These procedures will
1541 direct their output to a variety of places, based on the setting of
1542 the global variable |selector|, which has the following possible
1546 \hang |term_and_log|, the normal setting, prints on the terminal and on the
1549 \hang |log_only|, prints only on the transcript file.
1551 \hang |term_only|, prints only on the terminal.
1553 \hang |no_print|, doesn't print at all. This is used only in rare cases
1554 before the transcript file is open.
1556 \hang |pseudo|, puts output into a cyclic buffer that is used
1557 by the |show_context| routine; when we get to that routine we shall discuss
1558 the reasoning behind this curious mode.
1560 \hang |new_string|, appends the output to the current string in the
1563 \hang |>=write_file| prints on one of the files used for the \&{write}
1564 @:write_}{\&{write} primitive@>
1568 \noindent The symbolic names `|term_and_log|', etc., have been assigned
1569 numeric codes that satisfy the convenient relations |no_print+1=term_only|,
1570 |no_print+2=log_only|, |term_only+2=log_only+1=term_and_log|. These
1571 relations are not used when |selector| could be |pseudo|, or |new_string|.
1572 We need not check for unprintable characters when |selector<pseudo|.
1574 Three additional global variables, |tally|, |term_offset| and |file_offset|
1575 record the number of characters that have been printed
1576 since they were most recently cleared to zero. We use |tally| to record
1577 the length of (possibly very long) stretches of printing; |term_offset|,
1578 and |file_offset|, on the other hand, keep track of how many
1579 characters have appeared so far on the current line that has been output
1580 to the terminal, the transcript file, or the \ps\ output file, respectively.
1582 @d new_string 0 /* printing is deflected to the string pool */
1583 @d pseudo 2 /* special |selector| setting for |show_context| */
1584 @d no_print 3 /* |selector| setting that makes data disappear */
1585 @d term_only 4 /* printing is destined for the terminal only */
1586 @d log_only 5 /* printing is destined for the transcript file only */
1587 @d term_and_log 6 /* normal |selector| setting */
1588 @d write_file 7 /* first write file selector */
1591 void * log_file; /* transcript of \MP\ session */
1592 void * ps_file; /* the generic font output goes here */
1593 unsigned int selector; /* where to print a message */
1594 unsigned char dig[23]; /* digits in a number, for rounding */
1595 integer tally; /* the number of characters recently printed */
1596 unsigned int term_offset;
1597 /* the number of characters on the current terminal line */
1598 unsigned int file_offset;
1599 /* the number of characters on the current file line */
1600 ASCII_code *trick_buf; /* circular buffer for pseudoprinting */
1601 integer trick_count; /* threshold for pseudoprinting, explained later */
1602 integer first_count; /* another variable for pseudoprinting */
1604 @ @<Allocate or initialize ...@>=
1605 mp->trick_buf = xmalloc((mp->error_line+1),sizeof(ASCII_code));
1607 @ @<Dealloc variables@>=
1608 xfree(mp->trick_buf);
1610 @ @<Initialize the output routines@>=
1611 mp->selector=term_only; mp->tally=0; mp->term_offset=0; mp->file_offset=0;
1613 @ Macro abbreviations for output to the terminal and to the log file are
1614 defined here for convenience. Some systems need special conventions
1615 for terminal output, and it is possible to adhere to those conventions
1616 by changing |wterm|, |wterm_ln|, and |wterm_cr| here.
1617 @^system dependencies@>
1619 @d do_fprintf(f,b) (mp->write_ascii_file)(mp,f,b)
1620 @d wterm(A) do_fprintf(mp->term_out,(A))
1621 @d wterm_chr(A) { unsigned char ss[2]; ss[0]=(A); ss[1]='\0';
1622 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';
1627 do_fprintf(mp->log_file,(char *)ss); }
1628 @d wlog_cr do_fprintf(mp->log_file, "\n")
1629 @d wlog_ln(A) { wlog_cr; do_fprintf(mp->log_file,(A)); }
1632 @ To end a line of text output, we call |print_ln|. Cases |0..max_write_files|
1633 use an array |wr_file| that will be declared later.
1635 @d mp_print_text(A) mp_print_str(mp,text((A)))
1638 void mp_print (MP mp, const char *s);
1641 static void mp_print_ln (MP mp);
1642 static void mp_print_visible_char (MP mp, ASCII_code s);
1643 static void mp_print_char (MP mp, ASCII_code k);
1644 static void mp_print_str (MP mp, str_number s);
1645 static void mp_print_nl (MP mp, const char *s);
1646 static void mp_print_two (MP mp,scaled x, scaled y) ;
1647 static void mp_print_scaled (MP mp,scaled s);
1649 @ @<Basic print...@>=
1650 static void mp_print_ln (MP mp) { /* prints an end-of-line */
1651 switch (mp->selector) {
1654 mp->term_offset=0; mp->file_offset=0;
1657 wlog_cr; mp->file_offset=0;
1660 wterm_cr; mp->term_offset=0;
1667 do_fprintf(mp->wr_file[(mp->selector-write_file)],"\n");
1669 } /* note that |tally| is not affected */
1671 @ The |print_visible_char| procedure sends one character to the desired
1672 destination, using the |xchr| array to map it into an external character
1673 compatible with |input_ln|. (It assumes that it is always called with
1674 a visible ASCII character.) All printing comes through |print_ln| or
1675 |print_char|, which ultimately calls |print_visible_char|, hence these
1676 routines are the ones that limit lines to at most |max_print_line| characters.
1677 But we must make an exception for the \ps\ output file since it is not safe
1678 to cut up lines arbitrarily in \ps.
1680 Procedure |unit_str_room| needs to be declared |forward| here because it calls
1681 |do_compaction| and |do_compaction| can call the error routines. Actually,
1682 |unit_str_room| avoids |overflow| errors but it can call |confusion|.
1684 @<Basic printing...@>=
1685 static void mp_print_visible_char (MP mp, ASCII_code s) { /* prints a single character */
1686 switch (mp->selector) {
1688 wterm_chr(xchr(s)); wlog_chr(xchr(s));
1689 incr(mp->term_offset); incr(mp->file_offset);
1690 if ( mp->term_offset==(unsigned)mp->max_print_line ) {
1691 wterm_cr; mp->term_offset=0;
1693 if ( mp->file_offset==(unsigned)mp->max_print_line ) {
1694 wlog_cr; mp->file_offset=0;
1698 wlog_chr(xchr(s)); incr(mp->file_offset);
1699 if ( mp->file_offset==(unsigned)mp->max_print_line ) mp_print_ln(mp);
1702 wterm_chr(xchr(s)); incr(mp->term_offset);
1703 if ( mp->term_offset==(unsigned)mp->max_print_line ) mp_print_ln(mp);
1708 if ( mp->tally<mp->trick_count )
1709 mp->trick_buf[mp->tally % mp->error_line]=s;
1712 if ( mp->pool_ptr>=mp->max_pool_ptr ) {
1713 mp_unit_str_room(mp);
1714 if ( mp->pool_ptr>=mp->pool_size )
1715 goto DONE; /* drop characters if string space is full */
1720 { text_char ss[2]; ss[0] = xchr(s); ss[1]=0;
1721 do_fprintf(mp->wr_file[(mp->selector-write_file)],(char *)ss);
1728 @ The |print_char| procedure sends one character to the desired destination.
1729 File names and string expressions might contain |ASCII_code| values that
1730 can't be printed using |print_visible_char|. These characters will be
1731 printed in three- or four-symbol form like `\.{\^\^A}' or `\.{\^\^e4}'.
1732 (This procedure assumes that it is safe to bypass all checks for unprintable
1733 characters when |selector| is in the range |0..max_write_files-1|.
1734 The user might want to write unprintable characters.
1736 @<Basic printing...@>=
1737 static void mp_print_char (MP mp, ASCII_code k) { /* prints a single character */
1738 if ( mp->selector<pseudo || mp->selector>=write_file) {
1739 mp_print_visible_char(mp, k);
1740 } else if ( @<Character |k| cannot be printed@> ) {
1743 mp_print_visible_char(mp, k+0100);
1744 } else if ( k<0200 ) {
1745 mp_print_visible_char(mp, k-0100);
1747 int l; /* small index or counter */
1749 mp_print_visible_char(mp, xord(l<10 ? l+'0' : l-10+'a'));
1751 mp_print_visible_char(mp, xord(l<10 ? l+'0' : l-10+'a'));
1754 mp_print_visible_char(mp, k);
1758 @ An entire string is output by calling |print|. Note that if we are outputting
1759 the single standard ASCII character \.c, we could call |print("c")|, since
1760 |"c"=99| is the number of a single-character string, as explained above. But
1761 |print_char("c")| is quicker, so \MP\ goes directly to the |print_char|
1762 routine when it knows that this is safe. (The present implementation
1763 assumes that it is always safe to print a visible ASCII character.)
1764 @^system dependencies@>
1767 static void mp_do_print (MP mp, const char *ss, size_t len) { /* prints string |s| */
1770 mp_print_char(mp, xord((int)ss[j])); j++;
1776 void mp_print (MP mp, const char *ss) {
1777 if (ss==NULL) return;
1778 mp_do_print(mp, ss,strlen(ss));
1780 static void mp_print_str (MP mp, str_number s) {
1781 pool_pointer j; /* current character code position */
1782 if ( (s<0)||(s>mp->max_str_ptr) ) {
1783 mp_do_print(mp,"???",3); /* this can't happen */
1787 mp_do_print(mp, (char *)(mp->str_pool+j), (size_t)(str_stop(s)-j));
1791 @ Here is the very first thing that \MP\ prints: a headline that identifies
1792 the version number and base name. The |term_offset| variable is temporarily
1793 incorrect, but the discrepancy is not serious since we assume that the banner
1794 and mem identifier together will occupy at most |max_print_line|
1795 character positions.
1797 @<Initialize the output...@>=
1799 if (mp->mem_ident!=NULL)
1800 mp_print(mp,mp->mem_ident);
1804 @ The procedure |print_nl| is like |print|, but it makes sure that the
1805 string appears at the beginning of a new line.
1808 static void mp_print_nl (MP mp, const char *s) { /* prints string |s| at beginning of line */
1809 switch(mp->selector) {
1811 if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_ln(mp);
1814 if ( mp->file_offset>0 ) mp_print_ln(mp);
1817 if ( mp->term_offset>0 ) mp_print_ln(mp);
1823 } /* there are no other cases */
1827 @ The following procedure, which prints out the decimal representation of a
1828 given integer |n|, assumes that all integers fit nicely into a |int|.
1829 @^system dependencies@>
1832 static void mp_print_int (MP mp,integer n) { /* prints an integer in decimal form */
1834 mp_snprintf(s,12,"%d", (int)n);
1839 static void mp_print_int (MP mp,integer n);
1841 @ \MP\ also makes use of a trivial procedure to print two digits. The
1842 following subroutine is usually called with a parameter in the range |0<=n<=99|.
1845 static void mp_print_dd (MP mp,integer n) { /* prints two least significant digits */
1847 mp_print_char(mp, xord('0'+(n / 10)));
1848 mp_print_char(mp, xord('0'+(n % 10)));
1853 static void mp_print_dd (MP mp,integer n);
1855 @ Here is a procedure that asks the user to type a line of input,
1856 assuming that the |selector| setting is either |term_only| or |term_and_log|.
1857 The input is placed into locations |first| through |last-1| of the
1858 |buffer| array, and echoed on the transcript file if appropriate.
1860 This procedure is never called when |interaction<mp_scroll_mode|.
1862 @d prompt_input(A) do {
1863 if (!mp->noninteractive) {
1864 wake_up_terminal; mp_print(mp, (A));
1867 } while (0) /* prints a string and gets a line of input */
1870 void mp_term_input (MP mp) { /* gets a line from the terminal */
1871 size_t k; /* index into |buffer| */
1872 if (mp->noninteractive) {
1873 if (!mp_input_ln(mp, mp->term_in ))
1874 longjmp(*(mp->jump_buf),1); /* chunk finished */
1875 mp->buffer[mp->last]=xord('%');
1877 update_terminal; /* Now the user sees the prompt for sure */
1878 if (!mp_input_ln(mp, mp->term_in )) {
1879 mp_fatal_error(mp, "End of file on the terminal!");
1880 @.End of file on the terminal@>
1882 mp->term_offset=0; /* the user's line ended with \<\rm return> */
1883 decr(mp->selector); /* prepare to echo the input */
1884 if ( mp->last!=mp->first ) {
1885 for (k=mp->first;k<=mp->last-1;k++) {
1886 mp_print_char(mp, mp->buffer[k]);
1890 mp->buffer[mp->last]=xord('%');
1891 incr(mp->selector); /* restore previous status */
1895 @* \[6] Reporting errors.
1896 When something anomalous is detected, \MP\ typically does something like this:
1897 $$\vbox{\halign{#\hfil\cr
1898 |print_err("Something anomalous has been detected");|\cr
1899 |help3("This is the first line of my offer to help.")|\cr
1900 |("This is the second line. I'm trying to")|\cr
1901 |("explain the best way for you to proceed.");|\cr
1903 A two-line help message would be given using |help2|, etc.; these informal
1904 helps should use simple vocabulary that complements the words used in the
1905 official error message that was printed. (Outside the U.S.A., the help
1906 messages should preferably be translated into the local vernacular. Each
1907 line of help is at most 60 characters long, in the present implementation,
1908 so that |max_print_line| will not be exceeded.)
1910 The |print_err| procedure supplies a `\.!' before the official message,
1911 and makes sure that the terminal is awake if a stop is going to occur.
1912 The |error| procedure supplies a `\..' after the official message, then it
1913 shows the location of the error; and if |interaction=error_stop_mode|,
1914 it also enters into a dialog with the user, during which time the help
1915 message may be printed.
1916 @^system dependencies@>
1918 @ The global variable |interaction| has four settings, representing increasing
1919 amounts of user interaction:
1922 enum mp_interaction_mode {
1923 mp_unspecified_mode=0, /* extra value for command-line switch */
1924 mp_batch_mode, /* omits all stops and omits terminal output */
1925 mp_nonstop_mode, /* omits all stops */
1926 mp_scroll_mode, /* omits error stops */
1927 mp_error_stop_mode /* stops at every opportunity to interact */
1930 @ @<Option variables@>=
1931 int interaction; /* current level of interaction */
1932 int noninteractive; /* do we have a terminal? */
1934 @ Set it here so it can be overwritten by the commandline
1936 @<Allocate or initialize ...@>=
1937 mp->interaction=opt->interaction;
1938 if (mp->interaction==mp_unspecified_mode || mp->interaction>mp_error_stop_mode)
1939 mp->interaction=mp_error_stop_mode;
1940 if (mp->interaction<mp_unspecified_mode)
1941 mp->interaction=mp_batch_mode;
1945 @d print_err(A) mp_print_err(mp,(A))
1948 void mp_print_err(MP mp, const char * A);
1951 void mp_print_err(MP mp, const char * A) {
1952 if ( mp->interaction==mp_error_stop_mode )
1954 mp_print_nl(mp, "! ");
1960 @ \MP\ is careful not to call |error| when the print |selector| setting
1961 might be unusual. The only possible values of |selector| at the time of
1964 \yskip\hang|no_print| (when |interaction=mp_batch_mode|
1965 and |log_file| not yet open);
1967 \hang|term_only| (when |interaction>mp_batch_mode| and |log_file| not yet open);
1969 \hang|log_only| (when |interaction=mp_batch_mode| and |log_file| is open);
1971 \hang|term_and_log| (when |interaction>mp_batch_mode| and |log_file| is open).
1973 @<Initialize the print |selector| based on |interaction|@>=
1974 if ( mp->interaction==mp_batch_mode ) mp->selector=no_print; else mp->selector=term_only
1976 @ A global variable |deletions_allowed| is set |false| if the |get_next|
1977 routine is active when |error| is called; this ensures that |get_next|
1978 will never be called recursively.
1981 The global variable |history| records the worst level of error that
1982 has been detected. It has four possible values: |spotless|, |warning_issued|,
1983 |error_message_issued|, and |fatal_error_stop|.
1985 Another global variable, |error_count|, is increased by one when an
1986 |error| occurs without an interactive dialog, and it is reset to zero at
1987 the end of every statement. If |error_count| reaches 100, \MP\ decides
1988 that there is no point in continuing further.
1991 enum mp_history_state {
1992 mp_spotless=0, /* |history| value when nothing has been amiss yet */
1993 mp_warning_issued, /* |history| value when |begin_diagnostic| has been called */
1994 mp_error_message_issued, /* |history| value when |error| has been called */
1995 mp_fatal_error_stop, /* |history| value when termination was premature */
1996 mp_system_error_stop /* |history| value when termination was due to disaster */
2000 boolean deletions_allowed; /* is it safe for |error| to call |get_next|? */
2001 int history; /* has the source input been clean so far? */
2002 int error_count; /* the number of scrolled errors since the last statement ended */
2004 @ The value of |history| is initially |fatal_error_stop|, but it will
2005 be changed to |spotless| if \MP\ survives the initialization process.
2007 @<Allocate or ...@>=
2008 mp->deletions_allowed=true; /* |history| is initialized elsewhere */
2010 @ Since errors can be detected almost anywhere in \MP, we want to declare the
2011 error procedures near the beginning of the program. But the error procedures
2012 in turn use some other procedures, which need to be declared |forward|
2013 before we get to |error| itself.
2015 It is possible for |error| to be called recursively if some error arises
2016 when |get_next| is being used to delete a token, and/or if some fatal error
2017 occurs while \MP\ is trying to fix a non-fatal one. But such recursion
2019 is never more than two levels deep.
2022 static void mp_get_next (MP mp);
2023 static void mp_term_input (MP mp);
2024 static void mp_show_context (MP mp);
2025 static void mp_begin_file_reading (MP mp);
2026 static void mp_open_log_file (MP mp);
2027 static void mp_clear_for_error_prompt (MP mp);
2030 void mp_normalize_selector (MP mp);
2032 @ Individual lines of help are recorded in the array |help_line|, which
2033 contains entries in positions |0..(help_ptr-1)|. They should be printed
2034 in reverse order, i.e., with |help_line[0]| appearing last.
2036 @d hlp1(A) mp->help_line[0]=A; }
2037 @d hlp2(A,B) mp->help_line[1]=A; hlp1(B)
2038 @d hlp3(A,B,C) mp->help_line[2]=A; hlp2(B,C)
2039 @d hlp4(A,B,C,D) mp->help_line[3]=A; hlp3(B,C,D)
2040 @d hlp5(A,B,C,D,E) mp->help_line[4]=A; hlp4(B,C,D,E)
2041 @d hlp6(A,B,C,D,E,F) mp->help_line[5]=A; hlp5(B,C,D,E,F)
2042 @d help0 mp->help_ptr=0 /* sometimes there might be no help */
2043 @d help1 { mp->help_ptr=1; hlp1 /* use this with one help line */
2044 @d help2 { mp->help_ptr=2; hlp2 /* use this with two help lines */
2045 @d help3 { mp->help_ptr=3; hlp3 /* use this with three help lines */
2046 @d help4 { mp->help_ptr=4; hlp4 /* use this with four help lines */
2047 @d help5 { mp->help_ptr=5; hlp5 /* use this with five help lines */
2048 @d help6 { mp->help_ptr=6; hlp6 /* use this with six help lines */
2051 const char * help_line[6]; /* helps for the next |error| */
2052 unsigned int help_ptr; /* the number of help lines present */
2053 boolean use_err_help; /* should the |err_help| string be shown? */
2054 str_number err_help; /* a string set up by \&{errhelp} */
2055 str_number filename_template; /* a string set up by \&{filenametemplate} */
2057 @ @<Allocate or ...@>=
2058 mp->use_err_help=false;
2060 @ The |jump_out| procedure just cuts across all active procedure levels and
2061 goes to |end_of_MP|. This is the only nonlocal |goto| statement in the
2062 whole program. It is used when there is no recovery from a particular error.
2064 The program uses a |jump_buf| to handle this, this is initialized at three
2065 spots: the start of |mp_new|, the start of |mp_initialize|, and the start
2066 of |mp_run|. Those are the only library enty points.
2068 @^system dependencies@>
2073 @ If the array of internals is still |NULL| when |jump_out| is called, a
2074 crash occured during initialization, and it is not safe to run the normal
2078 static void mp_jump_out (MP mp) {
2079 if (mp->internal!=NULL && mp->history < mp_system_error_stop)
2080 mp_close_files_and_terminate(mp);
2081 longjmp(*(mp->jump_buf),1);
2084 @ Here now is the general |error| routine.
2087 void mp_error (MP mp) { /* completes the job of error reporting */
2088 ASCII_code c; /* what the user types */
2089 integer s1,s2,s3; /* used to save global variables when deleting tokens */
2090 pool_pointer j; /* character position being printed */
2091 if ( mp->history<mp_error_message_issued )
2092 mp->history=mp_error_message_issued;
2093 mp_print_char(mp, xord('.')); mp_show_context(mp);
2094 if ((!mp->noninteractive) && (mp->interaction==mp_error_stop_mode )) {
2095 @<Get user's advice and |return|@>;
2097 incr(mp->error_count);
2098 if ( mp->error_count==100 ) {
2099 mp_print_nl(mp,"(That makes 100 errors; please try again.)");
2100 @.That makes 100 errors...@>
2101 mp->history=mp_fatal_error_stop; mp_jump_out(mp);
2103 @<Put help message on the transcript file@>;
2105 void mp_warn (MP mp, const char *msg) {
2106 unsigned saved_selector = mp->selector;
2107 mp_normalize_selector(mp);
2108 mp_print_nl(mp,"Warning: ");
2111 mp->selector = saved_selector;
2114 @ @<Exported function ...@>=
2115 extern void mp_error (MP mp);
2116 extern void mp_warn (MP mp, const char *msg);
2119 @ @<Get user's advice...@>=
2122 mp_clear_for_error_prompt(mp); prompt_input("? ");
2124 if ( mp->last==mp->first ) return;
2125 c=mp->buffer[mp->first];
2126 if ( c>='a' ) c=c+'A'-'a'; /* convert to uppercase */
2127 @<Interpret code |c| and |return| if done@>;
2130 @ It is desirable to provide an `\.E' option here that gives the user
2131 an easy way to return from \MP\ to the system editor, with the offending
2132 line ready to be edited. But such an extension requires some system
2133 wizardry, so the present implementation simply types out the name of the
2135 edited and the relevant line number.
2136 @^system dependencies@>
2139 typedef void (*mp_run_editor_command)(MP, char *, int);
2141 @ @<Option variables@>=
2142 mp_run_editor_command run_editor;
2144 @ @<Allocate or initialize ...@>=
2145 set_callback_option(run_editor);
2148 static void mp_run_editor (MP mp, char *fname, int fline);
2151 void mp_run_editor (MP mp, char *fname, int fline) {
2152 mp_print_nl(mp, "You want to edit file ");
2153 @.You want to edit file x@>
2154 mp_print(mp, fname);
2155 mp_print(mp, " at line ");
2156 mp_print_int(mp, fline);
2157 mp->interaction=mp_scroll_mode;
2162 There is a secret `\.D' option available when the debugging routines haven't
2166 @<Interpret code |c| and |return| if done@>=
2168 case '0': case '1': case '2': case '3': case '4':
2169 case '5': case '6': case '7': case '8': case '9':
2170 if ( mp->deletions_allowed ) {
2171 @<Delete |c-"0"| tokens and |continue|@>;
2175 if ( mp->file_ptr>0 ){
2176 (mp->run_editor)(mp,
2177 str(mp->input_stack[mp->file_ptr].name_field),
2182 @<Print the help information and |continue|@>;
2185 @<Introduce new material from the terminal and |return|@>;
2187 case 'Q': case 'R': case 'S':
2188 @<Change the interaction level and |return|@>;
2191 mp->interaction=mp_scroll_mode; mp_jump_out(mp);
2196 @<Print the menu of available options@>
2198 @ @<Print the menu...@>=
2200 mp_print(mp, "Type <return> to proceed, S to scroll future error messages,");
2201 @.Type <return> to proceed...@>
2202 mp_print_nl(mp, "R to run without stopping, Q to run quietly,");
2203 mp_print_nl(mp, "I to insert something, ");
2204 if ( mp->file_ptr>0 )
2205 mp_print(mp, "E to edit your file,");
2206 if ( mp->deletions_allowed )
2207 mp_print_nl(mp, "1 or ... or 9 to ignore the next 1 to 9 tokens of input,");
2208 mp_print_nl(mp, "H for help, X to quit.");
2211 @ Here the author of \MP\ apologizes for making use of the numerical
2212 relation between |"Q"|, |"R"|, |"S"|, and the desired interaction settings
2213 |mp_batch_mode|, |mp_nonstop_mode|, |mp_scroll_mode|.
2214 @^Knuth, Donald Ervin@>
2216 @<Change the interaction...@>=
2218 mp->error_count=0; mp->interaction=mp_batch_mode+c-'Q';
2219 mp_print(mp, "OK, entering ");
2221 case 'Q': mp_print(mp, "batchmode"); decr(mp->selector); break;
2222 case 'R': mp_print(mp, "nonstopmode"); break;
2223 case 'S': mp_print(mp, "scrollmode"); break;
2224 } /* there are no other cases */
2225 mp_print(mp, "..."); mp_print_ln(mp); update_terminal; return;
2228 @ When the following code is executed, |buffer[(first+1)..(last-1)]| may
2229 contain the material inserted by the user; otherwise another prompt will
2230 be given. In order to understand this part of the program fully, you need
2231 to be familiar with \MP's input stacks.
2233 @<Introduce new material...@>=
2235 mp_begin_file_reading(mp); /* enter a new syntactic level for terminal input */
2236 if ( mp->last>mp->first+1 ) {
2237 loc=(halfword)(mp->first+1); mp->buffer[mp->first]=xord(' ');
2239 prompt_input("insert>"); loc=(halfword)mp->first;
2242 mp->first=mp->last+1; mp->cur_input.limit_field=(halfword)mp->last; return;
2245 @ We allow deletion of up to 99 tokens at a time.
2247 @<Delete |c-"0"| tokens...@>=
2249 s1=mp->cur_cmd; s2=mp->cur_mod; s3=mp->cur_sym; mp->OK_to_interrupt=false;
2250 if ( (mp->last>mp->first+1) && (mp->buffer[mp->first+1]>='0')&&(mp->buffer[mp->first+1]<='9') )
2251 c=xord(c*10+mp->buffer[mp->first+1]-'0'*11);
2255 mp_get_next(mp); /* one-level recursive call of |error| is possible */
2256 @<Decrease the string reference count, if the current token is a string@>;
2259 mp->cur_cmd=s1; mp->cur_mod=s2; mp->cur_sym=s3; mp->OK_to_interrupt=true;
2260 help2("I have just deleted some text, as you asked.",
2261 "You can now delete more, or insert, or whatever.");
2262 mp_show_context(mp);
2266 @ @<Print the help info...@>=
2268 if ( mp->use_err_help ) {
2269 @<Print the string |err_help|, possibly on several lines@>;
2270 mp->use_err_help=false;
2272 if ( mp->help_ptr==0 ) {
2273 help2("Sorry, I don't know how to help in this situation.",
2274 "Maybe you should try asking a human?");
2277 decr(mp->help_ptr); mp_print(mp, mp->help_line[mp->help_ptr]); mp_print_ln(mp);
2278 } while (mp->help_ptr!=0);
2280 help4("Sorry, I already gave what help I could...",
2281 "Maybe you should try asking a human?",
2282 "An error might have occurred before I noticed any problems.",
2283 "``If all else fails, read the instructions.''");
2287 @ @<Print the string |err_help|, possibly on several lines@>=
2288 j=mp->str_start[mp->err_help];
2289 while ( j<str_stop(mp->err_help) ) {
2290 if ( mp->str_pool[j]!='%' ) mp_print_str(mp, mp->str_pool[j]);
2291 else if ( j+1==str_stop(mp->err_help) ) mp_print_ln(mp);
2292 else if ( mp->str_pool[j+1]!='%' ) mp_print_ln(mp);
2293 else { j++; mp_print_char(mp, xord('%')); };
2297 @ @<Put help message on the transcript file@>=
2298 if ( mp->interaction>mp_batch_mode ) decr(mp->selector); /* avoid terminal output */
2299 if ( mp->use_err_help ) {
2300 mp_print_nl(mp, "");
2301 @<Print the string |err_help|, possibly on several lines@>;
2303 while ( mp->help_ptr>0 ){
2304 decr(mp->help_ptr); mp_print_nl(mp, mp->help_line[mp->help_ptr]);
2308 if ( mp->interaction>mp_batch_mode ) incr(mp->selector); /* re-enable terminal output */
2311 @ In anomalous cases, the print selector might be in an unknown state;
2312 the following subroutine is called to fix things just enough to keep
2313 running a bit longer.
2316 void mp_normalize_selector (MP mp) {
2317 if ( mp->log_opened ) mp->selector=term_and_log;
2318 else mp->selector=term_only;
2319 if ( mp->job_name==NULL) mp_open_log_file(mp);
2320 if ( mp->interaction==mp_batch_mode ) decr(mp->selector);
2323 @ The following procedure prints \MP's last words before dying.
2325 @d succumb { if ( mp->interaction==mp_error_stop_mode )
2326 mp->interaction=mp_scroll_mode; /* no more interaction */
2327 if ( mp->log_opened ) mp_error(mp);
2328 mp->history=mp_fatal_error_stop; mp_jump_out(mp); /* irrecoverable error */
2332 void mp_fatal_error (MP mp, const char *s) { /* prints |s|, and that's it */
2333 mp_normalize_selector(mp);
2334 print_err("Emergency stop"); help1(s); succumb;
2338 @ @<Exported function ...@>=
2339 extern void mp_fatal_error (MP mp, const char *s);
2342 @ Here is the most dreaded error message.
2345 void mp_overflow (MP mp, const char *s, integer n) { /* stop due to finiteness */
2347 mp_normalize_selector(mp);
2348 mp_snprintf(msg, 256, "MetaPost capacity exceeded, sorry [%s=%d]",s,(int)n);
2349 @.MetaPost capacity exceeded ...@>
2351 help2("If you really absolutely need more capacity,",
2352 "you can ask a wizard to enlarge me.");
2356 @ @<Internal library declarations@>=
2357 void mp_overflow (MP mp, const char *s, integer n);
2359 @ The program might sometime run completely amok, at which point there is
2360 no choice but to stop. If no previous error has been detected, that's bad
2361 news; a message is printed that is really intended for the \MP\
2362 maintenance person instead of the user (unless the user has been
2363 particularly diabolical). The index entries for `this can't happen' may
2364 help to pinpoint the problem.
2367 @<Internal library ...@>=
2368 void mp_confusion (MP mp, const char *s);
2370 @ Consistency check violated; |s| tells where.
2372 void mp_confusion (MP mp, const char *s) {
2374 mp_normalize_selector(mp);
2375 if ( mp->history<mp_error_message_issued ) {
2376 mp_snprintf(msg, 256, "This can't happen (%s)",s);
2377 @.This can't happen@>
2379 help1("I'm broken. Please show this to someone who can fix can fix");
2381 print_err("I can\'t go on meeting you like this");
2382 @.I can't go on...@>
2383 help2("One of your faux pas seems to have wounded me deeply...",
2384 "in fact, I'm barely conscious. Please fix it and try again.");
2389 @ Users occasionally want to interrupt \MP\ while it's running.
2390 If the runtime system allows this, one can implement
2391 a routine that sets the global variable |interrupt| to some nonzero value
2392 when such an interrupt is signaled. Otherwise there is probably at least
2393 a way to make |interrupt| nonzero using the C debugger.
2394 @^system dependencies@>
2397 @d check_interrupt { if ( mp->interrupt!=0 )
2398 mp_pause_for_instructions(mp); }
2401 integer interrupt; /* should \MP\ pause for instructions? */
2402 boolean OK_to_interrupt; /* should interrupts be observed? */
2403 integer run_state; /* are we processing input ?*/
2404 boolean finished; /* set true by |close_files_and_terminate| */
2406 @ @<Allocate or ...@>=
2407 mp->OK_to_interrupt=true;
2410 @ When an interrupt has been detected, the program goes into its
2411 highest interaction level and lets the user have the full flexibility of
2412 the |error| routine. \MP\ checks for interrupts only at times when it is
2416 static void mp_pause_for_instructions (MP mp) {
2417 if ( mp->OK_to_interrupt ) {
2418 mp->interaction=mp_error_stop_mode;
2419 if ( (mp->selector==log_only)||(mp->selector==no_print) )
2421 print_err("Interruption");
2424 "Try to insert some instructions for me (e.g.,`I show x'),",
2425 "unless you just want to quit by typing `X'.");
2426 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
2431 @ Many of \MP's error messages state that a missing token has been
2432 inserted behind the scenes. We can save string space and program space
2433 by putting this common code into a subroutine.
2436 static void mp_missing_err (MP mp, const char *s) {
2438 mp_snprintf(msg, 256, "Missing `%s' has been inserted", s);
2439 @.Missing...inserted@>
2443 @* \[7] Arithmetic with scaled numbers.
2444 The principal computations performed by \MP\ are done entirely in terms of
2445 integers less than $2^{31}$ in magnitude; thus, the arithmetic specified in this
2446 program can be carried out in exactly the same way on a wide variety of
2447 computers, including some small ones.
2450 But C does not rigidly define the |/| operation in the case of negative
2451 dividends; for example, the result of |(-2*n-1) / 2| is |-(n+1)| on some
2452 computers and |-n| on others (is this true ?). There are two principal
2453 types of arithmetic: ``translation-preserving,'' in which the identity
2454 |(a+q*b)/b=(a/b)+q| is valid; and ``negation-preserving,'' in which
2455 |(-a)/b=-(a/b)|. This leads to two \MP s, which can produce
2456 different results, although the differences should be negligible when the
2457 language is being used properly. The \TeX\ processor has been defined
2458 carefully so that both varieties of arithmetic will produce identical
2459 output, but it would be too inefficient to constrain \MP\ in a similar way.
2461 @d el_gordo 0x7fffffff /* $2^{31}-1$, the largest value that \MP\ likes */
2464 @ One of \MP's most common operations is the calculation of
2465 $\lfloor{a+b\over2}\rfloor$,
2466 the midpoint of two given integers |a| and~|b|. The most decent way to do
2467 this is to write `|(a+b)/2|'; but on many machines it is more efficient
2468 to calculate `|(a+b)>>1|'.
2470 Therefore the midpoint operation will always be denoted by `|half(a+b)|'
2471 in this program. If \MP\ is being implemented with languages that permit
2472 binary shifting, the |half| macro should be changed to make this operation
2473 as efficient as possible. Since some systems have shift operators that can
2474 only be trusted to work on positive numbers, there is also a macro |halfp|
2475 that is used only when the quantity being halved is known to be positive
2478 @d half(A) ((A) / 2)
2479 @d halfp(A) (integer)((unsigned)(A) >> 1)
2481 @ A single computation might use several subroutine calls, and it is
2482 desirable to avoid producing multiple error messages in case of arithmetic
2483 overflow. So the routines below set the global variable |arith_error| to |true|
2484 instead of reporting errors directly to the user.
2485 @^overflow in arithmetic@>
2488 boolean arith_error; /* has arithmetic overflow occurred recently? */
2490 @ @<Allocate or ...@>=
2491 mp->arith_error=false;
2493 @ At crucial points the program will say |check_arith|, to test if
2494 an arithmetic error has been detected.
2496 @d check_arith { if ( mp->arith_error ) mp_clear_arith(mp); }
2499 static void mp_clear_arith (MP mp) {
2500 print_err("Arithmetic overflow");
2501 @.Arithmetic overflow@>
2502 help4("Uh, oh. A little while ago one of the quantities that I was",
2503 "computing got too large, so I'm afraid your answers will be",
2504 "somewhat askew. You'll probably have to adopt different",
2505 "tactics next time. But I shall try to carry on anyway.");
2507 mp->arith_error=false;
2510 @ Addition is not always checked to make sure that it doesn't overflow,
2511 but in places where overflow isn't too unlikely the |slow_add| routine
2514 @c static integer mp_slow_add (MP mp,integer x, integer y) {
2516 if ( y<=el_gordo-x ) {
2519 mp->arith_error=true;
2522 } else if ( -y<=el_gordo+x ) {
2525 mp->arith_error=true;
2530 @ Fixed-point arithmetic is done on {\sl scaled integers\/} that are multiples
2531 of $2^{-16}$. In other words, a binary point is assumed to be sixteen bit
2532 positions from the right end of a binary computer word.
2534 @d quarter_unit 040000 /* $2^{14}$, represents 0.250000 */
2535 @d half_unit 0100000 /* $2^{15}$, represents 0.50000 */
2536 @d three_quarter_unit 0140000 /* $3\cdot2^{14}$, represents 0.75000 */
2537 @d unity 0200000 /* $2^{16}$, represents 1.00000 */
2538 @d two 0400000 /* $2^{17}$, represents 2.00000 */
2539 @d three 0600000 /* $2^{17}+2^{16}$, represents 3.00000 */
2542 typedef integer scaled; /* this type is used for scaled integers */
2544 @ The following function is used to create a scaled integer from a given decimal
2545 fraction $(.d_0d_1\ldots d_{k-1})$, where |0<=k<=17|. The digit $d_i$ is
2546 given in |dig[i]|, and the calculation produces a correctly rounded result.
2549 static scaled mp_round_decimals (MP mp,quarterword k) {
2550 /* converts a decimal fraction */
2551 unsigned a = 0; /* the accumulator */
2553 a=(a+mp->dig[k]*two) / 10;
2555 return (scaled)halfp(a+1);
2558 @ Conversely, here is a procedure analogous to |print_int|. If the output
2559 of this procedure is subsequently read by \MP\ and converted by the
2560 |round_decimals| routine above, it turns out that the original value will
2561 be reproduced exactly. A decimal point is printed only if the value is
2562 not an integer. If there is more than one way to print the result with
2563 the optimum number of digits following the decimal point, the closest
2564 possible value is given.
2566 The invariant relation in the \&{repeat} loop is that a sequence of
2567 decimal digits yet to be printed will yield the original number if and only if
2568 they form a fraction~$f$ in the range $s-\delta\L10\cdot2^{16}f<s$.
2569 We can stop if and only if $f=0$ satisfies this condition; the loop will
2570 terminate before $s$ can possibly become zero.
2572 @<Basic printing...@>=
2573 void mp_print_scaled (MP mp,scaled s) { /* prints scaled real, rounded to five digits */
2574 scaled delta; /* amount of allowable inaccuracy */
2576 mp_print_char(mp, xord('-'));
2577 negate(s); /* print the sign, if negative */
2579 mp_print_int(mp, s / unity); /* print the integer part */
2583 mp_print_char(mp, xord('.'));
2586 s=s+0100000-(delta / 2); /* round the final digit */
2587 mp_print_char(mp, xord('0'+(s / unity)));
2594 @ We often want to print two scaled quantities in parentheses,
2595 separated by a comma.
2597 @<Basic printing...@>=
2598 void mp_print_two (MP mp,scaled x, scaled y) { /* prints `|(x,y)|' */
2599 mp_print_char(mp, xord('('));
2600 mp_print_scaled(mp, x);
2601 mp_print_char(mp, xord(','));
2602 mp_print_scaled(mp, y);
2603 mp_print_char(mp, xord(')'));
2606 @ The |scaled| quantities in \MP\ programs are generally supposed to be
2607 less than $2^{12}$ in absolute value, so \MP\ does much of its internal
2608 arithmetic with 28~significant bits of precision. A |fraction| denotes
2609 a scaled integer whose binary point is assumed to be 28 bit positions
2612 @d fraction_half 01000000000 /* $2^{27}$, represents 0.50000000 */
2613 @d fraction_one 02000000000 /* $2^{28}$, represents 1.00000000 */
2614 @d fraction_two 04000000000 /* $2^{29}$, represents 2.00000000 */
2615 @d fraction_three 06000000000 /* $3\cdot2^{28}$, represents 3.00000000 */
2616 @d fraction_four 010000000000 /* $2^{30}$, represents 4.00000000 */
2619 typedef integer fraction; /* this type is used for scaled fractions */
2621 @ In fact, the two sorts of scaling discussed above aren't quite
2622 sufficient; \MP\ has yet another, used internally to keep track of angles
2623 in units of $2^{-20}$ degrees.
2625 @d forty_five_deg 0264000000 /* $45\cdot2^{20}$, represents $45^\circ$ */
2626 @d ninety_deg 0550000000 /* $90\cdot2^{20}$, represents $90^\circ$ */
2627 @d one_eighty_deg 01320000000 /* $180\cdot2^{20}$, represents $180^\circ$ */
2628 @d three_sixty_deg 02640000000 /* $360\cdot2^{20}$, represents $360^\circ$ */
2631 typedef integer angle; /* this type is used for scaled angles */
2633 @ The |make_fraction| routine produces the |fraction| equivalent of
2634 |p/q|, given integers |p| and~|q|; it computes the integer
2635 $f=\lfloor2^{28}p/q+{1\over2}\rfloor$, when $p$ and $q$ are
2636 positive. If |p| and |q| are both of the same scaled type |t|,
2637 the ``type relation'' |make_fraction(t,t)=fraction| is valid;
2638 and it's also possible to use the subroutine ``backwards,'' using
2639 the relation |make_fraction(t,fraction)=t| between scaled types.
2641 If the result would have magnitude $2^{31}$ or more, |make_fraction|
2642 sets |arith_error:=true|. Most of \MP's internal computations have
2643 been designed to avoid this sort of error.
2645 If this subroutine were programmed in assembly language on a typical
2646 machine, we could simply compute |(@t$2^{28}$@>*p)div q|, since a
2647 double-precision product can often be input to a fixed-point division
2648 instruction. But when we are restricted to int-eger arithmetic it
2649 is necessary either to resort to multiple-precision maneuvering
2650 or to use a simple but slow iteration. The multiple-precision technique
2651 would be about three times faster than the code adopted here, but it
2652 would be comparatively long and tricky, involving about sixteen
2653 additional multiplications and divisions.
2655 This operation is part of \MP's ``inner loop''; indeed, it will
2656 consume nearly 10\pct! of the running time (exclusive of input and output)
2657 if the code below is left unchanged. A machine-dependent recoding
2658 will therefore make \MP\ run faster. The present implementation
2659 is highly portable, but slow; it avoids multiplication and division
2660 except in the initial stage. System wizards should be careful to
2661 replace it with a routine that is guaranteed to produce identical
2662 results in all cases.
2663 @^system dependencies@>
2665 As noted below, a few more routines should also be replaced by machine-dependent
2666 code, for efficiency. But when a procedure is not part of the ``inner loop,''
2667 such changes aren't advisable; simplicity and robustness are
2668 preferable to trickery, unless the cost is too high.
2671 @<Internal library declarations@>=
2672 integer mp_take_scaled (MP mp,integer q, scaled f) ;
2675 static fraction mp_make_fraction (MP mp,integer p, integer q);
2677 @ If FIXPT is not defined, we need these preprocessor values
2679 @d TWEXP31 2147483648.0
2680 @d TWEXP28 268435456.0
2682 @d TWEXP_16 (1.0/65536.0)
2683 @d TWEXP_28 (1.0/268435456.0)
2687 fraction mp_make_fraction (MP mp,integer p, integer q) {
2689 if ( q==0 ) mp_confusion(mp, "/");
2690 @:this can't happen /}{\quad \./@>
2693 integer f; /* the fraction bits, with a leading 1 bit */
2694 integer n; /* the integer part of $\vert p/q\vert$ */
2695 boolean negative = false; /* should the result be negated? */
2697 negate(p); negative=true;
2700 negate(q); negative = ! negative;
2704 mp->arith_error=true;
2705 i= ( negative ? -el_gordo : el_gordo);
2707 n=(n-1)*fraction_one;
2708 @<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>;
2709 i = (negative ? (-(f+n)) : (f+n));
2715 d = TWEXP28 * (double)p /(double)q;
2718 if (d>=TWEXP31) {mp->arith_error=true; return el_gordo;}
2720 if (d==(double)i && ( ((q>0 ? -q : q)&077777)
2721 * (((i&037777)<<1)-1) & 04000)!=0) --i;
2724 if (d<= -TWEXP31) {mp->arith_error=true; return -el_gordo;}
2726 if (d==(double)i && ( ((q>0 ? q : -q)&077777)
2727 * (((i&037777)<<1)+1) & 04000)!=0) ++i;
2734 @ The |repeat| loop here preserves the following invariant relations
2735 between |f|, |p|, and~|q|:
2736 (i)~|0<=p<q|; (ii)~$fq+p=2^k(q+p_0)$, where $k$ is an integer and
2737 $p_0$ is the original value of~$p$.
2739 Notice that the computation specifies
2740 |(p-q)+p| instead of |(p+p)-q|, because the latter could overflow.
2741 Let us hope that optimizing compilers do not miss this point; a
2742 special variable |be_careful| is used to emphasize the necessary
2743 order of computation. Optimizing compilers should keep |be_careful|
2744 in a register, not store it in memory.
2747 @<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>=
2749 integer be_careful; /* disables certain compiler optimizations */
2752 be_careful=p-q; p=be_careful+p;
2758 } while (f<fraction_one);
2760 if ( be_careful+p>=0 ) incr(f);
2763 @ The dual of |make_fraction| is |take_fraction|, which multiplies a
2764 given integer~|q| by a fraction~|f|. When the operands are positive, it
2765 computes $p=\lfloor qf/2^{28}+{1\over2}\rfloor$, a symmetric function
2768 This routine is even more ``inner loopy'' than |make_fraction|;
2769 the present implementation consumes almost 20\pct! of \MP's computation
2770 time during typical jobs, so a machine-language substitute is advisable.
2771 @^inner loop@> @^system dependencies@>
2773 @<Internal library declarations@>=
2774 integer mp_take_fraction (MP mp,integer q, fraction f) ;
2778 integer mp_take_fraction (MP mp,integer q, fraction f) {
2779 integer p; /* the fraction so far */
2780 boolean negative; /* should the result be negated? */
2781 integer n; /* additional multiple of $q$ */
2782 integer be_careful; /* disables certain compiler optimizations */
2783 @<Reduce to the case that |f>=0| and |q>=0|@>;
2784 if ( f<fraction_one ) {
2787 n=f / fraction_one; f=f % fraction_one;
2788 if ( q<=el_gordo / n ) {
2791 mp->arith_error=true; n=el_gordo;
2795 @<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>;
2796 be_careful=n-el_gordo;
2797 if ( be_careful+p>0 ){
2798 mp->arith_error=true; n=el_gordo-p;
2805 integer mp_take_fraction (MP mp,integer p, fraction q) {
2808 d = (double)p * (double)q * TWEXP_28;
2812 if (d!=TWEXP31 || (((p&077777)*(q&077777))&040000)==0)
2813 mp->arith_error = true;
2817 if (d==(double)i && (((p&077777)*(q&077777))&040000)!=0) --i;
2821 if (d!= -TWEXP31 || ((-(p&077777)*(q&077777))&040000)==0)
2822 mp->arith_error = true;
2826 if (d==(double)i && ((-(p&077777)*(q&077777))&040000)!=0) ++i;
2832 @ @<Reduce to the case that |f>=0| and |q>=0|@>=
2836 negate( f); negative=true;
2839 negate(q); negative=! negative;
2842 @ The invariant relations in this case are (i)~$\lfloor(qf+p)/2^k\rfloor
2843 =\lfloor qf_0/2^{28}+{1\over2}\rfloor$, where $k$ is an integer and
2844 $f_0$ is the original value of~$f$; (ii)~$2^k\L f<2^{k+1}$.
2847 @<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>=
2848 p=fraction_half; /* that's $2^{27}$; the invariants hold now with $k=28$ */
2849 if ( q<fraction_four ) {
2851 if ( odd(f) ) p=halfp(p+q); else p=halfp(p);
2856 if ( odd(f) ) p=p+halfp(q-p); else p=halfp(p);
2862 @ When we want to multiply something by a |scaled| quantity, we use a scheme
2863 analogous to |take_fraction| but with a different scaling.
2864 Given positive operands, |take_scaled|
2865 computes the quantity $p=\lfloor qf/2^{16}+{1\over2}\rfloor$.
2867 Once again it is a good idea to use a machine-language replacement if
2868 possible; otherwise |take_scaled| will use more than 2\pct! of the running time
2869 when the Computer Modern fonts are being generated.
2874 integer mp_take_scaled (MP mp,integer q, scaled f) {
2875 integer p; /* the fraction so far */
2876 boolean negative; /* should the result be negated? */
2877 integer n; /* additional multiple of $q$ */
2878 integer be_careful; /* disables certain compiler optimizations */
2879 @<Reduce to the case that |f>=0| and |q>=0|@>;
2883 n=f / unity; f=f % unity;
2884 if ( q<=el_gordo / n ) {
2887 mp->arith_error=true; n=el_gordo;
2891 @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>;
2892 be_careful=n-el_gordo;
2893 if ( be_careful+p>0 ) {
2894 mp->arith_error=true; n=el_gordo-p;
2896 return ( negative ?(-(n+p)) :(n+p));
2898 integer mp_take_scaled (MP mp,integer p, scaled q) {
2901 d = (double)p * (double)q * TWEXP_16;
2905 if (d!=TWEXP31 || (((p&077777)*(q&077777))&040000)==0)
2906 mp->arith_error = true;
2910 if (d==(double)i && (((p&077777)*(q&077777))&040000)!=0) --i;
2914 if (d!= -TWEXP31 || ((-(p&077777)*(q&077777))&040000)==0)
2915 mp->arith_error = true;
2919 if (d==(double)i && ((-(p&077777)*(q&077777))&040000)!=0) ++i;
2925 @ @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>=
2926 p=half_unit; /* that's $2^{15}$; the invariants hold now with $k=16$ */
2928 if ( q<fraction_four ) {
2930 p = (odd(f) ? halfp(p+q) : halfp(p));
2935 p = (odd(f) ? p+halfp(q-p) : halfp(p));
2940 @ For completeness, there's also |make_scaled|, which computes a
2941 quotient as a |scaled| number instead of as a |fraction|.
2942 In other words, the result is $\lfloor2^{16}p/q+{1\over2}\rfloor$, if the
2943 operands are positive. \ (This procedure is not used especially often,
2944 so it is not part of \MP's inner loop.)
2946 @<Internal library ...@>=
2947 scaled mp_make_scaled (MP mp,integer p, integer q) ;
2950 scaled mp_make_scaled (MP mp,integer p, integer q) {
2952 if ( q==0 ) mp_confusion(mp, "/");
2953 @:this can't happen /}{\quad \./@>
2956 integer f; /* the fraction bits, with a leading 1 bit */
2957 integer n; /* the integer part of $\vert p/q\vert$ */
2958 boolean negative; /* should the result be negated? */
2959 integer be_careful; /* disables certain compiler optimizations */
2960 if ( p>=0 ) negative=false;
2961 else { negate(p); negative=true; };
2963 negate(q); negative=! negative;
2967 mp->arith_error=true;
2968 return (negative ? (-el_gordo) : el_gordo);
2971 @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>;
2972 i = (negative ? (-(f+n)) :(f+n));
2976 d = TWEXP16 * (double)p /(double)q;
2979 if (d>=TWEXP31) {mp->arith_error=true; return el_gordo;}
2981 if (d==(double)i && ( ((q>0 ? -q : q)&077777)
2982 * (((i&037777)<<1)-1) & 04000)!=0) --i;
2985 if (d<= -TWEXP31) {mp->arith_error=true; return -el_gordo;}
2987 if (d==(double)i && ( ((q>0 ? q : -q)&077777)
2988 * (((i&037777)<<1)+1) & 04000)!=0) ++i;
2995 @ @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>=
2998 be_careful=p-q; p=be_careful+p;
2999 if ( p>=0 ) f=f+f+1;
3000 else { f+=f; p=p+q; };
3003 if ( be_careful+p>=0 ) incr(f)
3005 @ Here is a typical example of how the routines above can be used.
3006 It computes the function
3007 $${1\over3\tau}f(\theta,\phi)=
3008 {\tau^{-1}\bigl(2+\sqrt2\,(\sin\theta-{1\over16}\sin\phi)
3009 (\sin\phi-{1\over16}\sin\theta)(\cos\theta-\cos\phi)\bigr)\over
3010 3\,\bigl(1+{1\over2}(\sqrt5-1)\cos\theta+{1\over2}(3-\sqrt5\,)\cos\phi\bigr)},$$
3011 where $\tau$ is a |scaled| ``tension'' parameter. This is \MP's magic
3012 fudge factor for placing the first control point of a curve that starts
3013 at an angle $\theta$ and ends at an angle $\phi$ from the straight path.
3014 (Actually, if the stated quantity exceeds 4, \MP\ reduces it to~4.)
3016 The trigonometric quantity to be multiplied by $\sqrt2$ is less than $\sqrt2$.
3017 (It's a sum of eight terms whose absolute values can be bounded using
3018 relations such as $\sin\theta\cos\theta\L{1\over2}$.) Thus the numerator
3019 is positive; and since the tension $\tau$ is constrained to be at least
3020 $3\over4$, the numerator is less than $16\over3$. The denominator is
3021 nonnegative and at most~6. Hence the fixed-point calculations below
3022 are guaranteed to stay within the bounds of a 32-bit computer word.
3024 The angles $\theta$ and $\phi$ are given implicitly in terms of |fraction|
3025 arguments |st|, |ct|, |sf|, and |cf|, representing $\sin\theta$, $\cos\theta$,
3026 $\sin\phi$, and $\cos\phi$, respectively.
3029 static fraction mp_velocity (MP mp,fraction st, fraction ct, fraction sf,
3030 fraction cf, scaled t) {
3031 integer acc,num,denom; /* registers for intermediate calculations */
3032 acc=mp_take_fraction(mp, st-(sf / 16), sf-(st / 16));
3033 acc=mp_take_fraction(mp, acc,ct-cf);
3034 num=fraction_two+mp_take_fraction(mp, acc,379625062);
3035 /* $2^{28}\sqrt2\approx379625062.497$ */
3036 denom=fraction_three+mp_take_fraction(mp, ct,497706707)+mp_take_fraction(mp, cf,307599661);
3037 /* $3\cdot2^{27}\cdot(\sqrt5-1)\approx497706706.78$ and
3038 $3\cdot2^{27}\cdot(3-\sqrt5\,)\approx307599661.22$ */
3039 if ( t!=unity ) num=mp_make_scaled(mp, num,t);
3040 /* |make_scaled(fraction,scaled)=fraction| */
3041 if ( num / 4>=denom )
3042 return fraction_four;
3044 return mp_make_fraction(mp, num, denom);
3047 @ The following somewhat different subroutine tests rigorously if $ab$ is
3048 greater than, equal to, or less than~$cd$,
3049 given integers $(a,b,c,d)$. In most cases a quick decision is reached.
3050 The result is $+1$, 0, or~$-1$ in the three respective cases.
3052 @d mp_ab_vs_cd(M,A,B,C,D) mp_do_ab_vs_cd(A,B,C,D)
3055 static integer mp_do_ab_vs_cd (integer a,integer b, integer c, integer d) {
3056 integer q,r; /* temporary registers */
3057 @<Reduce to the case that |a,c>=0|, |b,d>0|@>;
3059 q = a / d; r = c / b;
3061 return ( q>r ? 1 : -1);
3062 q = a % d; r = c % b;
3065 if ( q==0 ) return -1;
3067 } /* now |a>d>0| and |c>b>0| */
3070 @ @<Reduce to the case that |a...@>=
3071 if ( a<0 ) { negate(a); negate(b); };
3072 if ( c<0 ) { negate(c); negate(d); };
3075 if ( (a==0||b==0)&&(c==0||d==0) ) return 0;
3079 return ( a==0 ? 0 : -1);
3080 q=a; a=c; c=q; q=-b; b=-d; d=q;
3081 } else if ( b<=0 ) {
3082 if ( b<0 ) if ( a>0 ) return -1;
3083 return (c==0 ? 0 : -1);
3086 @ We conclude this set of elementary routines with some simple rounding
3087 and truncation operations.
3089 @<Internal library declarations@>=
3090 #define mp_floor_scaled(M,i) ((i)&(-65536))
3091 #define mp_round_unscaled(M,i) (((i/32768)+1)/2)
3092 #define mp_round_fraction(M,i) (((i/2048)+1)/2)
3095 @* \[8] Algebraic and transcendental functions.
3096 \MP\ computes all of the necessary special functions from scratch, without
3097 relying on |real| arithmetic or system subroutines for sines, cosines, etc.
3099 @ To get the square root of a |scaled| number |x|, we want to calculate
3100 $s=\lfloor 2^8\!\sqrt x +{1\over2}\rfloor$. If $x>0$, this is the unique
3101 integer such that $2^{16}x-s\L s^2<2^{16}x+s$. The following subroutine
3102 determines $s$ by an iterative method that maintains the invariant
3103 relations $x=2^{46-2k}x_0\bmod 2^{30}$, $0<y=\lfloor 2^{16-2k}x_0\rfloor
3104 -s^2+s\L q=2s$, where $x_0$ is the initial value of $x$. The value of~$y$
3105 might, however, be zero at the start of the first iteration.
3108 static scaled mp_square_rt (MP mp,scaled x) ;
3111 scaled mp_square_rt (MP mp,scaled x) {
3112 quarterword k; /* iteration control counter */
3113 integer y; /* register for intermediate calculations */
3114 unsigned q; /* register for intermediate calculations */
3116 @<Handle square root of zero or negative argument@>;
3119 while ( x<fraction_two ) { /* i.e., |while x<@t$2^{29}$@>|\unskip */
3122 if ( x<fraction_four ) y=0;
3123 else { x=x-fraction_four; y=1; };
3125 @<Decrease |k| by 1, maintaining the invariant
3126 relations between |x|, |y|, and~|q|@>;
3128 return (scaled)(halfp(q));
3132 @ @<Handle square root of zero...@>=
3135 print_err("Square root of ");
3136 @.Square root...replaced by 0@>
3137 mp_print_scaled(mp, x); mp_print(mp, " has been replaced by 0");
3138 help2("Since I don't take square roots of negative numbers,",
3139 "I'm zeroing this one. Proceed, with fingers crossed.");
3145 @ @<Decrease |k| by 1, maintaining...@>=
3147 if ( x>=fraction_four ) { /* note that |fraction_four=@t$2^{30}$@>| */
3148 x=x-fraction_four; y++;
3150 x+=x; y=y+y-q; q+=q;
3151 if ( x>=fraction_four ) { x=x-fraction_four; y++; };
3152 if ( y>(int)q ){ y=y-q; q=q+2; }
3153 else if ( y<=0 ) { q=q-2; y=y+q; };
3156 @ Pythagorean addition $\psqrt{a^2+b^2}$ is implemented by an elegant
3157 iterative scheme due to Cleve Moler and Donald Morrison [{\sl IBM Journal
3158 @^Moler, Cleve Barry@>
3159 @^Morrison, Donald Ross@>
3160 of Research and Development\/ \bf27} (1983), 577--581]. It modifies |a| and~|b|
3161 in such a way that their Pythagorean sum remains invariant, while the
3162 smaller argument decreases.
3164 @<Internal library ...@>=
3165 integer mp_pyth_add (MP mp,integer a, integer b);
3169 integer mp_pyth_add (MP mp,integer a, integer b) {
3170 fraction r; /* register used to transform |a| and |b| */
3171 boolean big; /* is the result dangerously near $2^{31}$? */
3173 if ( a<b ) { r=b; b=a; a=r; }; /* now |0<=b<=a| */
3175 if ( a<fraction_two ) {
3178 a=a / 4; b=b / 4; big=true;
3179 }; /* we reduced the precision to avoid arithmetic overflow */
3180 @<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>;
3182 if ( a<fraction_two ) {
3185 mp->arith_error=true; a=el_gordo;
3192 @ The key idea here is to reflect the vector $(a,b)$ about the
3193 line through $(a,b/2)$.
3195 @<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>=
3197 r=mp_make_fraction(mp, b,a);
3198 r=mp_take_fraction(mp, r,r); /* now $r\approx b^2/a^2$ */
3200 r=mp_make_fraction(mp, r,fraction_four+r);
3201 a=a+mp_take_fraction(mp, a+a,r); b=mp_take_fraction(mp, b,r);
3205 @ Here is a similar algorithm for $\psqrt{a^2-b^2}$.
3206 It converges slowly when $b$ is near $a$, but otherwise it works fine.
3209 static integer mp_pyth_sub (MP mp,integer a, integer b) {
3210 fraction r; /* register used to transform |a| and |b| */
3211 boolean big; /* is the input dangerously near $2^{31}$? */
3214 @<Handle erroneous |pyth_sub| and set |a:=0|@>;
3216 if ( a<fraction_four ) {
3219 a=(integer)halfp(a); b=(integer)halfp(b); big=true;
3221 @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>;
3222 if ( big ) double(a);
3227 @ @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>=
3229 r=mp_make_fraction(mp, b,a);
3230 r=mp_take_fraction(mp, r,r); /* now $r\approx b^2/a^2$ */
3232 r=mp_make_fraction(mp, r,fraction_four-r);
3233 a=a-mp_take_fraction(mp, a+a,r); b=mp_take_fraction(mp, b,r);
3236 @ @<Handle erroneous |pyth_sub| and set |a:=0|@>=
3239 print_err("Pythagorean subtraction "); mp_print_scaled(mp, a);
3240 mp_print(mp, "+-+"); mp_print_scaled(mp, b);
3241 mp_print(mp, " has been replaced by 0");
3243 help2("Since I don't take square roots of negative numbers,",
3244 "I'm zeroing this one. Proceed, with fingers crossed.");
3250 @ The subroutines for logarithm and exponential involve two tables.
3251 The first is simple: |two_to_the[k]| equals $2^k$. The second involves
3252 a bit more calculation, which the author claims to have done correctly:
3253 |spec_log[k]| is $2^{27}$ times $\ln\bigl(1/(1-2^{-k})\bigr)=
3254 2^{-k}+{1\over2}2^{-2k}+{1\over3}2^{-3k}+\cdots\,$, rounded to the
3257 @d two_to_the(A) (1<<(unsigned)(A))
3260 static const integer spec_log[29] = { 0, /* special logarithms */
3261 93032640, 38612034, 17922280, 8662214, 4261238, 2113709,
3262 1052693, 525315, 262400, 131136, 65552, 32772, 16385,
3263 8192, 4096, 2048, 1024, 512, 256, 128, 64, 32, 16, 8, 4, 2, 1, 1 };
3265 @ @<Local variables for initialization@>=
3266 integer k; /* all-purpose loop index */
3269 @ Here is the routine that calculates $2^8$ times the natural logarithm
3270 of a |scaled| quantity; it is an integer approximation to $2^{24}\ln(x/2^{16})$,
3271 when |x| is a given positive integer.
3273 The method is based on exercise 1.2.2--25 in {\sl The Art of Computer
3274 Programming\/}: During the main iteration we have $1\L 2^{-30}x<1/(1-2^{1-k})$,
3275 and the logarithm of $2^{30}x$ remains to be added to an accumulator
3276 register called~$y$. Three auxiliary bits of accuracy are retained in~$y$
3277 during the calculation, and sixteen auxiliary bits to extend |y| are
3278 kept in~|z| during the initial argument reduction. (We add
3279 $100\cdot2^{16}=6553600$ to~|z| and subtract 100 from~|y| so that |z| will
3280 not become negative; also, the actual amount subtracted from~|y| is~96,
3281 not~100, because we want to add~4 for rounding before the final division by~8.)
3284 static scaled mp_m_log (MP mp,scaled x) {
3285 integer y,z; /* auxiliary registers */
3286 integer k; /* iteration counter */
3288 @<Handle non-positive logarithm@>;
3290 y=1302456956+4-100; /* $14\times2^{27}\ln2\approx1302456956.421063$ */
3291 z=27595+6553600; /* and $2^{16}\times .421063\approx 27595$ */
3292 while ( x<fraction_four ) {
3293 double(x); y-=93032639; z-=48782;
3294 } /* $2^{27}\ln2\approx 93032639.74436163$ and $2^{16}\times.74436163\approx 48782$ */
3295 y=y+(z / unity); k=2;
3296 while ( x>fraction_four+4 ) {
3297 @<Increase |k| until |x| can be multiplied by a
3298 factor of $2^{-k}$, and adjust $y$ accordingly@>;
3304 @ @<Increase |k| until |x| can...@>=
3306 z=((x-1) / two_to_the(k))+1; /* $z=\lceil x/2^k\rceil$ */
3307 while ( x<fraction_four+z ) { z=halfp(z+1); k++; };
3308 y+=spec_log[k]; x-=z;
3311 @ @<Handle non-positive logarithm@>=
3313 print_err("Logarithm of ");
3314 @.Logarithm...replaced by 0@>
3315 mp_print_scaled(mp, x); mp_print(mp, " has been replaced by 0");
3316 help2("Since I don't take logs of non-positive numbers,",
3317 "I'm zeroing this one. Proceed, with fingers crossed.");
3322 @ Conversely, the exponential routine calculates $\exp(x/2^8)$,
3323 when |x| is |scaled|. The result is an integer approximation to
3324 $2^{16}\exp(x/2^{24})$, when |x| is regarded as an integer.
3327 static scaled mp_m_exp (MP mp,scaled x) {
3328 quarterword k; /* loop control index */
3329 integer y,z; /* auxiliary registers */
3330 if ( x>174436200 ) {
3331 /* $2^{24}\ln((2^{31}-1)/2^{16})\approx 174436199.51$ */
3332 mp->arith_error=true;
3334 } else if ( x<-197694359 ) {
3335 /* $2^{24}\ln(2^{-1}/2^{16})\approx-197694359.45$ */
3339 z=-8*x; y=04000000; /* $y=2^{20}$ */
3341 if ( x<=127919879 ) {
3343 /* $2^{27}\ln((2^{31}-1)/2^{20})\approx 1023359037.125$ */
3345 z=8*(174436200-x); /* |z| is always nonnegative */
3349 @<Multiply |y| by $\exp(-z/2^{27})$@>;
3351 return ((y+8) / 16);
3357 @ The idea here is that subtracting |spec_log[k]| from |z| corresponds
3358 to multiplying |y| by $1-2^{-k}$.
3360 A subtle point (which had to be checked) was that if $x=127919879$, the
3361 value of~|y| will decrease so that |y+8| doesn't overflow. In fact,
3362 $z$ will be 5 in this case, and |y| will decrease by~64 when |k=25|
3363 and by~16 when |k=27|.
3365 @<Multiply |y| by...@>=
3368 while ( z>=spec_log[k] ) {
3370 y=y-1-((y-two_to_the(k-1)) / two_to_the(k));
3375 @ The trigonometric subroutines use an auxiliary table such that
3376 |spec_atan[k]| contains an approximation to the |angle| whose tangent
3377 is~$1/2^k$. $\arctan2^{-k}$ times $2^{20}\cdot180/\pi$
3380 static const angle spec_atan[27] = { 0, 27855475, 14718068, 7471121, 3750058,
3381 1876857, 938658, 469357, 234682, 117342, 58671, 29335, 14668, 7334, 3667,
3382 1833, 917, 458, 229, 115, 57, 29, 14, 7, 4, 2, 1 };
3384 @ Given integers |x| and |y|, not both zero, the |n_arg| function
3385 returns the |angle| whose tangent points in the direction $(x,y)$.
3386 This subroutine first determines the correct octant, then solves the
3387 problem for |0<=y<=x|, then converts the result appropriately to
3388 return an answer in the range |-one_eighty_deg<=@t$\theta$@><=one_eighty_deg|.
3389 (The answer is |+one_eighty_deg| if |y=0| and |x<0|, but an answer of
3390 |-one_eighty_deg| is possible if, for example, |y=-1| and $x=-2^{30}$.)
3392 The octants are represented in a ``Gray code,'' since that turns out
3393 to be computationally simplest.
3399 @d second_octant (first_octant+switch_x_and_y)
3400 @d third_octant (first_octant+switch_x_and_y+negate_x)
3401 @d fourth_octant (first_octant+negate_x)
3402 @d fifth_octant (first_octant+negate_x+negate_y)
3403 @d sixth_octant (first_octant+switch_x_and_y+negate_x+negate_y)
3404 @d seventh_octant (first_octant+switch_x_and_y+negate_y)
3405 @d eighth_octant (first_octant+negate_y)
3408 static angle mp_n_arg (MP mp,integer x, integer y) {
3409 angle z; /* auxiliary register */
3410 integer t; /* temporary storage */
3411 quarterword k; /* loop counter */
3412 int octant; /* octant code */
3414 octant=first_octant;
3416 negate(x); octant=first_octant+negate_x;
3419 negate(y); octant=octant+negate_y;
3422 t=y; y=x; x=t; octant=octant+switch_x_and_y;
3425 @<Handle undefined arg@>;
3427 @<Set variable |z| to the arg of $(x,y)$@>;
3428 @<Return an appropriate answer based on |z| and |octant|@>;
3432 @ @<Handle undefined arg@>=
3434 print_err("angle(0,0) is taken as zero");
3435 @.angle(0,0)...zero@>
3436 help2("The `angle' between two identical points is undefined.",
3437 "I'm zeroing this one. Proceed, with fingers crossed.");
3442 @ @<Return an appropriate answer...@>=
3444 case first_octant: return z;
3445 case second_octant: return (ninety_deg-z);
3446 case third_octant: return (ninety_deg+z);
3447 case fourth_octant: return (one_eighty_deg-z);
3448 case fifth_octant: return (z-one_eighty_deg);
3449 case sixth_octant: return (-z-ninety_deg);
3450 case seventh_octant: return (z-ninety_deg);
3451 case eighth_octant: return (-z);
3452 }; /* there are no other cases */
3455 @ At this point we have |x>=y>=0|, and |x>0|. The numbers are scaled up
3456 or down until $2^{28}\L x<2^{29}$, so that accurate fixed-point calculations
3459 @<Set variable |z| to the arg...@>=
3460 while ( x>=fraction_two ) {
3461 x=halfp(x); y=halfp(y);
3465 while ( x<fraction_one ) {
3468 @<Increase |z| to the arg of $(x,y)$@>;
3471 @ During the calculations of this section, variables |x| and~|y|
3472 represent actual coordinates $(x,2^{-k}y)$. We will maintain the
3473 condition |x>=y|, so that the tangent will be at most $2^{-k}$.
3474 If $x<2y$, the tangent is greater than $2^{-k-1}$. The transformation
3475 $(a,b)\mapsto(a+b\tan\phi,b-a\tan\phi)$ replaces $(a,b)$ by
3476 coordinates whose angle has decreased by~$\phi$; in the special case
3477 $a=x$, $b=2^{-k}y$, and $\tan\phi=2^{-k-1}$, this operation reduces
3478 to the particularly simple iteration shown here. [Cf.~John E. Meggitt,
3479 @^Meggitt, John E.@>
3480 {\sl IBM Journal of Research and Development\/ \bf6} (1962), 210--226.]
3482 The initial value of |x| will be multiplied by at most
3483 $(1+{1\over2})(1+{1\over8})(1+{1\over32})\cdots\approx 1.7584$; hence
3484 there is no chance of integer overflow.
3486 @<Increase |z|...@>=
3491 z=z+spec_atan[k]; t=x; x=x+(y / two_to_the(k+k)); y=y-t;
3496 if ( y>x ) { z=z+spec_atan[k]; y=y-x; };
3499 @ Conversely, the |n_sin_cos| routine takes an |angle| and produces the sine
3500 and cosine of that angle. The results of this routine are
3501 stored in global integer variables |n_sin| and |n_cos|.
3504 fraction n_sin;fraction n_cos; /* results computed by |n_sin_cos| */
3506 @ Given an integer |z| that is $2^{20}$ times an angle $\theta$ in degrees,
3507 the purpose of |n_sin_cos(z)| is to set
3508 |x=@t$r\cos\theta$@>| and |y=@t$r\sin\theta$@>| (approximately),
3509 for some rather large number~|r|. The maximum of |x| and |y|
3510 will be between $2^{28}$ and $2^{30}$, so that there will be hardly
3511 any loss of accuracy. Then |x| and~|y| are divided by~|r|.
3514 static void mp_n_sin_cos (MP mp,angle z) { /* computes a multiple of the sine
3516 quarterword k; /* loop control variable */
3517 int q; /* specifies the quadrant */
3518 fraction r; /* magnitude of |(x,y)| */
3519 integer x,y,t; /* temporary registers */
3520 while ( z<0 ) z=z+three_sixty_deg;
3521 z=z % three_sixty_deg; /* now |0<=z<three_sixty_deg| */
3522 q=z / forty_five_deg; z=z % forty_five_deg;
3523 x=fraction_one; y=x;
3524 if ( ! odd(q) ) z=forty_five_deg-z;
3525 @<Subtract angle |z| from |(x,y)|@>;
3526 @<Convert |(x,y)| to the octant determined by~|q|@>;
3527 r=mp_pyth_add(mp, x,y);
3528 mp->n_cos=mp_make_fraction(mp, x,r);
3529 mp->n_sin=mp_make_fraction(mp, y,r);
3532 @ In this case the octants are numbered sequentially.
3534 @<Convert |(x,...@>=
3537 case 1: t=x; x=y; y=t; break;
3538 case 2: t=x; x=-y; y=t; break;
3539 case 3: negate(x); break;
3540 case 4: negate(x); negate(y); break;
3541 case 5: t=x; x=-y; y=-t; break;
3542 case 6: t=x; x=y; y=-t; break;
3543 case 7: negate(y); break;
3544 } /* there are no other cases */
3546 @ The main iteration of |n_sin_cos| is similar to that of |n_arg| but
3547 applied in reverse. The values of |spec_atan[k]| decrease slowly enough
3548 that this loop is guaranteed to terminate before the (nonexistent) value
3549 |spec_atan[27]| would be required.
3551 @<Subtract angle |z|...@>=
3554 if ( z>=spec_atan[k] ) {
3555 z=z-spec_atan[k]; t=x;
3556 x=t+y / two_to_the(k);
3557 y=y-t / two_to_the(k);
3561 if ( y<0 ) y=0 /* this precaution may never be needed */
3563 @ And now let's complete our collection of numeric utility routines
3564 by considering random number generation.
3565 \MP\ generates pseudo-random numbers with the additive scheme recommended
3566 in Section 3.6 of {\sl The Art of Computer Programming}; however, the
3567 results are random fractions between 0 and |fraction_one-1|, inclusive.
3569 There's an auxiliary array |randoms| that contains 55 pseudo-random
3570 fractions. Using the recurrence $x_n=(x_{n-55}-x_{n-31})\bmod 2^{28}$,
3571 we generate batches of 55 new $x_n$'s at a time by calling |new_randoms|.
3572 The global variable |j_random| tells which element has most recently
3574 The global variable |random_seed| was introduced in version 0.9,
3575 for the sole reason of stressing the fact that the initial value of the
3576 random seed is system-dependant. The initialization code below will initialize
3577 this variable to |(internal[mp_time] div unity)+internal[mp_day]|, but this
3578 is not good enough on modern fast machines that are capable of running
3579 multiple MetaPost processes within the same second.
3580 @^system dependencies@>
3583 fraction randoms[55]; /* the last 55 random values generated */
3584 int j_random; /* the number of unused |randoms| */
3586 @ @<Option variables@>=
3587 int random_seed; /* the default random seed */
3589 @ @<Allocate or initialize ...@>=
3590 mp->random_seed = (scaled)opt->random_seed;
3592 @ To consume a random fraction, the program below will say `|next_random|'
3593 and then it will fetch |randoms[j_random]|.
3595 @d next_random { if ( mp->j_random==0 ) mp_new_randoms(mp);
3596 else decr(mp->j_random); }
3599 static void mp_new_randoms (MP mp) {
3600 int k; /* index into |randoms| */
3601 fraction x; /* accumulator */
3602 for (k=0;k<=23;k++) {
3603 x=mp->randoms[k]-mp->randoms[k+31];
3604 if ( x<0 ) x=x+fraction_one;
3607 for (k=24;k<= 54;k++){
3608 x=mp->randoms[k]-mp->randoms[k-24];
3609 if ( x<0 ) x=x+fraction_one;
3616 static void mp_init_randoms (MP mp,scaled seed);
3618 @ To initialize the |randoms| table, we call the following routine.
3621 void mp_init_randoms (MP mp,scaled seed) {
3622 fraction j,jj,k; /* more or less random integers */
3623 int i; /* index into |randoms| */
3625 while ( j>=fraction_one ) j=halfp(j);
3627 for (i=0;i<=54;i++ ){
3629 if ( k<0 ) k=k+fraction_one;
3630 mp->randoms[(i*21)% 55]=j;
3634 mp_new_randoms(mp); /* ``warm up'' the array */
3637 @ To produce a uniform random number in the range |0<=u<x| or |0>=u>x|
3638 or |0=u=x|, given a |scaled| value~|x|, we proceed as shown here.
3640 Note that the call of |take_fraction| will produce the values 0 and~|x|
3641 with about half the probability that it will produce any other particular
3642 values between 0 and~|x|, because it rounds its answers.
3645 static scaled mp_unif_rand (MP mp,scaled x) {
3646 scaled y; /* trial value */
3647 next_random; y=mp_take_fraction(mp, abs(x),mp->randoms[mp->j_random]);
3648 if ( y==abs(x) ) return 0;
3649 else if ( x>0 ) return y;
3653 @ Finally, a normal deviate with mean zero and unit standard deviation
3654 can readily be obtained with the ratio method (Algorithm 3.4.1R in
3655 {\sl The Art of Computer Programming\/}).
3658 static scaled mp_norm_rand (MP mp) {
3659 integer x,u,l; /* what the book would call $2^{16}X$, $2^{28}U$, and $-2^{24}\ln U$ */
3663 x=mp_take_fraction(mp, 112429,mp->randoms[mp->j_random]-fraction_half);
3664 /* $2^{16}\sqrt{8/e}\approx 112428.82793$ */
3665 next_random; u=mp->randoms[mp->j_random];
3666 } while (abs(x)>=u);
3667 x=mp_make_fraction(mp, x,u);
3668 l=139548960-mp_m_log(mp, u); /* $2^{24}\cdot12\ln2\approx139548959.6165$ */
3669 } while (mp_ab_vs_cd(mp, 1024,l,x,x)<0);
3673 @* \[9] Packed data.
3674 In order to make efficient use of storage space, \MP\ bases its major data
3675 structures on a |memory_word|, which contains either a (signed) integer,
3676 possibly scaled, or a small number of fields that are one half or one
3677 quarter of the size used for storing integers.
3679 If |x| is a variable of type |memory_word|, it contains up to four
3680 fields that can be referred to as follows:
3681 $$\vbox{\halign{\hfil#&#\hfil&#\hfil\cr
3682 |x|&.|int|&(an |integer|)\cr
3683 |x|&.|sc|\qquad&(a |scaled| integer)\cr
3684 |x.hh.lh|, |x.hh|&.|rh|&(two halfword fields)\cr
3685 |x.hh.b0|, |x.hh.b1|, |x.hh|&.|rh|&(two quarterword fields, one halfword
3687 |x.qqqq.b0|, |x.qqqq.b1|, |x.qqqq|&.|b2|, |x.qqqq.b3|\hskip-100pt
3688 &\qquad\qquad\qquad(four quarterword fields)\cr}}$$
3689 This is somewhat cumbersome to write, and not very readable either, but
3690 macros will be used to make the notation shorter and more transparent.
3691 The code below gives a formal definition of |memory_word| and
3692 its subsidiary types, using packed variant records. \MP\ makes no
3693 assumptions about the relative positions of the fields within a word.
3695 @d max_quarterword 0x3FFF /* largest allowable value in a |quarterword| */
3696 @d max_halfword 0xFFFFFFF /* largest allowable value in a |halfword| */
3698 @ Here are the inequalities that the quarterword and halfword values
3699 must satisfy (or rather, the inequalities that they mustn't satisfy):
3701 @<Check the ``constant''...@>=
3702 if (mp->ini_version) {
3703 if ( mp->mem_max!=mp->mem_top ) mp->bad=8;
3705 if ( mp->mem_max<mp->mem_top ) mp->bad=8;
3707 if ( mp->mem_max>=max_halfword ) mp->bad=12;
3708 if ( mp->max_strings>max_halfword ) mp->bad=13;
3710 @ The macros |qi| and |qo| are used for input to and output
3711 from quarterwords. These are legacy macros.
3712 @^system dependencies@>
3714 @d qo(A) (A) /* to read eight bits from a quarterword */
3715 @d qi(A) (quarterword)(A) /* to store eight bits in a quarterword */
3717 @ The reader should study the following definitions closely:
3718 @^system dependencies@>
3720 @d sc cint /* |scaled| data is equivalent to |integer| */
3723 typedef short quarterword; /* 1/4 of a word */
3724 typedef int halfword; /* 1/2 of a word */
3729 struct { /* Make B0,B1 overlap the most significant bytes of LH. */
3736 quarterword B2, B3, B0, B1;
3751 @ When debugging, we may want to print a |memory_word| without knowing
3752 what type it is; so we print it in all modes.
3756 void mp_print_word (MP mp,memory_word w) {
3757 /* prints |w| in all ways */
3758 mp_print_int(mp, w.cint); mp_print_char(mp, xord(' '));
3759 mp_print_scaled(mp, w.sc); mp_print_char(mp, xord(' '));
3760 mp_print_scaled(mp, w.sc / 010000); mp_print_ln(mp);
3761 mp_print_int(mp, w.hh.lh); mp_print_char(mp, xord('='));
3762 mp_print_int(mp, w.hh.b0); mp_print_char(mp, xord(':'));
3763 mp_print_int(mp, w.hh.b1); mp_print_char(mp, xord(';'));
3764 mp_print_int(mp, w.hh.rh); mp_print_char(mp, xord(' '));
3765 mp_print_int(mp, w.qqqq.b0); mp_print_char(mp, xord(':'));
3766 mp_print_int(mp, w.qqqq.b1); mp_print_char(mp, xord(':'));
3767 mp_print_int(mp, w.qqqq.b2); mp_print_char(mp, xord(':'));
3768 mp_print_int(mp, w.qqqq.b3);
3772 @* \[10] Dynamic memory allocation.
3774 The \MP\ system does nearly all of its own memory allocation, so that it
3775 can readily be transported into environments that do not have automatic
3776 facilities for strings, garbage collection, etc., and so that it can be in
3777 control of what error messages the user receives. The dynamic storage
3778 requirements of \MP\ are handled by providing a large array |mem| in
3779 which consecutive blocks of words are used as nodes by the \MP\ routines.
3781 Pointer variables are indices into this array, or into another array
3782 called |eqtb| that will be explained later. A pointer variable might
3783 also be a special flag that lies outside the bounds of |mem|, so we
3784 allow pointers to assume any |halfword| value. The minimum memory
3785 index represents a null pointer.
3787 @d null 0 /* the null pointer */
3788 @d mp_void (null+1) /* a null pointer different from |null| */
3792 typedef halfword pointer; /* a flag or a location in |mem| or |eqtb| */
3794 @ The |mem| array is divided into two regions that are allocated separately,
3795 but the dividing line between these two regions is not fixed; they grow
3796 together until finding their ``natural'' size in a particular job.
3797 Locations less than or equal to |lo_mem_max| are used for storing
3798 variable-length records consisting of two or more words each. This region
3799 is maintained using an algorithm similar to the one described in exercise
3800 2.5--19 of {\sl The Art of Computer Programming}. However, no size field
3801 appears in the allocated nodes; the program is responsible for knowing the
3802 relevant size when a node is freed. Locations greater than or equal to
3803 |hi_mem_min| are used for storing one-word records; a conventional
3804 \.{AVAIL} stack is used for allocation in this region.
3806 Locations of |mem| between |0| and |mem_top| may be dumped as part
3807 of preloaded mem files, by the \.{INIMP} preprocessor.
3809 Production versions of \MP\ may extend the memory at the top end in order to
3810 provide more space; these locations, between |mem_top| and |mem_max|,
3811 are always used for single-word nodes.
3813 The key pointers that govern |mem| allocation have a prescribed order:
3814 $$\hbox{|null=0<lo_mem_max<hi_mem_min<mem_top<=mem_end<=mem_max|.}$$
3817 memory_word *mem; /* the big dynamic storage area */
3818 pointer lo_mem_max; /* the largest location of variable-size memory in use */
3819 pointer hi_mem_min; /* the smallest location of one-word memory in use */
3823 @d xfree(A) do { mp_xfree(A); A=NULL; } while (0)
3824 @d xrealloc(P,A,B) mp_xrealloc(mp,P,(size_t)A,B)
3825 @d xmalloc(A,B) mp_xmalloc(mp,(size_t)A,B)
3826 @d xstrdup(A) mp_xstrdup(mp,A)
3827 @d XREALLOC(a,b,c) a = xrealloc(a,(b+1),sizeof(c));
3829 @<Declare helpers@>=
3830 extern char *mp_strdup(const char *p) ;
3831 extern void mp_xfree ( @= /*@@only@@*/ /*@@out@@*/ /*@@null@@*/ @> void *x);
3832 extern @= /*@@only@@*/ @> void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size) ;
3833 extern @= /*@@only@@*/ @> void *mp_xmalloc (MP mp, size_t nmem, size_t size) ;
3834 extern @= /*@@only@@*/ @> char *mp_xstrdup(MP mp, const char *s);
3835 extern void mp_do_snprintf(char *str, int size, const char *fmt, ...);
3837 @ The |max_size_test| guards against overflow, on the assumption that
3838 |size_t| is at least 31bits wide.
3840 @d max_size_test 0x7FFFFFFF
3843 char *mp_strdup(const char *p) {
3846 if (p==NULL) return NULL;
3848 r = malloc (l*sizeof(char)+1);
3851 return memcpy (r,p,(l+1));
3853 void mp_xfree (void *x) {
3854 if (x!=NULL) free(x);
3856 void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size) {
3858 if ((max_size_test/size)<nmem) {
3859 do_fprintf(mp->err_out,"Memory size overflow!\n");
3860 mp->history =mp_fatal_error_stop; mp_jump_out(mp);
3862 w = realloc (p,(nmem*size));
3864 do_fprintf(mp->err_out,"Out of memory!\n");
3865 mp->history =mp_system_error_stop; mp_jump_out(mp);
3869 void *mp_xmalloc (MP mp, size_t nmem, size_t size) {
3871 if ((max_size_test/size)<nmem) {
3872 do_fprintf(mp->err_out,"Memory size overflow!\n");
3873 mp->history =mp_fatal_error_stop; mp_jump_out(mp);
3875 w = malloc (nmem*size);
3877 do_fprintf(mp->err_out,"Out of memory!\n");
3878 mp->history =mp_system_error_stop; mp_jump_out(mp);
3882 char *mp_xstrdup(MP mp, const char *s) {
3888 do_fprintf(mp->err_out,"Out of memory!\n");
3889 mp->history =mp_system_error_stop; mp_jump_out(mp);
3894 @ @<Internal library declarations@>=
3895 #ifdef HAVE_SNPRINTF
3896 #define mp_snprintf (void)snprintf
3898 #define mp_snprintf mp_do_snprintf
3901 @ This internal version is rather stupid, but good enough for its purpose.
3904 static char *mp_itoa (int i) {
3907 unsigned v = (unsigned)abs(i);
3908 memset(res,0,32*sizeof(char));
3910 char d = (char)(v % 10);
3914 res[idx--] = (char)v;
3918 return mp_strdup(res+idx);
3920 static char *mp_utoa (unsigned v) {
3923 memset(res,0,32*sizeof(char));
3925 char d = (char)(v % 10);
3929 res[idx--] = (char)v;
3930 return mp_strdup(res+idx);
3932 void mp_do_snprintf (char *str, int size, const char *format, ...) {
3936 va_start(ap, format);
3938 for (fmt=format;*fmt!='\0';fmt++) {
3944 char *s = va_arg(ap, char *);
3947 if (size-->0) res++;
3954 char *s = mp_itoa(va_arg(ap, int));
3958 if (size-->0) res++;
3965 char *s = mp_utoa(va_arg(ap, unsigned));
3969 if (size-->0) res++;
3976 if (size-->0) res++;
3980 if (size-->0) res++;
3982 if (size-->0) res++;
3987 if (size-->0) res++;
3995 @<Allocate or initialize ...@>=
3996 mp->mem = xmalloc ((mp->mem_max+1),sizeof (memory_word));
3997 memset(mp->mem,0,(mp->mem_max+1)*sizeof (memory_word));
3999 @ @<Dealloc variables@>=
4002 @ Users who wish to study the memory requirements of particular applications can
4003 can use optional special features that keep track of current and
4004 maximum memory usage. When code between the delimiters |stat| $\ldots$
4005 |tats| is not ``commented out,'' \MP\ will run a bit slower but it will
4006 report these statistics when |mp_tracing_stats| is positive.
4009 integer var_used; integer dyn_used; /* how much memory is in use */
4011 @ Let's consider the one-word memory region first, since it's the
4012 simplest. The pointer variable |mem_end| holds the highest-numbered location
4013 of |mem| that has ever been used. The free locations of |mem| that
4014 occur between |hi_mem_min| and |mem_end|, inclusive, are of type
4015 |two_halves|, and we write |info(p)| and |mp_link(p)| for the |lh|
4016 and |rh| fields of |mem[p]| when it is of this type. The single-word
4017 free locations form a linked list
4018 $$|avail|,\;\hbox{|mp_link(avail)|},\;\hbox{|mp_link(mp_link(avail))|},\;\ldots$$
4019 terminated by |null|.
4021 @d mp_link(A) mp->mem[(A)].hh.rh /* the |link| field of a memory word */
4022 @d info(A) mp->mem[(A)].hh.lh /* the |info| field of a memory word */
4025 pointer avail; /* head of the list of available one-word nodes */
4026 pointer mem_end; /* the last one-word node used in |mem| */
4028 @ If one-word memory is exhausted, it might mean that the user has forgotten
4029 a token like `\&{enddef}' or `\&{endfor}'. We will define some procedures
4030 later that try to help pinpoint the trouble.
4032 @ The function |get_avail| returns a pointer to a new one-word node whose
4033 |link| field is null. However, \MP\ will halt if there is no more room left.
4037 static pointer mp_get_avail (MP mp) { /* single-word node allocation */
4038 pointer p; /* the new node being got */
4039 p=mp->avail; /* get top location in the |avail| stack */
4041 mp->avail=mp_link(mp->avail); /* and pop it off */
4042 } else if ( mp->mem_end<mp->mem_max ) { /* or go into virgin territory */
4043 incr(mp->mem_end); p=mp->mem_end;
4045 decr(mp->hi_mem_min); p=mp->hi_mem_min;
4046 if ( mp->hi_mem_min<=mp->lo_mem_max ) {
4047 mp_runaway(mp); /* if memory is exhausted, display possible runaway text */
4048 mp_overflow(mp, "main memory size",mp->mem_max);
4049 /* quit; all one-word nodes are busy */
4050 @:MetaPost capacity exceeded main memory size}{\quad main memory size@>
4053 mp_link(p)=null; /* provide an oft-desired initialization of the new node */
4054 incr(mp->dyn_used);/* maintain statistics */
4058 @ Conversely, a one-word node is recycled by calling |free_avail|.
4060 @d free_avail(A) /* single-word node liberation */
4061 { mp_link((A))=mp->avail; mp->avail=(A); decr(mp->dyn_used); }
4063 @ There's also a |fast_get_avail| routine, which saves the procedure-call
4064 overhead at the expense of extra programming. This macro is used in
4065 the places that would otherwise account for the most calls of |get_avail|.
4068 @d fast_get_avail(A) {
4069 (A)=mp->avail; /* avoid |get_avail| if possible, to save time */
4070 if ( (A)==null ) { (A)=mp_get_avail(mp); }
4071 else { mp->avail=mp_link((A)); mp_link((A))=null; incr(mp->dyn_used); }
4074 @ The available-space list that keeps track of the variable-size portion
4075 of |mem| is a nonempty, doubly-linked circular list of empty nodes,
4076 pointed to by the roving pointer |rover|.
4078 Each empty node has size 2 or more; the first word contains the special
4079 value |max_halfword| in its |link| field and the size in its |info| field;
4080 the second word contains the two pointers for double linking.
4082 Each nonempty node also has size 2 or more. Its first word is of type
4083 |two_halves|\kern-1pt, and its |link| field is never equal to |max_halfword|.
4084 Otherwise there is complete flexibility with respect to the contents
4085 of its other fields and its other words.
4087 (We require |mem_max<max_halfword| because terrible things can happen
4088 when |max_halfword| appears in the |link| field of a nonempty node.)
4090 @d empty_flag max_halfword /* the |link| of an empty variable-size node */
4091 @d is_empty(A) (mp_link((A))==empty_flag) /* tests for empty node */
4092 @d node_size info /* the size field in empty variable-size nodes */
4093 @d lmp_link(A) info((A)+1) /* left link in doubly-linked list of empty nodes */
4094 @d rmp_link(A) mp_link((A)+1) /* right link in doubly-linked list of empty nodes */
4097 pointer rover; /* points to some node in the list of empties */
4099 @ A call to |get_node| with argument |s| returns a pointer to a new node
4100 of size~|s|, which must be 2~or more. The |link| field of the first word
4101 of this new node is set to null. An overflow stop occurs if no suitable
4104 If |get_node| is called with $s=2^{30}$, it simply merges adjacent free
4105 areas and returns the value |max_halfword|.
4107 @<Internal library declarations@>=
4108 pointer mp_get_node (MP mp,integer s) ;
4111 pointer mp_get_node (MP mp,integer s) { /* variable-size node allocation */
4112 pointer p; /* the node currently under inspection */
4113 pointer q; /* the node physically after node |p| */
4114 integer r; /* the newly allocated node, or a candidate for this honor */
4115 integer t,tt; /* temporary registers */
4118 p=mp->rover; /* start at some free node in the ring */
4120 @<Try to allocate within node |p| and its physical successors,
4121 and |goto found| if allocation was possible@>;
4122 if (rmp_link(p)==null || (rmp_link(p)==p && p!=mp->rover)) {
4123 print_err("Free list garbled");
4124 help3("I found an entry in the list of free nodes that links",
4125 "badly. I will try to ignore the broken link, but something",
4126 "is seriously amiss. It is wise to warn the maintainers.")
4128 rmp_link(p)=mp->rover;
4130 p=rmp_link(p); /* move to the next node in the ring */
4131 } while (p!=mp->rover); /* repeat until the whole list has been traversed */
4132 if ( s==010000000000 ) {
4133 return max_halfword;
4135 if ( mp->lo_mem_max+2<mp->hi_mem_min ) {
4136 if ( mp->lo_mem_max+2<=max_halfword ) {
4137 @<Grow more variable-size memory and |goto restart|@>;
4140 mp_overflow(mp, "main memory size",mp->mem_max);
4141 /* sorry, nothing satisfactory is left */
4142 @:MetaPost capacity exceeded main memory size}{\quad main memory size@>
4144 mp_link(r)=null; /* this node is now nonempty */
4145 mp->var_used+=s; /* maintain usage statistics */
4149 @ The lower part of |mem| grows by 1000 words at a time, unless
4150 we are very close to going under. When it grows, we simply link
4151 a new node into the available-space list. This method of controlled
4152 growth helps to keep the |mem| usage consecutive when \MP\ is
4153 implemented on ``virtual memory'' systems.
4156 @<Grow more variable-size memory and |goto restart|@>=
4158 if ( mp->hi_mem_min-mp->lo_mem_max>=1998 ) {
4159 t=mp->lo_mem_max+1000;
4161 t=mp->lo_mem_max+1+(mp->hi_mem_min-mp->lo_mem_max) / 2;
4162 /* |lo_mem_max+2<=t<hi_mem_min| */
4164 if ( t>max_halfword ) t=max_halfword;
4165 p=lmp_link(mp->rover); q=mp->lo_mem_max; rmp_link(p)=q; lmp_link(mp->rover)=q;
4166 rmp_link(q)=mp->rover; lmp_link(q)=p; mp_link(q)=empty_flag;
4167 node_size(q)=t-mp->lo_mem_max;
4168 mp->lo_mem_max=t; mp_link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null;
4173 @ @<Try to allocate...@>=
4174 q=p+node_size(p); /* find the physical successor */
4175 while ( is_empty(q) ) { /* merge node |p| with node |q| */
4176 t=rmp_link(q); tt=lmp_link(q);
4178 if ( q==mp->rover ) mp->rover=t;
4179 lmp_link(t)=tt; rmp_link(tt)=t;
4184 @<Allocate from the top of node |p| and |goto found|@>;
4187 if ( rmp_link(p)!=p ) {
4188 @<Allocate entire node |p| and |goto found|@>;
4191 node_size(p)=q-p /* reset the size in case it grew */
4193 @ @<Allocate from the top...@>=
4195 node_size(p)=r-p; /* store the remaining size */
4196 mp->rover=p; /* start searching here next time */
4200 @ Here we delete node |p| from the ring, and let |rover| rove around.
4202 @<Allocate entire...@>=
4204 mp->rover=rmp_link(p); t=lmp_link(p);
4205 lmp_link(mp->rover)=t; rmp_link(t)=mp->rover;
4209 @ Conversely, when some variable-size node |p| of size |s| is no longer needed,
4210 the operation |free_node(p,s)| will make its words available, by inserting
4211 |p| as a new empty node just before where |rover| now points.
4213 @<Internal library declarations@>=
4214 void mp_free_node (MP mp, pointer p, halfword s) ;
4217 void mp_free_node (MP mp, pointer p, halfword s) { /* variable-size node
4219 pointer q; /* |lmp_link(rover)| */
4220 node_size(p)=s; mp_link(p)=empty_flag;
4222 q=lmp_link(mp->rover); lmp_link(p)=q; rmp_link(p)=mp->rover; /* set both links */
4223 lmp_link(mp->rover)=p; rmp_link(q)=p; /* insert |p| into the ring */
4224 mp->var_used-=s; /* maintain statistics */
4227 @ Just before \.{INIMP} writes out the memory, it sorts the doubly linked
4228 available space list. The list is probably very short at such times, so a
4229 simple insertion sort is used. The smallest available location will be
4230 pointed to by |rover|, the next-smallest by |rmp_link(rover)|, etc.
4233 static void mp_sort_avail (MP mp) { /* sorts the available variable-size nodes
4235 pointer p,q,r; /* indices into |mem| */
4236 pointer old_rover; /* initial |rover| setting */
4237 p=mp_get_node(mp, 010000000000); /* merge adjacent free areas */
4238 p=rmp_link(mp->rover); rmp_link(mp->rover)=max_halfword; old_rover=mp->rover;
4239 while ( p!=old_rover ) {
4240 @<Sort |p| into the list starting at |rover|
4241 and advance |p| to |rmp_link(p)|@>;
4244 while ( rmp_link(p)!=max_halfword ) {
4245 lmp_link(rmp_link(p))=p; p=rmp_link(p);
4247 rmp_link(p)=mp->rover; lmp_link(mp->rover)=p;
4250 @ The following |while| loop is guaranteed to
4251 terminate, since the list that starts at
4252 |rover| ends with |max_halfword| during the sorting procedure.
4255 if ( p<mp->rover ) {
4256 q=p; p=rmp_link(q); rmp_link(q)=mp->rover; mp->rover=q;
4259 while ( rmp_link(q)<p ) q=rmp_link(q);
4260 r=rmp_link(p); rmp_link(p)=rmp_link(q); rmp_link(q)=p; p=r;
4263 @* \[11] Memory layout.
4264 Some areas of |mem| are dedicated to fixed usage, since static allocation is
4265 more efficient than dynamic allocation when we can get away with it. For
4266 example, locations |0| to |1| are always used to store a
4267 two-word dummy token whose second word is zero.
4268 The following macro definitions accomplish the static allocation by giving
4269 symbolic names to the fixed positions. Static variable-size nodes appear
4270 in locations |0| through |lo_mem_stat_max|, and static single-word nodes
4271 appear in locations |hi_mem_stat_min| through |mem_top|, inclusive.
4273 @d null_dash (2) /* the first two words are reserved for a null value */
4274 @d dep_head (null_dash+3) /* we will define |dash_node_size=3| */
4275 @d zero_val (dep_head+2) /* two words for a permanently zero value */
4276 @d temp_val (zero_val+2) /* two words for a temporary value node */
4277 @d end_attr temp_val /* we use |end_attr+2| only */
4278 @d inf_val (end_attr+2) /* and |inf_val+1| only */
4279 @d test_pen (inf_val+2)
4280 /* nine words for a pen used when testing the turning number */
4281 @d bad_vardef (test_pen+9) /* two words for \&{vardef} error recovery */
4282 @d lo_mem_stat_max (bad_vardef+1) /* largest statically
4283 allocated word in the variable-size |mem| */
4285 @d sentinel mp->mem_top /* end of sorted lists */
4286 @d temp_head (mp->mem_top-1) /* head of a temporary list of some kind */
4287 @d hold_head (mp->mem_top-2) /* head of a temporary list of another kind */
4288 @d spec_head (mp->mem_top-3) /* head of a list of unprocessed \&{special} items */
4289 @d hi_mem_stat_min (mp->mem_top-3) /* smallest statically allocated word in
4290 the one-word |mem| */
4292 @ The following code gets the dynamic part of |mem| off to a good start,
4293 when \MP\ is initializing itself the slow way.
4295 @<Initialize table entries (done by \.{INIMP} only)@>=
4296 mp->rover=lo_mem_stat_max+1; /* initialize the dynamic memory */
4297 mp_link(mp->rover)=empty_flag;
4298 node_size(mp->rover)=1000; /* which is a 1000-word available node */
4299 lmp_link(mp->rover)=mp->rover; rmp_link(mp->rover)=mp->rover;
4300 mp->lo_mem_max=mp->rover+1000;
4301 mp_link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null;
4302 for (k=hi_mem_stat_min;k<=(int)mp->mem_top;k++) {
4303 mp->mem[k]=mp->mem[mp->lo_mem_max]; /* clear list heads */
4305 mp->avail=null; mp->mem_end=mp->mem_top;
4306 mp->hi_mem_min=hi_mem_stat_min; /* initialize the one-word memory */
4307 mp->var_used=lo_mem_stat_max+1;
4308 mp->dyn_used=mp->mem_top+1-(hi_mem_stat_min); /* initialize statistics */
4309 @<Initialize a pen at |test_pen| so that it fits in nine words@>;
4311 @ The procedure |flush_list(p)| frees an entire linked list of one-word
4312 nodes that starts at a given position, until coming to |sentinel| or a
4313 pointer that is not in the one-word region. Another procedure,
4314 |flush_node_list|, frees an entire linked list of one-word and two-word
4315 nodes, until coming to a |null| pointer.
4319 static void mp_flush_list (MP mp,pointer p) { /* makes list of single-word nodes available */
4320 pointer q,r; /* list traversers */
4321 if ( p>=mp->hi_mem_min ) if ( p!=sentinel ) {
4326 if ( r<mp->hi_mem_min ) break;
4327 } while (r!=sentinel);
4328 /* now |q| is the last node on the list */
4329 mp_link(q)=mp->avail; mp->avail=p;
4333 static void mp_flush_node_list (MP mp,pointer p) {
4334 pointer q; /* the node being recycled */
4337 if ( q<mp->hi_mem_min )
4338 mp_free_node(mp, q,2);
4344 @ If \MP\ is extended improperly, the |mem| array might get screwed up.
4345 For example, some pointers might be wrong, or some ``dead'' nodes might not
4346 have been freed when the last reference to them disappeared. Procedures
4347 |check_mem| and |search_mem| are available to help diagnose such
4348 problems. These procedures make use of two arrays called |free| and
4349 |was_free| that are present only if \MP's debugging routines have
4350 been included. (You may want to decrease the size of |mem| while you
4354 Because |boolean|s are typedef-d as ints, it is better to use
4355 unsigned chars here.
4358 unsigned char *free; /* free cells */
4359 unsigned char *was_free; /* previously free cells */
4360 pointer was_mem_end; pointer was_lo_max; pointer was_hi_min;
4361 /* previous |mem_end|, |lo_mem_max|,and |hi_mem_min| */
4362 boolean panicking; /* do we want to check memory constantly? */
4364 @ @<Allocate or initialize ...@>=
4365 mp->free = xmalloc ((mp->mem_max+1),sizeof (unsigned char));
4366 mp->was_free = xmalloc ((mp->mem_max+1), sizeof (unsigned char));
4368 @ @<Dealloc variables@>=
4370 xfree(mp->was_free);
4372 @ @<Allocate or ...@>=
4373 mp->was_hi_min=mp->mem_max;
4374 mp->panicking=false;
4377 static void mp_reallocate_memory(MP mp, int l) ;
4380 static void mp_reallocate_memory(MP mp, int l) {
4381 XREALLOC(mp->free, l, unsigned char);
4382 XREALLOC(mp->was_free, l, unsigned char);
4384 int newarea = l-mp->mem_max;
4385 XREALLOC(mp->mem, l, memory_word);
4386 memset (mp->mem+(mp->mem_max+1),0,sizeof(memory_word)*(newarea));
4388 XREALLOC(mp->mem, l, memory_word);
4389 memset(mp->mem,0,sizeof(memory_word)*(l+1));
4392 if (mp->ini_version)
4398 @ Procedure |check_mem| makes sure that the available space lists of
4399 |mem| are well formed, and it optionally prints out all locations
4400 that are reserved now but were free the last time this procedure was called.
4403 void mp_check_mem (MP mp,boolean print_locs ) {
4404 pointer p,q,r; /* current locations of interest in |mem| */
4405 boolean clobbered; /* is something amiss? */
4406 for (p=0;p<=mp->lo_mem_max;p++) {
4407 mp->free[p]=false; /* you can probably do this faster */
4409 for (p=mp->hi_mem_min;p<= mp->mem_end;p++) {
4410 mp->free[p]=false; /* ditto */
4412 @<Check single-word |avail| list@>;
4413 @<Check variable-size |avail| list@>;
4414 @<Check flags of unavailable nodes@>;
4415 @<Check the list of linear dependencies@>;
4417 @<Print newly busy locations@>;
4419 memcpy(mp->was_free,mp->free, sizeof(char)*(mp->mem_end+1));
4420 mp->was_mem_end=mp->mem_end;
4421 mp->was_lo_max=mp->lo_mem_max;
4422 mp->was_hi_min=mp->hi_mem_min;
4425 @ @<Check single-word...@>=
4426 p=mp->avail; q=null; clobbered=false;
4428 if ( (p>mp->mem_end)||(p<mp->hi_mem_min) ) clobbered=true;
4429 else if ( mp->free[p] ) clobbered=true;
4431 mp_print_nl(mp, "AVAIL list clobbered at ");
4432 @.AVAIL list clobbered...@>
4433 mp_print_int(mp, q); break;
4435 mp->free[p]=true; q=p; p=mp_link(q);
4438 @ @<Check variable-size...@>=
4439 p=mp->rover; q=null; clobbered=false;
4441 if ( (p>=mp->lo_mem_max)||(p<0) ) clobbered=true;
4442 else if ( (rmp_link(p)>=mp->lo_mem_max)||(rmp_link(p)<0) ) clobbered=true;
4443 else if ( !(is_empty(p))||(node_size(p)<2)||
4444 (p+node_size(p)>mp->lo_mem_max)|| (lmp_link(rmp_link(p))!=p) ) clobbered=true;
4446 mp_print_nl(mp, "Double-AVAIL list clobbered at ");
4447 @.Double-AVAIL list clobbered...@>
4448 mp_print_int(mp, q); break;
4450 for (q=p;q<=p+node_size(p)-1;q++) { /* mark all locations free */
4451 if ( mp->free[q] ) {
4452 mp_print_nl(mp, "Doubly free location at ");
4453 @.Doubly free location...@>
4454 mp_print_int(mp, q); break;
4459 } while (p!=mp->rover)
4462 @ @<Check flags...@>=
4464 while ( p<=mp->lo_mem_max ) { /* node |p| should not be empty */
4465 if ( is_empty(p) ) {
4466 mp_print_nl(mp, "Bad flag at "); mp_print_int(mp, p);
4469 while ( (p<=mp->lo_mem_max) && ! mp->free[p] ) p++;
4470 while ( (p<=mp->lo_mem_max) && mp->free[p] ) p++;
4473 @ @<Print newly busy...@>=
4475 @<Do intialization required before printing new busy locations@>;
4476 mp_print_nl(mp, "New busy locs:");
4478 for (p=0;p<= mp->lo_mem_max;p++ ) {
4479 if ( ! mp->free[p] && ((p>mp->was_lo_max) || mp->was_free[p]) ) {
4480 @<Indicate that |p| is a new busy location@>;
4483 for (p=mp->hi_mem_min;p<=mp->mem_end;p++ ) {
4484 if ( ! mp->free[p] &&
4485 ((p<mp->was_hi_min) || (p>mp->was_mem_end) || mp->was_free[p]) ) {
4486 @<Indicate that |p| is a new busy location@>;
4489 @<Finish printing new busy locations@>;
4492 @ There might be many new busy locations so we are careful to print contiguous
4493 blocks compactly. During this operation |q| is the last new busy location and
4494 |r| is the start of the block containing |q|.
4496 @<Indicate that |p| is a new busy location@>=
4500 mp_print(mp, ".."); mp_print_int(mp, q);
4502 mp_print_char(mp, xord(' ')); mp_print_int(mp, p);
4508 @ @<Do intialization required before printing new busy locations@>=
4509 q=mp->mem_max; r=mp->mem_max
4511 @ @<Finish printing new busy locations@>=
4513 mp_print(mp, ".."); mp_print_int(mp, q);
4516 @ The |search_mem| procedure attempts to answer the question ``Who points
4517 to node~|p|?'' In doing so, it fetches |link| and |info| fields of |mem|
4518 that might not be of type |two_halves|. Strictly speaking, this is
4519 undefined, and it can lead to ``false drops'' (words that seem to
4520 point to |p| purely by coincidence). But for debugging purposes, we want
4521 to rule out the places that do {\sl not\/} point to |p|, so a few false
4522 drops are tolerable.
4525 void mp_search_mem (MP mp, pointer p) { /* look for pointers to |p| */
4526 integer q; /* current position being searched */
4527 for (q=0;q<=mp->lo_mem_max;q++) {
4528 if ( mp_link(q)==p ){
4529 mp_print_nl(mp, "MP_LINK("); mp_print_int(mp, q); mp_print_char(mp, xord(')'));
4532 mp_print_nl(mp, "INFO("); mp_print_int(mp, q); mp_print_char(mp, xord(')'));
4535 for (q=mp->hi_mem_min;q<=mp->mem_end;q++) {
4536 if ( mp_link(q)==p ) {
4537 mp_print_nl(mp, "MP_LINK("); mp_print_int(mp, q); mp_print_char(mp, xord(')'));
4540 mp_print_nl(mp, "INFO("); mp_print_int(mp, q); mp_print_char(mp, xord(')'));
4543 @<Search |eqtb| for equivalents equal to |p|@>;
4546 @* \[12] The command codes.
4547 Before we can go much further, we need to define symbolic names for the internal
4548 code numbers that represent the various commands obeyed by \MP. These codes
4549 are somewhat arbitrary, but not completely so. For example,
4550 some codes have been made adjacent so that |case| statements in the
4551 program need not consider cases that are widely spaced, or so that |case|
4552 statements can be replaced by |if| statements. A command can begin an
4553 expression if and only if its code lies between |min_primary_command| and
4554 |max_primary_command|, inclusive. The first token of a statement that doesn't
4555 begin with an expression has a command code between |min_command| and
4556 |max_statement_command|, inclusive. Anything less than |min_command| is
4557 eliminated during macro expansions, and anything no more than |max_pre_command|
4558 is eliminated when expanding \TeX\ material. Ranges such as
4559 |min_secondary_command..max_secondary_command| are used when parsing
4560 expressions, but the relative ordering within such a range is generally not
4563 The ordering of the highest-numbered commands
4564 (|comma<semicolon<end_group<stop|) is crucial for the parsing and
4565 error-recovery methods of this program as is the ordering |if_test<fi_or_else|
4566 for the smallest two commands. The ordering is also important in the ranges
4567 |numeric_token..plus_or_minus| and |left_brace..ampersand|.
4569 At any rate, here is the list, for future reference.
4571 @d start_tex 1 /* begin \TeX\ material (\&{btex}, \&{verbatimtex}) */
4572 @d etex_marker 2 /* end \TeX\ material (\&{etex}) */
4573 @d mpx_break 3 /* stop reading an \.{MPX} file (\&{mpxbreak}) */
4574 @d max_pre_command mpx_break
4575 @d if_test 4 /* conditional text (\&{if}) */
4576 @d fi_or_else 5 /* delimiters for conditionals (\&{elseif}, \&{else}, \&{fi}) */
4577 @d input 6 /* input a source file (\&{input}, \&{endinput}) */
4578 @d iteration 7 /* iterate (\&{for}, \&{forsuffixes}, \&{forever}, \&{endfor}) */
4579 @d repeat_loop 8 /* special command substituted for \&{endfor} */
4580 @d exit_test 9 /* premature exit from a loop (\&{exitif}) */
4581 @d relax 10 /* do nothing (\.{\char`\\}) */
4582 @d scan_tokens 11 /* put a string into the input buffer */
4583 @d expand_after 12 /* look ahead one token */
4584 @d defined_macro 13 /* a macro defined by the user */
4585 @d min_command (defined_macro+1)
4586 @d save_command 14 /* save a list of tokens (\&{save}) */
4587 @d interim_command 15 /* save an internal quantity (\&{interim}) */
4588 @d let_command 16 /* redefine a symbolic token (\&{let}) */
4589 @d new_internal 17 /* define a new internal quantity (\&{newinternal}) */
4590 @d macro_def 18 /* define a macro (\&{def}, \&{vardef}, etc.) */
4591 @d ship_out_command 19 /* output a character (\&{shipout}) */
4592 @d add_to_command 20 /* add to edges (\&{addto}) */
4593 @d bounds_command 21 /* add bounding path to edges (\&{setbounds}, \&{clip}) */
4594 @d tfm_command 22 /* command for font metric info (\&{ligtable}, etc.) */
4595 @d protection_command 23 /* set protection flag (\&{outer}, \&{inner}) */
4596 @d show_command 24 /* diagnostic output (\&{show}, \&{showvariable}, etc.) */
4597 @d mode_command 25 /* set interaction level (\&{batchmode}, etc.) */
4598 @d mp_random_seed 26 /* initialize random number generator (\&{randomseed}) */
4599 @d message_command 27 /* communicate to user (\&{message}, \&{errmessage}) */
4600 @d every_job_command 28 /* designate a starting token (\&{everyjob}) */
4601 @d delimiters 29 /* define a pair of delimiters (\&{delimiters}) */
4602 @d special_command 30 /* output special info (\&{special})
4603 or font map info (\&{fontmapfile}, \&{fontmapline}) */
4604 @d write_command 31 /* write text to a file (\&{write}) */
4605 @d type_name 32 /* declare a type (\&{numeric}, \&{pair}, etc.) */
4606 @d max_statement_command type_name
4607 @d min_primary_command type_name
4608 @d left_delimiter 33 /* the left delimiter of a matching pair */
4609 @d begin_group 34 /* beginning of a group (\&{begingroup}) */
4610 @d nullary 35 /* an operator without arguments (e.g., \&{normaldeviate}) */
4611 @d unary 36 /* an operator with one argument (e.g., \&{sqrt}) */
4612 @d str_op 37 /* convert a suffix to a string (\&{str}) */
4613 @d cycle 38 /* close a cyclic path (\&{cycle}) */
4614 @d primary_binary 39 /* binary operation taking `\&{of}' (e.g., \&{point}) */
4615 @d capsule_token 40 /* a value that has been put into a token list */
4616 @d string_token 41 /* a string constant (e.g., |"hello"|) */
4617 @d internal_quantity 42 /* internal numeric parameter (e.g., \&{pausing}) */
4618 @d min_suffix_token internal_quantity
4619 @d tag_token 43 /* a symbolic token without a primitive meaning */
4620 @d numeric_token 44 /* a numeric constant (e.g., \.{3.14159}) */
4621 @d max_suffix_token numeric_token
4622 @d plus_or_minus 45 /* either `\.+' or `\.-' */
4623 @d max_primary_command plus_or_minus /* should also be |numeric_token+1| */
4624 @d min_tertiary_command plus_or_minus
4625 @d tertiary_secondary_macro 46 /* a macro defined by \&{secondarydef} */
4626 @d tertiary_binary 47 /* an operator at the tertiary level (e.g., `\.{++}') */
4627 @d max_tertiary_command tertiary_binary
4628 @d left_brace 48 /* the operator `\.{\char`\{}' */
4629 @d min_expression_command left_brace
4630 @d path_join 49 /* the operator `\.{..}' */
4631 @d ampersand 50 /* the operator `\.\&' */
4632 @d expression_tertiary_macro 51 /* a macro defined by \&{tertiarydef} */
4633 @d expression_binary 52 /* an operator at the expression level (e.g., `\.<') */
4634 @d equals 53 /* the operator `\.=' */
4635 @d max_expression_command equals
4636 @d and_command 54 /* the operator `\&{and}' */
4637 @d min_secondary_command and_command
4638 @d secondary_primary_macro 55 /* a macro defined by \&{primarydef} */
4639 @d slash 56 /* the operator `\./' */
4640 @d secondary_binary 57 /* an operator at the binary level (e.g., \&{shifted}) */
4641 @d max_secondary_command secondary_binary
4642 @d param_type 58 /* type of parameter (\&{primary}, \&{expr}, \&{suffix}, etc.) */
4643 @d controls 59 /* specify control points explicitly (\&{controls}) */
4644 @d tension 60 /* specify tension between knots (\&{tension}) */
4645 @d at_least 61 /* bounded tension value (\&{atleast}) */
4646 @d curl_command 62 /* specify curl at an end knot (\&{curl}) */
4647 @d macro_special 63 /* special macro operators (\&{quote}, \.{\#\AT!}, etc.) */
4648 @d right_delimiter 64 /* the right delimiter of a matching pair */
4649 @d left_bracket 65 /* the operator `\.[' */
4650 @d right_bracket 66 /* the operator `\.]' */
4651 @d right_brace 67 /* the operator `\.{\char`\}}' */
4652 @d with_option 68 /* option for filling (\&{withpen}, \&{withweight}, etc.) */
4654 /* variant of \&{addto} (\&{contour}, \&{doublepath}, \&{also}) */
4655 @d of_token 70 /* the operator `\&{of}' */
4656 @d to_token 71 /* the operator `\&{to}' */
4657 @d step_token 72 /* the operator `\&{step}' */
4658 @d until_token 73 /* the operator `\&{until}' */
4659 @d within_token 74 /* the operator `\&{within}' */
4660 @d lig_kern_token 75
4661 /* the operators `\&{kern}' and `\.{=:}' and `\.{=:\char'174}', etc. */
4662 @d assignment 76 /* the operator `\.{:=}' */
4663 @d skip_to 77 /* the operation `\&{skipto}' */
4664 @d bchar_label 78 /* the operator `\.{\char'174\char'174:}' */
4665 @d double_colon 79 /* the operator `\.{::}' */
4666 @d colon 80 /* the operator `\.:' */
4668 @d comma 81 /* the operator `\.,', must be |colon+1| */
4669 @d end_of_statement (mp->cur_cmd>comma)
4670 @d semicolon 82 /* the operator `\.;', must be |comma+1| */
4671 @d end_group 83 /* end a group (\&{endgroup}), must be |semicolon+1| */
4672 @d stop 84 /* end a job (\&{end}, \&{dump}), must be |end_group+1| */
4673 @d max_command_code stop
4674 @d outer_tag (max_command_code+1) /* protection code added to command code */
4677 typedef int command_code;
4679 @ Variables and capsules in \MP\ have a variety of ``types,''
4680 distinguished by the code numbers defined here. These numbers are also
4681 not completely arbitrary. Things that get expanded must have types
4682 |>mp_independent|; a type remaining after expansion is numeric if and only if
4683 its code number is at least |numeric_type|; objects containing numeric
4684 parts must have types between |transform_type| and |pair_type|;
4685 all other types must be smaller than |transform_type|; and among the types
4686 that are not unknown or vacuous, the smallest two must be |boolean_type|
4687 and |string_type| in that order.
4689 @d undefined 0 /* no type has been declared */
4690 @d unknown_tag 1 /* this constant is added to certain type codes below */
4691 @d unknown_types mp_unknown_boolean: case mp_unknown_string:
4692 case mp_unknown_pen: case mp_unknown_picture: case mp_unknown_path
4695 enum mp_variable_type {
4696 mp_vacuous=1, /* no expression was present */
4697 mp_boolean_type, /* \&{boolean} with a known value */
4699 mp_string_type, /* \&{string} with a known value */
4701 mp_pen_type, /* \&{pen} with a known value */
4703 mp_path_type, /* \&{path} with a known value */
4705 mp_picture_type, /* \&{picture} with a known value */
4707 mp_transform_type, /* \&{transform} variable or capsule */
4708 mp_color_type, /* \&{color} variable or capsule */
4709 mp_cmykcolor_type, /* \&{cmykcolor} variable or capsule */
4710 mp_pair_type, /* \&{pair} variable or capsule */
4711 mp_numeric_type, /* variable that has been declared \&{numeric} but not used */
4712 mp_known, /* \&{numeric} with a known value */
4713 mp_dependent, /* a linear combination with |fraction| coefficients */
4714 mp_proto_dependent, /* a linear combination with |scaled| coefficients */
4715 mp_independent, /* \&{numeric} with unknown value */
4716 mp_token_list, /* variable name or suffix argument or text argument */
4717 mp_structured, /* variable with subscripts and attributes */
4718 mp_unsuffixed_macro, /* variable defined with \&{vardef} but no \.{\AT!\#} */
4719 mp_suffixed_macro /* variable defined with \&{vardef} and \.{\AT!\#} */
4723 static void mp_print_type (MP mp,quarterword t) ;
4725 @ @<Basic printing procedures@>=
4726 void mp_print_type (MP mp,quarterword t) {
4728 case mp_vacuous:mp_print(mp, "mp_vacuous"); break;
4729 case mp_boolean_type:mp_print(mp, "boolean"); break;
4730 case mp_unknown_boolean:mp_print(mp, "unknown boolean"); break;
4731 case mp_string_type:mp_print(mp, "string"); break;
4732 case mp_unknown_string:mp_print(mp, "unknown string"); break;
4733 case mp_pen_type:mp_print(mp, "pen"); break;
4734 case mp_unknown_pen:mp_print(mp, "unknown pen"); break;
4735 case mp_path_type:mp_print(mp, "path"); break;
4736 case mp_unknown_path:mp_print(mp, "unknown path"); break;
4737 case mp_picture_type:mp_print(mp, "picture"); break;
4738 case mp_unknown_picture:mp_print(mp, "unknown picture"); break;
4739 case mp_transform_type:mp_print(mp, "transform"); break;
4740 case mp_color_type:mp_print(mp, "color"); break;
4741 case mp_cmykcolor_type:mp_print(mp, "cmykcolor"); break;
4742 case mp_pair_type:mp_print(mp, "pair"); break;
4743 case mp_known:mp_print(mp, "known numeric"); break;
4744 case mp_dependent:mp_print(mp, "dependent"); break;
4745 case mp_proto_dependent:mp_print(mp, "proto-dependent"); break;
4746 case mp_numeric_type:mp_print(mp, "numeric"); break;
4747 case mp_independent:mp_print(mp, "independent"); break;
4748 case mp_token_list:mp_print(mp, "token list"); break;
4749 case mp_structured:mp_print(mp, "mp_structured"); break;
4750 case mp_unsuffixed_macro:mp_print(mp, "unsuffixed macro"); break;
4751 case mp_suffixed_macro:mp_print(mp, "suffixed macro"); break;
4752 default: mp_print(mp, "undefined"); break;
4756 @ Values inside \MP\ are stored in two-word nodes that have a |name_type|
4757 as well as a |type|. The possibilities for |name_type| are defined
4758 here; they will be explained in more detail later.
4762 mp_root=0, /* |name_type| at the top level of a variable */
4763 mp_saved_root, /* same, when the variable has been saved */
4764 mp_structured_root, /* |name_type| where a |mp_structured| branch occurs */
4765 mp_subscr, /* |name_type| in a subscript node */
4766 mp_attr, /* |name_type| in an attribute node */
4767 mp_x_part_sector, /* |name_type| in the \&{xpart} of a node */
4768 mp_y_part_sector, /* |name_type| in the \&{ypart} of a node */
4769 mp_xx_part_sector, /* |name_type| in the \&{xxpart} of a node */
4770 mp_xy_part_sector, /* |name_type| in the \&{xypart} of a node */
4771 mp_yx_part_sector, /* |name_type| in the \&{yxpart} of a node */
4772 mp_yy_part_sector, /* |name_type| in the \&{yypart} of a node */
4773 mp_red_part_sector, /* |name_type| in the \&{redpart} of a node */
4774 mp_green_part_sector, /* |name_type| in the \&{greenpart} of a node */
4775 mp_blue_part_sector, /* |name_type| in the \&{bluepart} of a node */
4776 mp_cyan_part_sector, /* |name_type| in the \&{redpart} of a node */
4777 mp_magenta_part_sector, /* |name_type| in the \&{greenpart} of a node */
4778 mp_yellow_part_sector, /* |name_type| in the \&{bluepart} of a node */
4779 mp_black_part_sector, /* |name_type| in the \&{greenpart} of a node */
4780 mp_grey_part_sector, /* |name_type| in the \&{bluepart} of a node */
4781 mp_capsule, /* |name_type| in stashed-away subexpressions */
4782 mp_token /* |name_type| in a numeric token or string token */
4785 @ Primitive operations that produce values have a secondary identification
4786 code in addition to their command code; it's something like genera and species.
4787 For example, `\.*' has the command code |primary_binary|, and its
4788 secondary identification is |times|. The secondary codes start at 30 so that
4789 they don't overlap with the type codes; some type codes (e.g., |mp_string_type|)
4790 are used as operators as well as type identifications. The relative values
4791 are not critical, except for |true_code..false_code|, |or_op..and_op|,
4792 and |filled_op..bounded_op|. The restrictions are that
4793 |and_op-false_code=or_op-true_code|, that the ordering of
4794 |x_part...blue_part| must match that of |x_part_sector..mp_blue_part_sector|,
4795 and the ordering of |filled_op..bounded_op| must match that of the code
4796 values they test for.
4798 @d true_code 30 /* operation code for \.{true} */
4799 @d false_code 31 /* operation code for \.{false} */
4800 @d null_picture_code 32 /* operation code for \.{nullpicture} */
4801 @d null_pen_code 33 /* operation code for \.{nullpen} */
4802 @d job_name_op 34 /* operation code for \.{jobname} */
4803 @d read_string_op 35 /* operation code for \.{readstring} */
4804 @d pen_circle 36 /* operation code for \.{pencircle} */
4805 @d normal_deviate 37 /* operation code for \.{normaldeviate} */
4806 @d read_from_op 38 /* operation code for \.{readfrom} */
4807 @d close_from_op 39 /* operation code for \.{closefrom} */
4808 @d odd_op 40 /* operation code for \.{odd} */
4809 @d known_op 41 /* operation code for \.{known} */
4810 @d unknown_op 42 /* operation code for \.{unknown} */
4811 @d not_op 43 /* operation code for \.{not} */
4812 @d decimal 44 /* operation code for \.{decimal} */
4813 @d reverse 45 /* operation code for \.{reverse} */
4814 @d make_path_op 46 /* operation code for \.{makepath} */
4815 @d make_pen_op 47 /* operation code for \.{makepen} */
4816 @d oct_op 48 /* operation code for \.{oct} */
4817 @d hex_op 49 /* operation code for \.{hex} */
4818 @d ASCII_op 50 /* operation code for \.{ASCII} */
4819 @d char_op 51 /* operation code for \.{char} */
4820 @d length_op 52 /* operation code for \.{length} */
4821 @d turning_op 53 /* operation code for \.{turningnumber} */
4822 @d color_model_part 54 /* operation code for \.{colormodel} */
4823 @d x_part 55 /* operation code for \.{xpart} */
4824 @d y_part 56 /* operation code for \.{ypart} */
4825 @d xx_part 57 /* operation code for \.{xxpart} */
4826 @d xy_part 58 /* operation code for \.{xypart} */
4827 @d yx_part 59 /* operation code for \.{yxpart} */
4828 @d yy_part 60 /* operation code for \.{yypart} */
4829 @d red_part 61 /* operation code for \.{redpart} */
4830 @d green_part 62 /* operation code for \.{greenpart} */
4831 @d blue_part 63 /* operation code for \.{bluepart} */
4832 @d cyan_part 64 /* operation code for \.{cyanpart} */
4833 @d magenta_part 65 /* operation code for \.{magentapart} */
4834 @d yellow_part 66 /* operation code for \.{yellowpart} */
4835 @d black_part 67 /* operation code for \.{blackpart} */
4836 @d grey_part 68 /* operation code for \.{greypart} */
4837 @d font_part 69 /* operation code for \.{fontpart} */
4838 @d text_part 70 /* operation code for \.{textpart} */
4839 @d path_part 71 /* operation code for \.{pathpart} */
4840 @d pen_part 72 /* operation code for \.{penpart} */
4841 @d dash_part 73 /* operation code for \.{dashpart} */
4842 @d sqrt_op 74 /* operation code for \.{sqrt} */
4843 @d mp_m_exp_op 75 /* operation code for \.{mexp} */
4844 @d mp_m_log_op 76 /* operation code for \.{mlog} */
4845 @d sin_d_op 77 /* operation code for \.{sind} */
4846 @d cos_d_op 78 /* operation code for \.{cosd} */
4847 @d floor_op 79 /* operation code for \.{floor} */
4848 @d uniform_deviate 80 /* operation code for \.{uniformdeviate} */
4849 @d char_exists_op 81 /* operation code for \.{charexists} */
4850 @d font_size 82 /* operation code for \.{fontsize} */
4851 @d ll_corner_op 83 /* operation code for \.{llcorner} */
4852 @d lr_corner_op 84 /* operation code for \.{lrcorner} */
4853 @d ul_corner_op 85 /* operation code for \.{ulcorner} */
4854 @d ur_corner_op 86 /* operation code for \.{urcorner} */
4855 @d arc_length 87 /* operation code for \.{arclength} */
4856 @d angle_op 88 /* operation code for \.{angle} */
4857 @d cycle_op 89 /* operation code for \.{cycle} */
4858 @d filled_op 90 /* operation code for \.{filled} */
4859 @d stroked_op 91 /* operation code for \.{stroked} */
4860 @d textual_op 92 /* operation code for \.{textual} */
4861 @d clipped_op 93 /* operation code for \.{clipped} */
4862 @d bounded_op 94 /* operation code for \.{bounded} */
4863 @d plus 95 /* operation code for \.+ */
4864 @d minus 96 /* operation code for \.- */
4865 @d times 97 /* operation code for \.* */
4866 @d over 98 /* operation code for \./ */
4867 @d pythag_add 99 /* operation code for \.{++} */
4868 @d pythag_sub 100 /* operation code for \.{+-+} */
4869 @d or_op 101 /* operation code for \.{or} */
4870 @d and_op 102 /* operation code for \.{and} */
4871 @d less_than 103 /* operation code for \.< */
4872 @d less_or_equal 104 /* operation code for \.{<=} */
4873 @d greater_than 105 /* operation code for \.> */
4874 @d greater_or_equal 106 /* operation code for \.{>=} */
4875 @d equal_to 107 /* operation code for \.= */
4876 @d unequal_to 108 /* operation code for \.{<>} */
4877 @d concatenate 109 /* operation code for \.\& */
4878 @d rotated_by 110 /* operation code for \.{rotated} */
4879 @d slanted_by 111 /* operation code for \.{slanted} */
4880 @d scaled_by 112 /* operation code for \.{scaled} */
4881 @d shifted_by 113 /* operation code for \.{shifted} */
4882 @d transformed_by 114 /* operation code for \.{transformed} */
4883 @d x_scaled 115 /* operation code for \.{xscaled} */
4884 @d y_scaled 116 /* operation code for \.{yscaled} */
4885 @d z_scaled 117 /* operation code for \.{zscaled} */
4886 @d in_font 118 /* operation code for \.{infont} */
4887 @d intersect 119 /* operation code for \.{intersectiontimes} */
4888 @d double_dot 120 /* operation code for improper \.{..} */
4889 @d substring_of 121 /* operation code for \.{substring} */
4890 @d min_of substring_of
4891 @d subpath_of 122 /* operation code for \.{subpath} */
4892 @d direction_time_of 123 /* operation code for \.{directiontime} */
4893 @d point_of 124 /* operation code for \.{point} */
4894 @d precontrol_of 125 /* operation code for \.{precontrol} */
4895 @d postcontrol_of 126 /* operation code for \.{postcontrol} */
4896 @d pen_offset_of 127 /* operation code for \.{penoffset} */
4897 @d arc_time_of 128 /* operation code for \.{arctime} */
4898 @d mp_version 129 /* operation code for \.{mpversion} */
4899 @d envelope_of 130 /* operation code for \.{envelope} */
4901 @c static void mp_print_op (MP mp,quarterword c) {
4902 if (c<=mp_numeric_type ) {
4903 mp_print_type(mp, c);
4906 case true_code:mp_print(mp, "true"); break;
4907 case false_code:mp_print(mp, "false"); break;
4908 case null_picture_code:mp_print(mp, "nullpicture"); break;
4909 case null_pen_code:mp_print(mp, "nullpen"); break;
4910 case job_name_op:mp_print(mp, "jobname"); break;
4911 case read_string_op:mp_print(mp, "readstring"); break;
4912 case pen_circle:mp_print(mp, "pencircle"); break;
4913 case normal_deviate:mp_print(mp, "normaldeviate"); break;
4914 case read_from_op:mp_print(mp, "readfrom"); break;
4915 case close_from_op:mp_print(mp, "closefrom"); break;
4916 case odd_op:mp_print(mp, "odd"); break;
4917 case known_op:mp_print(mp, "known"); break;
4918 case unknown_op:mp_print(mp, "unknown"); break;
4919 case not_op:mp_print(mp, "not"); break;
4920 case decimal:mp_print(mp, "decimal"); break;
4921 case reverse:mp_print(mp, "reverse"); break;
4922 case make_path_op:mp_print(mp, "makepath"); break;
4923 case make_pen_op:mp_print(mp, "makepen"); break;
4924 case oct_op:mp_print(mp, "oct"); break;
4925 case hex_op:mp_print(mp, "hex"); break;
4926 case ASCII_op:mp_print(mp, "ASCII"); break;
4927 case char_op:mp_print(mp, "char"); break;
4928 case length_op:mp_print(mp, "length"); break;
4929 case turning_op:mp_print(mp, "turningnumber"); break;
4930 case x_part:mp_print(mp, "xpart"); break;
4931 case y_part:mp_print(mp, "ypart"); break;
4932 case xx_part:mp_print(mp, "xxpart"); break;
4933 case xy_part:mp_print(mp, "xypart"); break;
4934 case yx_part:mp_print(mp, "yxpart"); break;
4935 case yy_part:mp_print(mp, "yypart"); break;
4936 case red_part:mp_print(mp, "redpart"); break;
4937 case green_part:mp_print(mp, "greenpart"); break;
4938 case blue_part:mp_print(mp, "bluepart"); break;
4939 case cyan_part:mp_print(mp, "cyanpart"); break;
4940 case magenta_part:mp_print(mp, "magentapart"); break;
4941 case yellow_part:mp_print(mp, "yellowpart"); break;
4942 case black_part:mp_print(mp, "blackpart"); break;
4943 case grey_part:mp_print(mp, "greypart"); break;
4944 case color_model_part:mp_print(mp, "colormodel"); break;
4945 case font_part:mp_print(mp, "fontpart"); break;
4946 case text_part:mp_print(mp, "textpart"); break;
4947 case path_part:mp_print(mp, "pathpart"); break;
4948 case pen_part:mp_print(mp, "penpart"); break;
4949 case dash_part:mp_print(mp, "dashpart"); break;
4950 case sqrt_op:mp_print(mp, "sqrt"); break;
4951 case mp_m_exp_op:mp_print(mp, "mexp"); break;
4952 case mp_m_log_op:mp_print(mp, "mlog"); break;
4953 case sin_d_op:mp_print(mp, "sind"); break;
4954 case cos_d_op:mp_print(mp, "cosd"); break;
4955 case floor_op:mp_print(mp, "floor"); break;
4956 case uniform_deviate:mp_print(mp, "uniformdeviate"); break;
4957 case char_exists_op:mp_print(mp, "charexists"); break;
4958 case font_size:mp_print(mp, "fontsize"); break;
4959 case ll_corner_op:mp_print(mp, "llcorner"); break;
4960 case lr_corner_op:mp_print(mp, "lrcorner"); break;
4961 case ul_corner_op:mp_print(mp, "ulcorner"); break;
4962 case ur_corner_op:mp_print(mp, "urcorner"); break;
4963 case arc_length:mp_print(mp, "arclength"); break;
4964 case angle_op:mp_print(mp, "angle"); break;
4965 case cycle_op:mp_print(mp, "cycle"); break;
4966 case filled_op:mp_print(mp, "filled"); break;
4967 case stroked_op:mp_print(mp, "stroked"); break;
4968 case textual_op:mp_print(mp, "textual"); break;
4969 case clipped_op:mp_print(mp, "clipped"); break;
4970 case bounded_op:mp_print(mp, "bounded"); break;
4971 case plus:mp_print_char(mp, xord('+')); break;
4972 case minus:mp_print_char(mp, xord('-')); break;
4973 case times:mp_print_char(mp, xord('*')); break;
4974 case over:mp_print_char(mp, xord('/')); break;
4975 case pythag_add:mp_print(mp, "++"); break;
4976 case pythag_sub:mp_print(mp, "+-+"); break;
4977 case or_op:mp_print(mp, "or"); break;
4978 case and_op:mp_print(mp, "and"); break;
4979 case less_than:mp_print_char(mp, xord('<')); break;
4980 case less_or_equal:mp_print(mp, "<="); break;
4981 case greater_than:mp_print_char(mp, xord('>')); break;
4982 case greater_or_equal:mp_print(mp, ">="); break;
4983 case equal_to:mp_print_char(mp, xord('=')); break;
4984 case unequal_to:mp_print(mp, "<>"); break;
4985 case concatenate:mp_print(mp, "&"); break;
4986 case rotated_by:mp_print(mp, "rotated"); break;
4987 case slanted_by:mp_print(mp, "slanted"); break;
4988 case scaled_by:mp_print(mp, "scaled"); break;
4989 case shifted_by:mp_print(mp, "shifted"); break;
4990 case transformed_by:mp_print(mp, "transformed"); break;
4991 case x_scaled:mp_print(mp, "xscaled"); break;
4992 case y_scaled:mp_print(mp, "yscaled"); break;
4993 case z_scaled:mp_print(mp, "zscaled"); break;
4994 case in_font:mp_print(mp, "infont"); break;
4995 case intersect:mp_print(mp, "intersectiontimes"); break;
4996 case substring_of:mp_print(mp, "substring"); break;
4997 case subpath_of:mp_print(mp, "subpath"); break;
4998 case direction_time_of:mp_print(mp, "directiontime"); break;
4999 case point_of:mp_print(mp, "point"); break;
5000 case precontrol_of:mp_print(mp, "precontrol"); break;
5001 case postcontrol_of:mp_print(mp, "postcontrol"); break;
5002 case pen_offset_of:mp_print(mp, "penoffset"); break;
5003 case arc_time_of:mp_print(mp, "arctime"); break;
5004 case mp_version:mp_print(mp, "mpversion"); break;
5005 case envelope_of:mp_print(mp, "envelope"); break;
5006 default: mp_print(mp, ".."); break;
5011 @ \MP\ also has a bunch of internal parameters that a user might want to
5012 fuss with. Every such parameter has an identifying code number, defined here.
5015 enum mp_given_internal {
5016 mp_tracing_titles=1, /* show titles online when they appear */
5017 mp_tracing_equations, /* show each variable when it becomes known */
5018 mp_tracing_capsules, /* show capsules too */
5019 mp_tracing_choices, /* show the control points chosen for paths */
5020 mp_tracing_specs, /* show path subdivision prior to filling with polygonal a pen */
5021 mp_tracing_commands, /* show commands and operations before they are performed */
5022 mp_tracing_restores, /* show when a variable or internal is restored */
5023 mp_tracing_macros, /* show macros before they are expanded */
5024 mp_tracing_output, /* show digitized edges as they are output */
5025 mp_tracing_stats, /* show memory usage at end of job */
5026 mp_tracing_lost_chars, /* show characters that aren't \&{infont} */
5027 mp_tracing_online, /* show long diagnostics on terminal and in the log file */
5028 mp_year, /* the current year (e.g., 1984) */
5029 mp_month, /* the current month (e.g., 3 $\equiv$ March) */
5030 mp_day, /* the current day of the month */
5031 mp_time, /* the number of minutes past midnight when this job started */
5032 mp_char_code, /* the number of the next character to be output */
5033 mp_char_ext, /* the extension code of the next character to be output */
5034 mp_char_wd, /* the width of the next character to be output */
5035 mp_char_ht, /* the height of the next character to be output */
5036 mp_char_dp, /* the depth of the next character to be output */
5037 mp_char_ic, /* the italic correction of the next character to be output */
5038 mp_design_size, /* the unit of measure used for |mp_char_wd..mp_char_ic|, in points */
5039 mp_pausing, /* positive to display lines on the terminal before they are read */
5040 mp_showstopping, /* positive to stop after each \&{show} command */
5041 mp_fontmaking, /* positive if font metric output is to be produced */
5042 mp_linejoin, /* as in \ps: 0 for mitered, 1 for round, 2 for beveled */
5043 mp_linecap, /* as in \ps: 0 for butt, 1 for round, 2 for square */
5044 mp_miterlimit, /* controls miter length as in \ps */
5045 mp_warning_check, /* controls error message when variable value is large */
5046 mp_boundary_char, /* the right boundary character for ligatures */
5047 mp_prologues, /* positive to output conforming PostScript using built-in fonts */
5048 mp_true_corners, /* positive to make \&{llcorner} etc. ignore \&{setbounds} */
5049 mp_default_color_model, /* the default color model for unspecified items */
5050 mp_restore_clip_color,
5051 mp_procset, /* wether or not create PostScript command shortcuts */
5052 mp_gtroffmode /* whether the user specified |-troff| on the command line */
5057 @d max_given_internal mp_gtroffmode
5060 scaled *internal; /* the values of internal quantities */
5061 char **int_name; /* their names */
5062 int int_ptr; /* the maximum internal quantity defined so far */
5063 int max_internal; /* current maximum number of internal quantities */
5065 @ @<Option variables@>=
5068 @ @<Allocate or initialize ...@>=
5069 mp->max_internal=2*max_given_internal;
5070 mp->internal = xmalloc ((mp->max_internal+1), sizeof(scaled));
5071 memset(mp->internal,0,(mp->max_internal+1)* sizeof(scaled));
5072 mp->int_name = xmalloc ((mp->max_internal+1), sizeof(char *));
5073 memset(mp->int_name,0,(mp->max_internal+1) * sizeof(char *));
5074 mp->troff_mode=(opt->troff_mode>0 ? true : false);
5076 @ @<Exported function ...@>=
5077 int mp_troff_mode(MP mp);
5080 int mp_troff_mode(MP mp) { return mp->troff_mode; }
5082 @ @<Set initial ...@>=
5083 mp->int_ptr=max_given_internal;
5085 @ The symbolic names for internal quantities are put into \MP's hash table
5086 by using a routine called |primitive|, which will be defined later. Let us
5087 enter them now, so that we don't have to list all those names again
5090 @<Put each of \MP's primitives into the hash table@>=
5091 mp_primitive(mp, "tracingtitles",internal_quantity,mp_tracing_titles);
5092 @:tracingtitles_}{\&{tracingtitles} primitive@>
5093 mp_primitive(mp, "tracingequations",internal_quantity,mp_tracing_equations);
5094 @:mp_tracing_equations_}{\&{tracingequations} primitive@>
5095 mp_primitive(mp, "tracingcapsules",internal_quantity,mp_tracing_capsules);
5096 @:mp_tracing_capsules_}{\&{tracingcapsules} primitive@>
5097 mp_primitive(mp, "tracingchoices",internal_quantity,mp_tracing_choices);
5098 @:mp_tracing_choices_}{\&{tracingchoices} primitive@>
5099 mp_primitive(mp, "tracingspecs",internal_quantity,mp_tracing_specs);
5100 @:mp_tracing_specs_}{\&{tracingspecs} primitive@>
5101 mp_primitive(mp, "tracingcommands",internal_quantity,mp_tracing_commands);
5102 @:mp_tracing_commands_}{\&{tracingcommands} primitive@>
5103 mp_primitive(mp, "tracingrestores",internal_quantity,mp_tracing_restores);
5104 @:mp_tracing_restores_}{\&{tracingrestores} primitive@>
5105 mp_primitive(mp, "tracingmacros",internal_quantity,mp_tracing_macros);
5106 @:mp_tracing_macros_}{\&{tracingmacros} primitive@>
5107 mp_primitive(mp, "tracingoutput",internal_quantity,mp_tracing_output);
5108 @:mp_tracing_output_}{\&{tracingoutput} primitive@>
5109 mp_primitive(mp, "tracingstats",internal_quantity,mp_tracing_stats);
5110 @:mp_tracing_stats_}{\&{tracingstats} primitive@>
5111 mp_primitive(mp, "tracinglostchars",internal_quantity,mp_tracing_lost_chars);
5112 @:mp_tracing_lost_chars_}{\&{tracinglostchars} primitive@>
5113 mp_primitive(mp, "tracingonline",internal_quantity,mp_tracing_online);
5114 @:mp_tracing_online_}{\&{tracingonline} primitive@>
5115 mp_primitive(mp, "year",internal_quantity,mp_year);
5116 @:mp_year_}{\&{year} primitive@>
5117 mp_primitive(mp, "month",internal_quantity,mp_month);
5118 @:mp_month_}{\&{month} primitive@>
5119 mp_primitive(mp, "day",internal_quantity,mp_day);
5120 @:mp_day_}{\&{day} primitive@>
5121 mp_primitive(mp, "time",internal_quantity,mp_time);
5122 @:time_}{\&{time} primitive@>
5123 mp_primitive(mp, "charcode",internal_quantity,mp_char_code);
5124 @:mp_char_code_}{\&{charcode} primitive@>
5125 mp_primitive(mp, "charext",internal_quantity,mp_char_ext);
5126 @:mp_char_ext_}{\&{charext} primitive@>
5127 mp_primitive(mp, "charwd",internal_quantity,mp_char_wd);
5128 @:mp_char_wd_}{\&{charwd} primitive@>
5129 mp_primitive(mp, "charht",internal_quantity,mp_char_ht);
5130 @:mp_char_ht_}{\&{charht} primitive@>
5131 mp_primitive(mp, "chardp",internal_quantity,mp_char_dp);
5132 @:mp_char_dp_}{\&{chardp} primitive@>
5133 mp_primitive(mp, "charic",internal_quantity,mp_char_ic);
5134 @:mp_char_ic_}{\&{charic} primitive@>
5135 mp_primitive(mp, "designsize",internal_quantity,mp_design_size);
5136 @:mp_design_size_}{\&{designsize} primitive@>
5137 mp_primitive(mp, "pausing",internal_quantity,mp_pausing);
5138 @:mp_pausing_}{\&{pausing} primitive@>
5139 mp_primitive(mp, "showstopping",internal_quantity,mp_showstopping);
5140 @:mp_showstopping_}{\&{showstopping} primitive@>
5141 mp_primitive(mp, "fontmaking",internal_quantity,mp_fontmaking);
5142 @:mp_fontmaking_}{\&{fontmaking} primitive@>
5143 mp_primitive(mp, "linejoin",internal_quantity,mp_linejoin);
5144 @:mp_linejoin_}{\&{linejoin} primitive@>
5145 mp_primitive(mp, "linecap",internal_quantity,mp_linecap);
5146 @:mp_linecap_}{\&{linecap} primitive@>
5147 mp_primitive(mp, "miterlimit",internal_quantity,mp_miterlimit);
5148 @:mp_miterlimit_}{\&{miterlimit} primitive@>
5149 mp_primitive(mp, "warningcheck",internal_quantity,mp_warning_check);
5150 @:mp_warning_check_}{\&{warningcheck} primitive@>
5151 mp_primitive(mp, "boundarychar",internal_quantity,mp_boundary_char);
5152 @:mp_boundary_char_}{\&{boundarychar} primitive@>
5153 mp_primitive(mp, "prologues",internal_quantity,mp_prologues);
5154 @:mp_prologues_}{\&{prologues} primitive@>
5155 mp_primitive(mp, "truecorners",internal_quantity,mp_true_corners);
5156 @:mp_true_corners_}{\&{truecorners} primitive@>
5157 mp_primitive(mp, "mpprocset",internal_quantity,mp_procset);
5158 @:mp_procset_}{\&{mpprocset} primitive@>
5159 mp_primitive(mp, "troffmode",internal_quantity,mp_gtroffmode);
5160 @:troffmode_}{\&{troffmode} primitive@>
5161 mp_primitive(mp, "defaultcolormodel",internal_quantity,mp_default_color_model);
5162 @:mp_default_color_model_}{\&{defaultcolormodel} primitive@>
5163 mp_primitive(mp, "restoreclipcolor",internal_quantity,mp_restore_clip_color);
5164 @:mp_restore_clip_color_}{\&{restoreclipcolor} primitive@>
5166 @ Colors can be specified in four color models. In the special
5167 case of |no_model|, MetaPost does not output any color operator to
5168 the postscript output.
5170 Note: these values are passed directly on to |with_option|. This only
5171 works because the other possible values passed to |with_option| are
5172 8 and 10 respectively (from |with_pen| and |with_picture|).
5174 There is a first state, that is only used for |gs_colormodel|. It flags
5175 the fact that there has not been any kind of color specification by
5176 the user so far in the game.
5179 enum mp_color_model {
5184 mp_uninitialized_model=9
5188 @ @<Initialize table entries (done by \.{INIMP} only)@>=
5189 mp->internal[mp_default_color_model]=(mp_rgb_model*unity);
5190 mp->internal[mp_restore_clip_color]=unity;
5192 @ Well, we do have to list the names one more time, for use in symbolic
5195 @<Initialize table...@>=
5196 mp->int_name[mp_tracing_titles]=xstrdup("tracingtitles");
5197 mp->int_name[mp_tracing_equations]=xstrdup("tracingequations");
5198 mp->int_name[mp_tracing_capsules]=xstrdup("tracingcapsules");
5199 mp->int_name[mp_tracing_choices]=xstrdup("tracingchoices");
5200 mp->int_name[mp_tracing_specs]=xstrdup("tracingspecs");
5201 mp->int_name[mp_tracing_commands]=xstrdup("tracingcommands");
5202 mp->int_name[mp_tracing_restores]=xstrdup("tracingrestores");
5203 mp->int_name[mp_tracing_macros]=xstrdup("tracingmacros");
5204 mp->int_name[mp_tracing_output]=xstrdup("tracingoutput");
5205 mp->int_name[mp_tracing_stats]=xstrdup("tracingstats");
5206 mp->int_name[mp_tracing_lost_chars]=xstrdup("tracinglostchars");
5207 mp->int_name[mp_tracing_online]=xstrdup("tracingonline");
5208 mp->int_name[mp_year]=xstrdup("year");
5209 mp->int_name[mp_month]=xstrdup("month");
5210 mp->int_name[mp_day]=xstrdup("day");
5211 mp->int_name[mp_time]=xstrdup("time");
5212 mp->int_name[mp_char_code]=xstrdup("charcode");
5213 mp->int_name[mp_char_ext]=xstrdup("charext");
5214 mp->int_name[mp_char_wd]=xstrdup("charwd");
5215 mp->int_name[mp_char_ht]=xstrdup("charht");
5216 mp->int_name[mp_char_dp]=xstrdup("chardp");
5217 mp->int_name[mp_char_ic]=xstrdup("charic");
5218 mp->int_name[mp_design_size]=xstrdup("designsize");
5219 mp->int_name[mp_pausing]=xstrdup("pausing");
5220 mp->int_name[mp_showstopping]=xstrdup("showstopping");
5221 mp->int_name[mp_fontmaking]=xstrdup("fontmaking");
5222 mp->int_name[mp_linejoin]=xstrdup("linejoin");
5223 mp->int_name[mp_linecap]=xstrdup("linecap");
5224 mp->int_name[mp_miterlimit]=xstrdup("miterlimit");
5225 mp->int_name[mp_warning_check]=xstrdup("warningcheck");
5226 mp->int_name[mp_boundary_char]=xstrdup("boundarychar");
5227 mp->int_name[mp_prologues]=xstrdup("prologues");
5228 mp->int_name[mp_true_corners]=xstrdup("truecorners");
5229 mp->int_name[mp_default_color_model]=xstrdup("defaultcolormodel");
5230 mp->int_name[mp_procset]=xstrdup("mpprocset");
5231 mp->int_name[mp_gtroffmode]=xstrdup("troffmode");
5232 mp->int_name[mp_restore_clip_color]=xstrdup("restoreclipcolor");
5234 @ The following procedure, which is called just before \MP\ initializes its
5235 input and output, establishes the initial values of the date and time.
5236 @^system dependencies@>
5238 Note that the values are |scaled| integers. Hence \MP\ can no longer
5239 be used after the year 32767.
5242 static void mp_fix_date_and_time (MP mp) {
5243 time_t aclock = time ((time_t *) 0);
5244 struct tm *tmptr = localtime (&aclock);
5245 mp->internal[mp_time]=
5246 (tmptr->tm_hour*60+tmptr->tm_min)*unity; /* minutes since midnight */
5247 mp->internal[mp_day]=(tmptr->tm_mday)*unity; /* fourth day of the month */
5248 mp->internal[mp_month]=(tmptr->tm_mon+1)*unity; /* seventh month of the year */
5249 mp->internal[mp_year]=(tmptr->tm_year+1900)*unity; /* Anno Domini */
5253 static void mp_fix_date_and_time (MP mp) ;
5255 @ \MP\ is occasionally supposed to print diagnostic information that
5256 goes only into the transcript file, unless |mp_tracing_online| is positive.
5257 Now that we have defined |mp_tracing_online| we can define
5258 two routines that adjust the destination of print commands:
5261 static void mp_begin_diagnostic (MP mp) ;
5262 static void mp_end_diagnostic (MP mp,boolean blank_line);
5263 static void mp_print_diagnostic (MP mp, const char *s, const char *t, boolean nuline) ;
5265 @ @<Basic printing...@>=
5266 void mp_begin_diagnostic (MP mp) { /* prepare to do some tracing */
5267 mp->old_setting=mp->selector;
5268 if ((mp->internal[mp_tracing_online]<=0)&&(mp->selector==term_and_log)){
5270 if ( mp->history==mp_spotless ) mp->history=mp_warning_issued;
5274 void mp_end_diagnostic (MP mp,boolean blank_line) {
5275 /* restore proper conditions after tracing */
5276 mp_print_nl(mp, "");
5277 if ( blank_line ) mp_print_ln(mp);
5278 mp->selector=mp->old_setting;
5284 unsigned int old_setting;
5286 @ We will occasionally use |begin_diagnostic| in connection with line-number
5287 printing, as follows. (The parameter |s| is typically |"Path"| or
5288 |"Cycle spec"|, etc.)
5290 @<Basic printing...@>=
5291 void mp_print_diagnostic (MP mp, const char *s, const char *t, boolean nuline) {
5292 mp_begin_diagnostic(mp);
5293 if ( nuline ) mp_print_nl(mp, s); else mp_print(mp, s);
5294 mp_print(mp, " at line ");
5295 mp_print_int(mp, mp_true_line(mp));
5296 mp_print(mp, t); mp_print_char(mp, xord(':'));
5299 @ The 256 |ASCII_code| characters are grouped into classes by means of
5300 the |char_class| table. Individual class numbers have no semantic
5301 or syntactic significance, except in a few instances defined here.
5302 There's also |max_class|, which can be used as a basis for additional
5303 class numbers in nonstandard extensions of \MP.
5305 @d digit_class 0 /* the class number of \.{0123456789} */
5306 @d period_class 1 /* the class number of `\..' */
5307 @d space_class 2 /* the class number of spaces and nonstandard characters */
5308 @d percent_class 3 /* the class number of `\.\%' */
5309 @d string_class 4 /* the class number of `\."' */
5310 @d right_paren_class 8 /* the class number of `\.)' */
5311 @d isolated_classes 5: case 6: case 7: case 8 /* characters that make length-one tokens only */
5312 @d letter_class 9 /* letters and the underline character */
5313 @d left_bracket_class 17 /* `\.[' */
5314 @d right_bracket_class 18 /* `\.]' */
5315 @d invalid_class 20 /* bad character in the input */
5316 @d max_class 20 /* the largest class number */
5319 int char_class[256]; /* the class numbers */
5321 @ If changes are made to accommodate non-ASCII character sets, they should
5322 follow the guidelines in Appendix~C of {\sl The {\logos METAFONT\/}book}.
5323 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
5324 @^system dependencies@>
5326 @<Set initial ...@>=
5327 for (k='0';k<='9';k++)
5328 mp->char_class[k]=digit_class;
5329 mp->char_class['.']=period_class;
5330 mp->char_class[' ']=space_class;
5331 mp->char_class['%']=percent_class;
5332 mp->char_class['"']=string_class;
5333 mp->char_class[',']=5;
5334 mp->char_class[';']=6;
5335 mp->char_class['(']=7;
5336 mp->char_class[')']=right_paren_class;
5337 for (k='A';k<= 'Z';k++ )
5338 mp->char_class[k]=letter_class;
5339 for (k='a';k<='z';k++)
5340 mp->char_class[k]=letter_class;
5341 mp->char_class['_']=letter_class;
5342 mp->char_class['<']=10;
5343 mp->char_class['=']=10;
5344 mp->char_class['>']=10;
5345 mp->char_class[':']=10;
5346 mp->char_class['|']=10;
5347 mp->char_class['`']=11;
5348 mp->char_class['\'']=11;
5349 mp->char_class['+']=12;
5350 mp->char_class['-']=12;
5351 mp->char_class['/']=13;
5352 mp->char_class['*']=13;
5353 mp->char_class['\\']=13;
5354 mp->char_class['!']=14;
5355 mp->char_class['?']=14;
5356 mp->char_class['#']=15;
5357 mp->char_class['&']=15;
5358 mp->char_class['@@']=15;
5359 mp->char_class['$']=15;
5360 mp->char_class['^']=16;
5361 mp->char_class['~']=16;
5362 mp->char_class['[']=left_bracket_class;
5363 mp->char_class[']']=right_bracket_class;
5364 mp->char_class['{']=19;
5365 mp->char_class['}']=19;
5367 mp->char_class[k]=invalid_class;
5368 mp->char_class['\t']=space_class;
5369 mp->char_class['\f']=space_class;
5370 for (k=127;k<=255;k++)
5371 mp->char_class[k]=invalid_class;
5373 @* \[13] The hash table.
5374 Symbolic tokens are stored and retrieved by means of a fairly standard hash
5375 table algorithm called the method of ``coalescing lists'' (cf.\ Algorithm 6.4C
5376 in {\sl The Art of Computer Programming\/}). Once a symbolic token enters the
5377 table, it is never removed.
5379 The actual sequence of characters forming a symbolic token is
5380 stored in the |str_pool| array together with all the other strings. An
5381 auxiliary array |hash| consists of items with two halfword fields per
5382 word. The first of these, called |next(p)|, points to the next identifier
5383 belonging to the same coalesced list as the identifier corresponding to~|p|;
5384 and the other, called |text(p)|, points to the |str_start| entry for
5385 |p|'s identifier. If position~|p| of the hash table is empty, we have
5386 |text(p)=0|; if position |p| is either empty or the end of a coalesced
5387 hash list, we have |next(p)=0|.
5389 An auxiliary pointer variable called |hash_used| is maintained in such a
5390 way that all locations |p>=hash_used| are nonempty. The global variable
5391 |st_count| tells how many symbolic tokens have been defined, if statistics
5394 The first 256 locations of |hash| are reserved for symbols of length one.
5396 There's a parallel array called |eqtb| that contains the current equivalent
5397 values of each symbolic token. The entries of this array consist of
5398 two halfwords called |eq_type| (a command code) and |equiv| (a secondary
5399 piece of information that qualifies the |eq_type|).
5401 @d next(A) mp->hash[(A)].lh /* link for coalesced lists */
5402 @d text(A) mp->hash[(A)].rh /* string number for symbolic token name */
5403 @d eq_type(A) mp->eqtb[(A)].lh /* the current ``meaning'' of a symbolic token */
5404 @d equiv(A) mp->eqtb[(A)].rh /* parametric part of a token's meaning */
5405 @d hash_base 257 /* hashing actually starts here */
5406 @d hash_is_full (mp->hash_used==hash_base) /* are all positions occupied? */
5409 pointer hash_used; /* allocation pointer for |hash| */
5410 integer st_count; /* total number of known identifiers */
5412 @ Certain entries in the hash table are ``frozen'' and not redefinable,
5413 since they are used in error recovery.
5415 @d hash_top (integer)(hash_base+mp->hash_size) /* the first location of the frozen area */
5416 @d frozen_inaccessible hash_top /* |hash| location to protect the frozen area */
5417 @d frozen_repeat_loop (hash_top+1) /* |hash| location of a loop-repeat token */
5418 @d frozen_right_delimiter (hash_top+2) /* |hash| location of a permanent `\.)' */
5419 @d frozen_left_bracket (hash_top+3) /* |hash| location of a permanent `\.[' */
5420 @d frozen_slash (hash_top+4) /* |hash| location of a permanent `\./' */
5421 @d frozen_colon (hash_top+5) /* |hash| location of a permanent `\.:' */
5422 @d frozen_semicolon (hash_top+6) /* |hash| location of a permanent `\.;' */
5423 @d frozen_end_for (hash_top+7) /* |hash| location of a permanent \&{endfor} */
5424 @d frozen_end_def (hash_top+8) /* |hash| location of a permanent \&{enddef} */
5425 @d frozen_fi (hash_top+9) /* |hash| location of a permanent \&{fi} */
5426 @d frozen_end_group (hash_top+10) /* |hash| location of a permanent `\.{endgroup}' */
5427 @d frozen_etex (hash_top+11) /* |hash| location of a permanent \&{etex} */
5428 @d frozen_mpx_break (hash_top+12) /* |hash| location of a permanent \&{mpxbreak} */
5429 @d frozen_bad_vardef (hash_top+13) /* |hash| location of `\.{a bad variable}' */
5430 @d frozen_undefined (hash_top+14) /* |hash| location that never gets defined */
5431 @d hash_end (integer)(hash_top+14) /* the actual size of the |hash| and |eqtb| arrays */
5434 two_halves *hash; /* the hash table */
5435 two_halves *eqtb; /* the equivalents */
5437 @ @<Allocate or initialize ...@>=
5438 mp->hash = xmalloc((hash_end+1),sizeof(two_halves));
5439 mp->eqtb = xmalloc((hash_end+1),sizeof(two_halves));
5441 @ @<Dealloc variables@>=
5446 next(1)=0; text(1)=0; eq_type(1)=tag_token; equiv(1)=null;
5447 for (k=2;k<=hash_end;k++) {
5448 mp->hash[k]=mp->hash[1]; mp->eqtb[k]=mp->eqtb[1];
5451 @ @<Initialize table entries...@>=
5452 mp->hash_used=frozen_inaccessible; /* nothing is used */
5454 text(frozen_bad_vardef)=intern("a bad variable");
5455 text(frozen_etex)=intern("etex");
5456 text(frozen_mpx_break)=intern("mpxbreak");
5457 text(frozen_fi)=intern("fi");
5458 text(frozen_end_group)=intern("endgroup");
5459 text(frozen_end_def)=intern("enddef");
5460 text(frozen_end_for)=intern("endfor");
5461 text(frozen_semicolon)=intern(";");
5462 text(frozen_colon)=intern(":");
5463 text(frozen_slash)=intern("/");
5464 text(frozen_left_bracket)=intern("[");
5465 text(frozen_right_delimiter)=intern(")");
5466 text(frozen_inaccessible)=intern(" INACCESSIBLE");
5467 eq_type(frozen_right_delimiter)=right_delimiter;
5469 @ @<Check the ``constant'' values...@>=
5470 if ( hash_end+mp->max_internal>max_halfword ) mp->bad=17;
5472 @ Here is the subroutine that searches the hash table for an identifier
5473 that matches a given string of length~|l| appearing in |buffer[j..
5474 (j+l-1)]|. If the identifier is not found, it is inserted; hence it
5475 will always be found, and the corresponding hash table address
5479 static pointer mp_id_lookup (MP mp,integer j, integer l) { /* search the hash table */
5480 integer h; /* hash code */
5481 pointer p; /* index in |hash| array */
5482 pointer k; /* index in |buffer| array */
5484 @<Treat special case of length 1 and |break|@>;
5486 @<Compute the hash code |h|@>;
5487 p=h+hash_base; /* we start searching here; note that |0<=h<hash_prime| */
5489 if (text(p)>0 && length(text(p))==l && mp_str_eq_buf(mp, text(p),j))
5492 @<Insert a new symbolic token after |p|, then
5493 make |p| point to it and |break|@>;
5500 @ @<Treat special case of length 1...@>=
5501 p=mp->buffer[j]+1; text(p)=p-1; return p;
5504 @ @<Insert a new symbolic...@>=
5509 mp_overflow(mp, "hash size",(integer)mp->hash_size);
5510 @:MetaPost capacity exceeded hash size}{\quad hash size@>
5511 decr(mp->hash_used);
5512 } while (text(mp->hash_used)!=0); /* search for an empty location in |hash| */
5513 next(p)=mp->hash_used;
5517 for (k=j;k<=j+l-1;k++) {
5518 append_char(mp->buffer[k]);
5520 text(p)=mp_make_string(mp);
5521 mp->str_ref[text(p)]=max_str_ref;
5527 @ The value of |hash_prime| should be roughly 85\pct! of |hash_size|, and it
5528 should be a prime number. The theory of hashing tells us to expect fewer
5529 than two table probes, on the average, when the search is successful.
5530 [See J.~S. Vitter, {\sl Journal of the ACM\/ \bf30} (1983), 231--258.]
5531 @^Vitter, Jeffrey Scott@>
5533 @<Compute the hash code |h|@>=
5535 for (k=j+1;k<=j+l-1;k++){
5536 h=h+h+mp->buffer[k];
5537 while ( h>=mp->hash_prime ) h=h-mp->hash_prime;
5540 @ @<Search |eqtb| for equivalents equal to |p|@>=
5541 for (q=1;q<=hash_end;q++) {
5542 if ( equiv(q)==p ) {
5543 mp_print_nl(mp, "EQUIV(");
5544 mp_print_int(mp, q);
5545 mp_print_char(mp, xord(')'));
5549 @ We need to put \MP's ``primitive'' symbolic tokens into the hash
5550 table, together with their command code (which will be the |eq_type|)
5551 and an operand (which will be the |equiv|). The |primitive| procedure
5552 does this, in a way that no \MP\ user can. The global value |cur_sym|
5553 contains the new |eqtb| pointer after |primitive| has acted.
5556 static void mp_primitive (MP mp, const char *ss, halfword c, halfword o) {
5557 pool_pointer k; /* index into |str_pool| */
5558 quarterword j; /* index into |buffer| */
5559 quarterword l; /* length of the string */
5562 k=mp->str_start[s]; l=str_stop(s)-k;
5563 /* we will move |s| into the (empty) |buffer| */
5564 for (j=0;j<=l-1;j++) {
5565 mp->buffer[j]=mp->str_pool[k+j];
5567 mp->cur_sym=mp_id_lookup(mp, 0,l);
5568 if ( s>=256 ) { /* we don't want to have the string twice */
5569 mp_flush_string(mp, text(mp->cur_sym)); text(mp->cur_sym)=s;
5571 eq_type(mp->cur_sym)=c;
5572 equiv(mp->cur_sym)=o;
5576 @ Many of \MP's primitives need no |equiv|, since they are identifiable
5577 by their |eq_type| alone. These primitives are loaded into the hash table
5580 @<Put each of \MP's primitives into the hash table@>=
5581 mp_primitive(mp, "..",path_join,0);
5582 @:.._}{\.{..} primitive@>
5583 mp_primitive(mp, "[",left_bracket,0); mp->eqtb[frozen_left_bracket]=mp->eqtb[mp->cur_sym];
5584 @:[ }{\.{[} primitive@>
5585 mp_primitive(mp, "]",right_bracket,0);
5586 @:] }{\.{]} primitive@>
5587 mp_primitive(mp, "}",right_brace,0);
5588 @:]]}{\.{\char`\}} primitive@>
5589 mp_primitive(mp, "{",left_brace,0);
5590 @:][}{\.{\char`\{} primitive@>
5591 mp_primitive(mp, ":",colon,0); mp->eqtb[frozen_colon]=mp->eqtb[mp->cur_sym];
5592 @:: }{\.{:} primitive@>
5593 mp_primitive(mp, "::",double_colon,0);
5594 @::: }{\.{::} primitive@>
5595 mp_primitive(mp, "||:",bchar_label,0);
5596 @:::: }{\.{\char'174\char'174:} primitive@>
5597 mp_primitive(mp, ":=",assignment,0);
5598 @::=_}{\.{:=} primitive@>
5599 mp_primitive(mp, ",",comma,0);
5600 @:, }{\., primitive@>
5601 mp_primitive(mp, ";",semicolon,0); mp->eqtb[frozen_semicolon]=mp->eqtb[mp->cur_sym];
5602 @:; }{\.; primitive@>
5603 mp_primitive(mp, "\\",relax,0);
5604 @:]]\\}{\.{\char`\\} primitive@>
5606 mp_primitive(mp, "addto",add_to_command,0);
5607 @:add_to_}{\&{addto} primitive@>
5608 mp_primitive(mp, "atleast",at_least,0);
5609 @:at_least_}{\&{atleast} primitive@>
5610 mp_primitive(mp, "begingroup",begin_group,0); mp->bg_loc=mp->cur_sym;
5611 @:begin_group_}{\&{begingroup} primitive@>
5612 mp_primitive(mp, "controls",controls,0);
5613 @:controls_}{\&{controls} primitive@>
5614 mp_primitive(mp, "curl",curl_command,0);
5615 @:curl_}{\&{curl} primitive@>
5616 mp_primitive(mp, "delimiters",delimiters,0);
5617 @:delimiters_}{\&{delimiters} primitive@>
5618 mp_primitive(mp, "endgroup",end_group,0);
5619 mp->eqtb[frozen_end_group]=mp->eqtb[mp->cur_sym]; mp->eg_loc=mp->cur_sym;
5620 @:endgroup_}{\&{endgroup} primitive@>
5621 mp_primitive(mp, "everyjob",every_job_command,0);
5622 @:every_job_}{\&{everyjob} primitive@>
5623 mp_primitive(mp, "exitif",exit_test,0);
5624 @:exit_if_}{\&{exitif} primitive@>
5625 mp_primitive(mp, "expandafter",expand_after,0);
5626 @:expand_after_}{\&{expandafter} primitive@>
5627 mp_primitive(mp, "interim",interim_command,0);
5628 @:interim_}{\&{interim} primitive@>
5629 mp_primitive(mp, "let",let_command,0);
5630 @:let_}{\&{let} primitive@>
5631 mp_primitive(mp, "newinternal",new_internal,0);
5632 @:new_internal_}{\&{newinternal} primitive@>
5633 mp_primitive(mp, "of",of_token,0);
5634 @:of_}{\&{of} primitive@>
5635 mp_primitive(mp, "randomseed",mp_random_seed,0);
5636 @:mp_random_seed_}{\&{randomseed} primitive@>
5637 mp_primitive(mp, "save",save_command,0);
5638 @:save_}{\&{save} primitive@>
5639 mp_primitive(mp, "scantokens",scan_tokens,0);
5640 @:scan_tokens_}{\&{scantokens} primitive@>
5641 mp_primitive(mp, "shipout",ship_out_command,0);
5642 @:ship_out_}{\&{shipout} primitive@>
5643 mp_primitive(mp, "skipto",skip_to,0);
5644 @:skip_to_}{\&{skipto} primitive@>
5645 mp_primitive(mp, "special",special_command,0);
5646 @:special}{\&{special} primitive@>
5647 mp_primitive(mp, "fontmapfile",special_command,1);
5648 @:fontmapfile}{\&{fontmapfile} primitive@>
5649 mp_primitive(mp, "fontmapline",special_command,2);
5650 @:fontmapline}{\&{fontmapline} primitive@>
5651 mp_primitive(mp, "step",step_token,0);
5652 @:step_}{\&{step} primitive@>
5653 mp_primitive(mp, "str",str_op,0);
5654 @:str_}{\&{str} primitive@>
5655 mp_primitive(mp, "tension",tension,0);
5656 @:tension_}{\&{tension} primitive@>
5657 mp_primitive(mp, "to",to_token,0);
5658 @:to_}{\&{to} primitive@>
5659 mp_primitive(mp, "until",until_token,0);
5660 @:until_}{\&{until} primitive@>
5661 mp_primitive(mp, "within",within_token,0);
5662 @:within_}{\&{within} primitive@>
5663 mp_primitive(mp, "write",write_command,0);
5664 @:write_}{\&{write} primitive@>
5666 @ Each primitive has a corresponding inverse, so that it is possible to
5667 display the cryptic numeric contents of |eqtb| in symbolic form.
5668 Every call of |primitive| in this program is therefore accompanied by some
5669 straightforward code that forms part of the |print_cmd_mod| routine
5672 @<Cases of |print_cmd_mod| for symbolic printing of primitives@>=
5673 case add_to_command:mp_print(mp, "addto"); break;
5674 case assignment:mp_print(mp, ":="); break;
5675 case at_least:mp_print(mp, "atleast"); break;
5676 case bchar_label:mp_print(mp, "||:"); break;
5677 case begin_group:mp_print(mp, "begingroup"); break;
5678 case colon:mp_print(mp, ":"); break;
5679 case comma:mp_print(mp, ","); break;
5680 case controls:mp_print(mp, "controls"); break;
5681 case curl_command:mp_print(mp, "curl"); break;
5682 case delimiters:mp_print(mp, "delimiters"); break;
5683 case double_colon:mp_print(mp, "::"); break;
5684 case end_group:mp_print(mp, "endgroup"); break;
5685 case every_job_command:mp_print(mp, "everyjob"); break;
5686 case exit_test:mp_print(mp, "exitif"); break;
5687 case expand_after:mp_print(mp, "expandafter"); break;
5688 case interim_command:mp_print(mp, "interim"); break;
5689 case left_brace:mp_print(mp, "{"); break;
5690 case left_bracket:mp_print(mp, "["); break;
5691 case let_command:mp_print(mp, "let"); break;
5692 case new_internal:mp_print(mp, "newinternal"); break;
5693 case of_token:mp_print(mp, "of"); break;
5694 case path_join:mp_print(mp, ".."); break;
5695 case mp_random_seed:mp_print(mp, "randomseed"); break;
5696 case relax:mp_print_char(mp, xord('\\')); break;
5697 case right_brace:mp_print_char(mp, xord('}')); break;
5698 case right_bracket:mp_print_char(mp, xord(']')); break;
5699 case save_command:mp_print(mp, "save"); break;
5700 case scan_tokens:mp_print(mp, "scantokens"); break;
5701 case semicolon:mp_print_char(mp, xord(';')); break;
5702 case ship_out_command:mp_print(mp, "shipout"); break;
5703 case skip_to:mp_print(mp, "skipto"); break;
5704 case special_command: if ( m==2 ) mp_print(mp, "fontmapline"); else
5705 if ( m==1 ) mp_print(mp, "fontmapfile"); else
5706 mp_print(mp, "special"); break;
5707 case step_token:mp_print(mp, "step"); break;
5708 case str_op:mp_print(mp, "str"); break;
5709 case tension:mp_print(mp, "tension"); break;
5710 case to_token:mp_print(mp, "to"); break;
5711 case until_token:mp_print(mp, "until"); break;
5712 case within_token:mp_print(mp, "within"); break;
5713 case write_command:mp_print(mp, "write"); break;
5715 @ We will deal with the other primitives later, at some point in the program
5716 where their |eq_type| and |equiv| values are more meaningful. For example,
5717 the primitives for macro definitions will be loaded when we consider the
5718 routines that define macros.
5719 It is easy to find where each particular
5720 primitive was treated by looking in the index at the end; for example, the
5721 section where |"def"| entered |eqtb| is listed under `\&{def} primitive'.
5723 @* \[14] Token lists.
5724 A \MP\ token is either symbolic or numeric or a string, or it denotes
5725 a macro parameter or capsule; so there are five corresponding ways to encode it
5727 internally: (1)~A symbolic token whose hash code is~|p|
5728 is represented by the number |p|, in the |info| field of a single-word
5729 node in~|mem|. (2)~A numeric token whose |scaled| value is~|v| is
5730 represented in a two-word node of~|mem|; the |type| field is |known|,
5731 the |name_type| field is |token|, and the |value| field holds~|v|.
5732 The fact that this token appears in a two-word node rather than a
5733 one-word node is, of course, clear from the node address.
5734 (3)~A string token is also represented in a two-word node; the |type|
5735 field is |mp_string_type|, the |name_type| field is |token|, and the
5736 |value| field holds the corresponding |str_number|. (4)~Capsules have
5737 |name_type=capsule|, and their |type| and |value| fields represent
5738 arbitrary values (in ways to be explained later). (5)~Macro parameters
5739 are like symbolic tokens in that they appear in |info| fields of
5740 one-word nodes. The $k$th parameter is represented by |expr_base+k| if it
5741 is of type \&{expr}, or by |suffix_base+k| if it is of type \&{suffix}, or
5742 by |text_base+k| if it is of type \&{text}. (Here |0<=k<param_size|.)
5743 Actual values of these parameters are kept in a separate stack, as we will
5744 see later. The constants |expr_base|, |suffix_base|, and |text_base| are,
5745 of course, chosen so that there will be no confusion between symbolic
5746 tokens and parameters of various types.
5749 the `\\{type}' field of a node has nothing to do with ``type'' in a
5750 printer's sense. It's curious that the same word is used in such different ways.
5752 @d type(A) mp->mem[(A)].hh.b0 /* identifies what kind of value this is */
5753 @d name_type(A) mp->mem[(A)].hh.b1 /* a clue to the name of this value */
5754 @d token_node_size 2 /* the number of words in a large token node */
5755 @d value_loc(A) ((A)+1) /* the word that contains the |value| field */
5756 @d value(A) mp->mem[value_loc((A))].cint /* the value stored in a large token node */
5757 @d expr_base (hash_end+1) /* code for the zeroth \&{expr} parameter */
5758 @d suffix_base (expr_base+mp->param_size) /* code for the zeroth \&{suffix} parameter */
5759 @d text_base (suffix_base+mp->param_size) /* code for the zeroth \&{text} parameter */
5761 @<Check the ``constant''...@>=
5762 if ( text_base+mp->param_size>max_halfword ) mp->bad=18;
5764 @ We have set aside a two word node beginning at |null| so that we can have
5765 |value(null)=0|. We will make use of this coincidence later.
5767 @<Initialize table entries...@>=
5768 mp_link(null)=null; value(null)=0;
5770 @ A numeric token is created by the following trivial routine.
5773 static pointer mp_new_num_tok (MP mp,scaled v) {
5774 pointer p; /* the new node */
5775 p=mp_get_node(mp, token_node_size); value(p)=v;
5776 type(p)=mp_known; name_type(p)=mp_token;
5780 @ A token list is a singly linked list of nodes in |mem|, where
5781 each node contains a token and a link. Here's a subroutine that gets rid
5782 of a token list when it is no longer needed.
5784 @c static void mp_flush_token_list (MP mp,pointer p) {
5785 pointer q; /* the node being recycled */
5788 if ( q>=mp->hi_mem_min ) {
5792 case mp_vacuous: case mp_boolean_type: case mp_known:
5794 case mp_string_type:
5795 delete_str_ref(value(q));
5797 case unknown_types: case mp_pen_type: case mp_path_type:
5798 case mp_picture_type: case mp_pair_type: case mp_color_type:
5799 case mp_cmykcolor_type: case mp_transform_type: case mp_dependent:
5800 case mp_proto_dependent: case mp_independent:
5801 mp_recycle_value(mp,q);
5803 default: mp_confusion(mp, "token");
5804 @:this can't happen token}{\quad token@>
5806 mp_free_node(mp, q,token_node_size);
5811 @ The procedure |show_token_list|, which prints a symbolic form of
5812 the token list that starts at a given node |p|, illustrates these
5813 conventions. The token list being displayed should not begin with a reference
5814 count. However, the procedure is intended to be fairly robust, so that if the
5815 memory links are awry or if |p| is not really a pointer to a token list,
5816 almost nothing catastrophic can happen.
5818 An additional parameter |q| is also given; this parameter is either null
5819 or it points to a node in the token list where a certain magic computation
5820 takes place that will be explained later. (Basically, |q| is non-null when
5821 we are printing the two-line context information at the time of an error
5822 message; |q| marks the place corresponding to where the second line
5825 The generation will stop, and `\.{\char`\ ETC.}' will be printed, if the length
5826 of printing exceeds a given limit~|l|; the length of printing upon entry is
5827 assumed to be a given amount called |null_tally|. (Note that
5828 |show_token_list| sometimes uses itself recursively to print
5829 variable names within a capsule.)
5832 Unusual entries are printed in the form of all-caps tokens
5833 preceded by a space, e.g., `\.{\char`\ BAD}'.
5836 static void mp_show_token_list (MP mp, integer p, integer q, integer l,
5837 integer null_tally) ;
5840 void mp_show_token_list (MP mp, integer p, integer q, integer l,
5841 integer null_tally) {
5842 quarterword class,c; /* the |char_class| of previous and new tokens */
5843 integer r,v; /* temporary registers */
5844 class=percent_class;
5845 mp->tally=null_tally;
5846 while ( (p!=null) && (mp->tally<l) ) {
5848 @<Do magic computation@>;
5849 @<Display token |p| and set |c| to its class;
5850 but |return| if there are problems@>;
5851 class=c; p=mp_link(p);
5854 mp_print(mp, " ETC.");
5859 @ @<Display token |p| and set |c| to its class...@>=
5860 c=letter_class; /* the default */
5861 if ( (p<0)||(p>mp->mem_end) ) {
5862 mp_print(mp, " CLOBBERED"); return;
5865 if ( p<mp->hi_mem_min ) {
5866 @<Display two-word token@>;
5869 if ( r>=expr_base ) {
5870 @<Display a parameter token@>;
5874 @<Display a collective subscript@>
5876 mp_print(mp, " IMPOSSIBLE");
5881 if ( (r<0)||(r>mp->max_str_ptr) ) {
5882 mp_print(mp, " NONEXISTENT");
5885 @<Print string |r| as a symbolic token
5886 and set |c| to its class@>;
5892 @ @<Display two-word token@>=
5893 if ( name_type(p)==mp_token ) {
5894 if ( type(p)==mp_known ) {
5895 @<Display a numeric token@>;
5896 } else if ( type(p)!=mp_string_type ) {
5897 mp_print(mp, " BAD");
5900 mp_print_char(mp, xord('"')); mp_print_str(mp, value(p)); mp_print_char(mp, xord('"'));
5903 } else if ((name_type(p)!=mp_capsule)||(type(p)<mp_vacuous)||(type(p)>mp_independent) ) {
5904 mp_print(mp, " BAD");
5906 mp_print_capsule(mp,p); c=right_paren_class;
5909 @ @<Display a numeric token@>=
5910 if ( class==digit_class )
5911 mp_print_char(mp, xord(' '));
5914 if ( class==left_bracket_class )
5915 mp_print_char(mp, xord(' '));
5916 mp_print_char(mp, xord('[')); mp_print_scaled(mp, v); mp_print_char(mp, xord(']'));
5917 c=right_bracket_class;
5919 mp_print_scaled(mp, v); c=digit_class;
5923 @ Strictly speaking, a genuine token will never have |info(p)=0|.
5924 But we will see later (in the |print_variable_name| routine) that
5925 it is convenient to let |info(p)=0| stand for `\.{[]}'.
5927 @<Display a collective subscript@>=
5929 if ( class==left_bracket_class )
5930 mp_print_char(mp, xord(' '));
5931 mp_print(mp, "[]"); c=right_bracket_class;
5934 @ @<Display a parameter token@>=
5936 if ( r<suffix_base ) {
5937 mp_print(mp, "(EXPR"); r=r-(expr_base);
5939 } else if ( r<text_base ) {
5940 mp_print(mp, "(SUFFIX"); r=r-(suffix_base);
5943 mp_print(mp, "(TEXT"); r=r-(text_base);
5946 mp_print_int(mp, r); mp_print_char(mp, xord(')')); c=right_paren_class;
5950 @ @<Print string |r| as a symbolic token...@>=
5952 c=mp->char_class[mp->str_pool[mp->str_start[r]]];
5955 case letter_class:mp_print_char(mp, xord('.')); break;
5956 case isolated_classes: break;
5957 default: mp_print_char(mp, xord(' ')); break;
5960 mp_print_str(mp, r);
5964 static void mp_print_capsule (MP mp, pointer p);
5966 @ @<Declare miscellaneous procedures that were declared |forward|@>=
5967 void mp_print_capsule (MP mp, pointer p) {
5968 mp_print_char(mp, xord('(')); mp_print_exp(mp,p,0); mp_print_char(mp, xord(')'));
5971 @ Macro definitions are kept in \MP's memory in the form of token lists
5972 that have a few extra one-word nodes at the beginning.
5974 The first node contains a reference count that is used to tell when the
5975 list is no longer needed. To emphasize the fact that a reference count is
5976 present, we shall refer to the |info| field of this special node as the
5978 @^reference counts@>
5980 The next node or nodes after the reference count serve to describe the
5981 formal parameters. They consist of zero or more parameter tokens followed
5982 by a code for the type of macro.
5985 /* reference count preceding a macro definition or picture header */
5986 @d add_mac_ref(A) incr(ref_count((A))) /* make a new reference to a macro list */
5987 @d general_macro 0 /* preface to a macro defined with a parameter list */
5988 @d primary_macro 1 /* preface to a macro with a \&{primary} parameter */
5989 @d secondary_macro 2 /* preface to a macro with a \&{secondary} parameter */
5990 @d tertiary_macro 3 /* preface to a macro with a \&{tertiary} parameter */
5991 @d expr_macro 4 /* preface to a macro with an undelimited \&{expr} parameter */
5992 @d of_macro 5 /* preface to a macro with
5993 undelimited `\&{expr} |x| \&{of}~|y|' parameters */
5994 @d suffix_macro 6 /* preface to a macro with an undelimited \&{suffix} parameter */
5995 @d text_macro 7 /* preface to a macro with an undelimited \&{text} parameter */
5998 static void mp_delete_mac_ref (MP mp,pointer p) {
5999 /* |p| points to the reference count of a macro list that is
6000 losing one reference */
6001 if ( ref_count(p)==null ) mp_flush_token_list(mp, p);
6002 else decr(ref_count(p));
6005 @ The following subroutine displays a macro, given a pointer to its
6009 static void mp_show_macro (MP mp, pointer p, integer q, integer l) {
6010 pointer r; /* temporary storage */
6011 p=mp_link(p); /* bypass the reference count */
6012 while ( info(p)>text_macro ){
6013 r=mp_link(p); mp_link(p)=null;
6014 mp_show_token_list(mp, p,null,l,0); mp_link(p)=r; p=r;
6015 if ( l>0 ) l=l-mp->tally; else return;
6016 } /* control printing of `\.{ETC.}' */
6020 case general_macro:mp_print(mp, "->"); break;
6022 case primary_macro: case secondary_macro: case tertiary_macro:
6023 mp_print_char(mp, xord('<'));
6024 mp_print_cmd_mod(mp, param_type,info(p));
6025 mp_print(mp, ">->");
6027 case expr_macro:mp_print(mp, "<expr>->"); break;
6028 case of_macro:mp_print(mp, "<expr>of<primary>->"); break;
6029 case suffix_macro:mp_print(mp, "<suffix>->"); break;
6030 case text_macro:mp_print(mp, "<text>->"); break;
6031 } /* there are no other cases */
6032 mp_show_token_list(mp, mp_link(p),q,l-mp->tally,0);
6035 @* \[15] Data structures for variables.
6036 The variables of \MP\ programs can be simple, like `\.x', or they can
6037 combine the structural properties of arrays and records, like `\.{x20a.b}'.
6038 A \MP\ user assigns a type to a variable like \.{x20a.b} by saying, for
6039 example, `\.{boolean} \.{x[]a.b}'. It's time for us to study how such
6040 things are represented inside of the computer.
6042 Each variable value occupies two consecutive words, either in a two-word
6043 node called a value node, or as a two-word subfield of a larger node. One
6044 of those two words is called the |value| field; it is an integer,
6045 containing either a |scaled| numeric value or the representation of some
6046 other type of quantity. (It might also be subdivided into halfwords, in
6047 which case it is referred to by other names instead of |value|.) The other
6048 word is broken into subfields called |type|, |name_type|, and |link|. The
6049 |type| field is a quarterword that specifies the variable's type, and
6050 |name_type| is a quarterword from which \MP\ can reconstruct the
6051 variable's name (sometimes by using the |link| field as well). Thus, only
6052 1.25 words are actually devoted to the value itself; the other
6053 three-quarters of a word are overhead, but they aren't wasted because they
6054 allow \MP\ to deal with sparse arrays and to provide meaningful diagnostics.
6056 In this section we shall be concerned only with the structural aspects of
6057 variables, not their values. Later parts of the program will change the
6058 |type| and |value| fields, but we shall treat those fields as black boxes
6059 whose contents should not be touched.
6061 However, if the |type| field is |mp_structured|, there is no |value| field,
6062 and the second word is broken into two pointer fields called |attr_head|
6063 and |subscr_head|. Those fields point to additional nodes that
6064 contain structural information, as we shall see.
6066 @d subscr_head_loc(A) (A)+1 /* where |value|, |subscr_head| and |attr_head| are */
6067 @d attr_head(A) info(subscr_head_loc((A))) /* pointer to attribute info */
6068 @d subscr_head(A) mp_link(subscr_head_loc((A))) /* pointer to subscript info */
6069 @d value_node_size 2 /* the number of words in a value node */
6071 @ An attribute node is three words long. Two of these words contain |type|
6072 and |value| fields as described above, and the third word contains
6073 additional information: There is an |attr_loc| field, which contains the
6074 hash address of the token that names this attribute; and there's also a
6075 |parent| field, which points to the value node of |mp_structured| type at the
6076 next higher level (i.e., at the level to which this attribute is
6077 subsidiary). The |name_type| in an attribute node is `|attr|'. The
6078 |link| field points to the next attribute with the same parent; these are
6079 arranged in increasing order, so that |attr_loc(mp_link(p))>attr_loc(p)|. The
6080 final attribute node links to the constant |end_attr|, whose |attr_loc|
6081 field is greater than any legal hash address. The |attr_head| in the
6082 parent points to a node whose |name_type| is |mp_structured_root|; this
6083 node represents the null attribute, i.e., the variable that is relevant
6084 when no attributes are attached to the parent. The |attr_head| node
6085 has the fields of either
6086 a value node, a subscript node, or an attribute node, depending on what
6087 the parent would be if it were not structured; but the subscript and
6088 attribute fields are ignored, so it effectively contains only the data of
6089 a value node. The |link| field in this special node points to an attribute
6090 node whose |attr_loc| field is zero; the latter node represents a collective
6091 subscript `\.{[]}' attached to the parent, and its |link| field points to
6092 the first non-special attribute node (or to |end_attr| if there are none).
6094 A subscript node likewise occupies three words, with |type| and |value| fields
6095 plus extra information; its |name_type| is |subscr|. In this case the
6096 third word is called the |subscript| field, which is a |scaled| integer.
6097 The |link| field points to the subscript node with the next larger
6098 subscript, if any; otherwise the |link| points to the attribute node
6099 for collective subscripts at this level. We have seen that the latter node
6100 contains an upward pointer, so that the parent can be deduced.
6102 The |name_type| in a parent-less value node is |root|, and the |link|
6103 is the hash address of the token that names this value.
6105 In other words, variables have a hierarchical structure that includes
6106 enough threads running around so that the program is able to move easily
6107 between siblings, parents, and children. An example should be helpful:
6108 (The reader is advised to draw a picture while reading the following
6109 description, since that will help to firm up the ideas.)
6110 Suppose that `\.x' and `\.{x.a}' and `\.{x[]b}' and `\.{x5}'
6111 and `\.{x20b}' have been mentioned in a user's program, where
6112 \.{x[]b} has been declared to be of \&{boolean} type. Let |h(x)|, |h(a)|,
6113 and |h(b)| be the hash addresses of \.x, \.a, and~\.b. Then
6114 |eq_type(h(x))=name| and |equiv(h(x))=p|, where |p|~is a two-word value
6115 node with |name_type(p)=root| and |mp_link(p)=h(x)|. We have |type(p)=mp_structured|,
6116 |attr_head(p)=q|, and |subscr_head(p)=r|, where |q| points to a value
6117 node and |r| to a subscript node. (Are you still following this? Use
6118 a pencil to draw a diagram.) The lone variable `\.x' is represented by
6119 |type(q)| and |value(q)|; furthermore
6120 |name_type(q)=mp_structured_root| and |mp_link(q)=q1|, where |q1| points
6121 to an attribute node representing `\.{x[]}'. Thus |name_type(q1)=attr|,
6122 |attr_loc(q1)=collective_subscript=0|, |parent(q1)=p|,
6123 |type(q1)=mp_structured|, |attr_head(q1)=qq|, and |subscr_head(q1)=qq1|;
6124 |qq| is a three-word ``attribute-as-value'' node with |type(qq)=numeric_type|
6125 (assuming that \.{x5} is numeric, because |qq| represents `\.{x[]}'
6126 with no further attributes), |name_type(qq)=structured_root|,
6127 |attr_loc(qq)=0|, |parent(qq)=p|, and
6128 |mp_link(qq)=qq1|. (Now pay attention to the next part.) Node |qq1| is
6129 an attribute node representing `\.{x[][]}', which has never yet
6130 occurred; its |type| field is |undefined|, and its |value| field is
6131 undefined. We have |name_type(qq1)=attr|, |attr_loc(qq1)=collective_subscript|,
6132 |parent(qq1)=q1|, and |mp_link(qq1)=qq2|. Since |qq2| represents
6133 `\.{x[]b}', |type(qq2)=mp_unknown_boolean|; also |attr_loc(qq2)=h(b)|,
6134 |parent(qq2)=q1|, |name_type(qq2)=attr|, |mp_link(qq2)=end_attr|.
6135 (Maybe colored lines will help untangle your picture.)
6136 Node |r| is a subscript node with |type| and |value|
6137 representing `\.{x5}'; |name_type(r)=subscr|, |subscript(r)=5.0|,
6138 and |mp_link(r)=r1| is another subscript node. To complete the picture,
6139 see if you can guess what |mp_link(r1)| is; give up? It's~|q1|.
6140 Furthermore |subscript(r1)=20.0|, |name_type(r1)=subscr|,
6141 |type(r1)=mp_structured|, |attr_head(r1)=qqq|, |subscr_head(r1)=qqq1|,
6142 and we finish things off with three more nodes
6143 |qqq|, |qqq1|, and |qqq2| hung onto~|r1|. (Perhaps you should start again
6144 with a larger sheet of paper.) The value of variable \.{x20b}
6145 appears in node~|qqq2|, as you can well imagine.
6147 If the example in the previous paragraph doesn't make things crystal
6148 clear, a glance at some of the simpler subroutines below will reveal how
6149 things work out in practice.
6151 The only really unusual thing about these conventions is the use of
6152 collective subscript attributes. The idea is to avoid repeating a lot of
6153 type information when many elements of an array are identical macros
6154 (for which distinct values need not be stored) or when they don't have
6155 all of the possible attributes. Branches of the structure below collective
6156 subscript attributes do not carry actual values except for macro identifiers;
6157 branches of the structure below subscript nodes do not carry significant
6158 information in their collective subscript attributes.
6160 @d attr_loc_loc(A) ((A)+2) /* where the |attr_loc| and |parent| fields are */
6161 @d attr_loc(A) info(attr_loc_loc((A))) /* hash address of this attribute */
6162 @d parent(A) mp_link(attr_loc_loc((A))) /* pointer to |mp_structured| variable */
6163 @d subscript_loc(A) ((A)+2) /* where the |subscript| field lives */
6164 @d subscript(A) mp->mem[subscript_loc((A))].sc /* subscript of this variable */
6165 @d attr_node_size 3 /* the number of words in an attribute node */
6166 @d subscr_node_size 3 /* the number of words in a subscript node */
6167 @d collective_subscript 0 /* code for the attribute `\.{[]}' */
6169 @<Initialize table...@>=
6170 attr_loc(end_attr)=hash_end+1; parent(end_attr)=null;
6172 @ Variables of type \&{pair} will have values that point to four-word
6173 nodes containing two numeric values. The first of these values has
6174 |name_type=mp_x_part_sector| and the second has |name_type=mp_y_part_sector|;
6175 the |link| in the first points back to the node whose |value| points
6176 to this four-word node.
6178 Variables of type \&{transform} are similar, but in this case their
6179 |value| points to a 12-word node containing six values, identified by
6180 |x_part_sector|, |y_part_sector|, |mp_xx_part_sector|, |mp_xy_part_sector|,
6181 |mp_yx_part_sector|, and |mp_yy_part_sector|.
6182 Finally, variables of type \&{color} have 3~values in 6~words
6183 identified by |mp_red_part_sector|, |mp_green_part_sector|, and |mp_blue_part_sector|.
6185 When an entire structured variable is saved, the |root| indication
6186 is temporarily replaced by |saved_root|.
6188 Some variables have no name; they just are used for temporary storage
6189 while expressions are being evaluated. We call them {\sl capsules}.
6191 @d x_part_loc(A) (A) /* where the \&{xpart} is found in a pair or transform node */
6192 @d y_part_loc(A) ((A)+2) /* where the \&{ypart} is found in a pair or transform node */
6193 @d xx_part_loc(A) ((A)+4) /* where the \&{xxpart} is found in a transform node */
6194 @d xy_part_loc(A) ((A)+6) /* where the \&{xypart} is found in a transform node */
6195 @d yx_part_loc(A) ((A)+8) /* where the \&{yxpart} is found in a transform node */
6196 @d yy_part_loc(A) ((A)+10) /* where the \&{yypart} is found in a transform node */
6197 @d red_part_loc(A) (A) /* where the \&{redpart} is found in a color node */
6198 @d green_part_loc(A) ((A)+2) /* where the \&{greenpart} is found in a color node */
6199 @d blue_part_loc(A) ((A)+4) /* where the \&{bluepart} is found in a color node */
6200 @d cyan_part_loc(A) (A) /* where the \&{cyanpart} is found in a color node */
6201 @d magenta_part_loc(A) ((A)+2) /* where the \&{magentapart} is found in a color node */
6202 @d yellow_part_loc(A) ((A)+4) /* where the \&{yellowpart} is found in a color node */
6203 @d black_part_loc(A) ((A)+6) /* where the \&{blackpart} is found in a color node */
6204 @d grey_part_loc(A) (A) /* where the \&{greypart} is found in a color node */
6206 @d pair_node_size 4 /* the number of words in a pair node */
6207 @d transform_node_size 12 /* the number of words in a transform node */
6208 @d color_node_size 6 /* the number of words in a color node */
6209 @d cmykcolor_node_size 8 /* the number of words in a color node */
6212 quarterword big_node_size[mp_pair_type+1];
6213 quarterword sector0[mp_pair_type+1];
6214 quarterword sector_offset[mp_black_part_sector+1];
6216 @ The |sector0| array gives for each big node type, |name_type| values
6217 for its first subfield; the |sector_offset| array gives for each
6218 |name_type| value, the offset from the first subfield in words;
6219 and the |big_node_size| array gives the size in words for each type of
6223 mp->big_node_size[mp_transform_type]=transform_node_size;
6224 mp->big_node_size[mp_pair_type]=pair_node_size;
6225 mp->big_node_size[mp_color_type]=color_node_size;
6226 mp->big_node_size[mp_cmykcolor_type]=cmykcolor_node_size;
6227 mp->sector0[mp_transform_type]=mp_x_part_sector;
6228 mp->sector0[mp_pair_type]=mp_x_part_sector;
6229 mp->sector0[mp_color_type]=mp_red_part_sector;
6230 mp->sector0[mp_cmykcolor_type]=mp_cyan_part_sector;
6231 for (k=mp_x_part_sector;k<= mp_yy_part_sector;k++ ) {
6232 mp->sector_offset[k]=2*(k-mp_x_part_sector);
6234 for (k=mp_red_part_sector;k<= mp_blue_part_sector ; k++) {
6235 mp->sector_offset[k]=2*(k-mp_red_part_sector);
6237 for (k=mp_cyan_part_sector;k<= mp_black_part_sector;k++ ) {
6238 mp->sector_offset[k]=2*(k-mp_cyan_part_sector);
6241 @ If |type(p)=mp_pair_type| or |mp_transform_type| and if |value(p)=null|, the
6242 procedure call |init_big_node(p)| will allocate a pair or transform node
6243 for~|p|. The individual parts of such nodes are initially of type
6247 static void mp_init_big_node (MP mp,pointer p) {
6248 pointer q; /* the new node */
6249 quarterword s; /* its size */
6250 s=mp->big_node_size[type(p)]; q=mp_get_node(mp, s);
6253 @<Make variable |q+s| newly independent@>;
6254 name_type(q+s)=halfp(s)+mp->sector0[type(p)];
6257 mp_link(q)=p; value(p)=q;
6260 @ The |id_transform| function creates a capsule for the
6261 identity transformation.
6264 static pointer mp_id_transform (MP mp) {
6265 pointer p,q,r; /* list manipulation registers */
6266 p=mp_get_node(mp, value_node_size); type(p)=mp_transform_type;
6267 name_type(p)=mp_capsule; value(p)=null; mp_init_big_node(mp, p); q=value(p);
6268 r=q+transform_node_size;
6271 type(r)=mp_known; value(r)=0;
6273 value(xx_part_loc(q))=unity;
6274 value(yy_part_loc(q))=unity;
6278 @ Tokens are of type |tag_token| when they first appear, but they point
6279 to |null| until they are first used as the root of a variable.
6280 The following subroutine establishes the root node on such grand occasions.
6283 static void mp_new_root (MP mp,pointer x) {
6284 pointer p; /* the new node */
6285 p=mp_get_node(mp, value_node_size); type(p)=undefined; name_type(p)=mp_root;
6286 mp_link(p)=x; equiv(x)=p;
6289 @ These conventions for variable representation are illustrated by the
6290 |print_variable_name| routine, which displays the full name of a
6291 variable given only a pointer to its two-word value packet.
6294 static void mp_print_variable_name (MP mp, pointer p);
6297 void mp_print_variable_name (MP mp, pointer p) {
6298 pointer q; /* a token list that will name the variable's suffix */
6299 pointer r; /* temporary for token list creation */
6300 while ( name_type(p)>=mp_x_part_sector ) {
6301 @<Preface the output with a part specifier; |return| in the
6302 case of a capsule@>;
6305 while ( name_type(p)>mp_saved_root ) {
6306 @<Ascend one level, pushing a token onto list |q|
6307 and replacing |p| by its parent@>;
6309 r=mp_get_avail(mp); info(r)=mp_link(p); mp_link(r)=q;
6310 if ( name_type(p)==mp_saved_root ) mp_print(mp, "(SAVED)");
6312 mp_show_token_list(mp, r,null,el_gordo,mp->tally);
6313 mp_flush_token_list(mp, r);
6316 @ @<Ascend one level, pushing a token onto list |q|...@>=
6318 if ( name_type(p)==mp_subscr ) {
6319 r=mp_new_num_tok(mp, subscript(p));
6322 } while (name_type(p)!=mp_attr);
6323 } else if ( name_type(p)==mp_structured_root ) {
6324 p=mp_link(p); goto FOUND;
6326 if ( name_type(p)!=mp_attr ) mp_confusion(mp, "var");
6327 @:this can't happen var}{\quad var@>
6328 r=mp_get_avail(mp); info(r)=attr_loc(p);
6335 @ @<Preface the output with a part specifier...@>=
6336 { switch (name_type(p)) {
6337 case mp_x_part_sector: mp_print_char(mp, xord('x')); break;
6338 case mp_y_part_sector: mp_print_char(mp, xord('y')); break;
6339 case mp_xx_part_sector: mp_print(mp, "xx"); break;
6340 case mp_xy_part_sector: mp_print(mp, "xy"); break;
6341 case mp_yx_part_sector: mp_print(mp, "yx"); break;
6342 case mp_yy_part_sector: mp_print(mp, "yy"); break;
6343 case mp_red_part_sector: mp_print(mp, "red"); break;
6344 case mp_green_part_sector: mp_print(mp, "green"); break;
6345 case mp_blue_part_sector: mp_print(mp, "blue"); break;
6346 case mp_cyan_part_sector: mp_print(mp, "cyan"); break;
6347 case mp_magenta_part_sector: mp_print(mp, "magenta"); break;
6348 case mp_yellow_part_sector: mp_print(mp, "yellow"); break;
6349 case mp_black_part_sector: mp_print(mp, "black"); break;
6350 case mp_grey_part_sector: mp_print(mp, "grey"); break;
6352 mp_print(mp, "%CAPSULE"); mp_print_int(mp, p-null); return;
6355 } /* there are no other cases */
6356 mp_print(mp, "part ");
6357 p=mp_link(p-mp->sector_offset[name_type(p)]);
6360 @ The |interesting| function returns |true| if a given variable is not
6361 in a capsule, or if the user wants to trace capsules.
6364 static boolean mp_interesting (MP mp,pointer p) {
6365 quarterword t; /* a |name_type| */
6366 if ( mp->internal[mp_tracing_capsules]>0 ) {
6370 if ( t>=mp_x_part_sector ) if ( t!=mp_capsule )
6371 t=name_type(mp_link(p-mp->sector_offset[t]));
6372 return (t!=mp_capsule);
6376 @ Now here is a subroutine that converts an unstructured type into an
6377 equivalent structured type, by inserting a |mp_structured| node that is
6378 capable of growing. This operation is done only when |name_type(p)=root|,
6379 |subscr|, or |attr|.
6381 The procedure returns a pointer to the new node that has taken node~|p|'s
6382 place in the structure. Node~|p| itself does not move, nor are its
6383 |value| or |type| fields changed in any way.
6386 static pointer mp_new_structure (MP mp,pointer p) {
6387 pointer q,r=0; /* list manipulation registers */
6388 switch (name_type(p)) {
6390 q=mp_link(p); r=mp_get_node(mp, value_node_size); equiv(q)=r;
6393 @<Link a new subscript node |r| in place of node |p|@>;
6396 @<Link a new attribute node |r| in place of node |p|@>;
6399 mp_confusion(mp, "struct");
6400 @:this can't happen struct}{\quad struct@>
6403 mp_link(r)=mp_link(p); type(r)=mp_structured; name_type(r)=name_type(p);
6404 attr_head(r)=p; name_type(p)=mp_structured_root;
6405 q=mp_get_node(mp, attr_node_size); mp_link(p)=q; subscr_head(r)=q;
6406 parent(q)=r; type(q)=undefined; name_type(q)=mp_attr; mp_link(q)=end_attr;
6407 attr_loc(q)=collective_subscript;
6411 @ @<Link a new subscript node |r| in place of node |p|@>=
6416 } while (name_type(q)!=mp_attr);
6417 q=parent(q); r=subscr_head_loc(q); /* |mp_link(r)=subscr_head(q)| */
6421 r=mp_get_node(mp, subscr_node_size);
6422 mp_link(q)=r; subscript(r)=subscript(p);
6425 @ If the attribute is |collective_subscript|, there are two pointers to
6426 node~|p|, so we must change both of them.
6428 @<Link a new attribute node |r| in place of node |p|@>=
6430 q=parent(p); r=attr_head(q);
6434 r=mp_get_node(mp, attr_node_size); mp_link(q)=r;
6435 mp->mem[attr_loc_loc(r)]=mp->mem[attr_loc_loc(p)]; /* copy |attr_loc| and |parent| */
6436 if ( attr_loc(p)==collective_subscript ) {
6437 q=subscr_head_loc(parent(p));
6438 while ( mp_link(q)!=p ) q=mp_link(q);
6443 @ The |find_variable| routine is given a pointer~|t| to a nonempty token
6444 list of suffixes; it returns a pointer to the corresponding two-word
6445 value. For example, if |t| points to token \.x followed by a numeric
6446 token containing the value~7, |find_variable| finds where the value of
6447 \.{x7} is stored in memory. This may seem a simple task, and it
6448 usually is, except when \.{x7} has never been referenced before.
6449 Indeed, \.x may never have even been subscripted before; complexities
6450 arise with respect to updating the collective subscript information.
6452 If a macro type is detected anywhere along path~|t|, or if the first
6453 item on |t| isn't a |tag_token|, the value |null| is returned.
6454 Otherwise |p| will be a non-null pointer to a node such that
6455 |undefined<type(p)<mp_structured|.
6457 @d abort_find { return null; }
6460 static pointer mp_find_variable (MP mp,pointer t) {
6461 pointer p,q,r,s; /* nodes in the ``value'' line */
6462 pointer pp,qq,rr,ss; /* nodes in the ``collective'' line */
6463 integer n; /* subscript or attribute */
6464 memory_word save_word; /* temporary storage for a word of |mem| */
6466 p=info(t); t=mp_link(t);
6467 if ( (eq_type(p) % outer_tag) != tag_token ) abort_find;
6468 if ( equiv(p)==null ) mp_new_root(mp, p);
6471 @<Make sure that both nodes |p| and |pp| are of |mp_structured| type@>;
6472 if ( t<mp->hi_mem_min ) {
6473 @<Descend one level for the subscript |value(t)|@>
6475 @<Descend one level for the attribute |info(t)|@>;
6479 if ( type(pp)>=mp_structured ) {
6480 if ( type(pp)==mp_structured ) pp=attr_head(pp); else abort_find;
6482 if ( type(p)==mp_structured ) p=attr_head(p);
6483 if ( type(p)==undefined ) {
6484 if ( type(pp)==undefined ) { type(pp)=mp_numeric_type; value(pp)=null; };
6485 type(p)=type(pp); value(p)=null;
6490 @ Although |pp| and |p| begin together, they diverge when a subscript occurs;
6491 |pp|~stays in the collective line while |p|~goes through actual subscript
6494 @<Make sure that both nodes |p| and |pp|...@>=
6495 if ( type(pp)!=mp_structured ) {
6496 if ( type(pp)>mp_structured ) abort_find;
6497 ss=mp_new_structure(mp, pp);
6500 }; /* now |type(pp)=mp_structured| */
6501 if ( type(p)!=mp_structured ) /* it cannot be |>mp_structured| */
6502 p=mp_new_structure(mp, p) /* now |type(p)=mp_structured| */
6504 @ We want this part of the program to be reasonably fast, in case there are
6506 lots of subscripts at the same level of the data structure. Therefore
6507 we store an ``infinite'' value in the word that appears at the end of the
6508 subscript list, even though that word isn't part of a subscript node.
6510 @<Descend one level for the subscript |value(t)|@>=
6513 pp=mp_link(attr_head(pp)); /* now |attr_loc(pp)=collective_subscript| */
6514 q=mp_link(attr_head(p)); save_word=mp->mem[subscript_loc(q)];
6515 subscript(q)=el_gordo; s=subscr_head_loc(p); /* |mp_link(s)=subscr_head(p)| */
6518 } while (n>subscript(s));
6519 if ( n==subscript(s) ) {
6522 p=mp_get_node(mp, subscr_node_size); mp_link(r)=p; mp_link(p)=s;
6523 subscript(p)=n; name_type(p)=mp_subscr; type(p)=undefined;
6525 mp->mem[subscript_loc(q)]=save_word;
6528 @ @<Descend one level for the attribute |info(t)|@>=
6533 rr=ss; ss=mp_link(ss);
6534 } while (n>attr_loc(ss));
6535 if ( n<attr_loc(ss) ) {
6536 qq=mp_get_node(mp, attr_node_size); mp_link(rr)=qq; mp_link(qq)=ss;
6537 attr_loc(qq)=n; name_type(qq)=mp_attr; type(qq)=undefined;
6538 parent(qq)=pp; ss=qq;
6543 pp=ss; s=attr_head(p);
6546 } while (n>attr_loc(s));
6547 if ( n==attr_loc(s) ) {
6550 q=mp_get_node(mp, attr_node_size); mp_link(r)=q; mp_link(q)=s;
6551 attr_loc(q)=n; name_type(q)=mp_attr; type(q)=undefined;
6557 @ Variables lose their former values when they appear in a type declaration,
6558 or when they are defined to be macros or \&{let} equal to something else.
6559 A subroutine will be defined later that recycles the storage associated
6560 with any particular |type| or |value|; our goal now is to study a higher
6561 level process called |flush_variable|, which selectively frees parts of a
6564 This routine has some complexity because of examples such as
6565 `\hbox{\tt numeric x[]a[]b}'
6566 which recycles all variables of the form \.{x[i]a[j]b} (and no others), while
6567 `\hbox{\tt vardef x[]a[]=...}'
6568 discards all variables of the form \.{x[i]a[j]} followed by an arbitrary
6569 suffix, except for the collective node \.{x[]a[]} itself. The obvious way
6570 to handle such examples is to use recursion; so that's what we~do.
6573 Parameter |p| points to the root information of the variable;
6574 parameter |t| points to a list of one-word nodes that represent
6575 suffixes, with |info=collective_subscript| for subscripts.
6578 static void mp_flush_cur_exp (MP mp,scaled v) ;
6581 static void mp_flush_variable (MP mp,pointer p, pointer t, boolean discard_suffixes) {
6582 pointer q,r; /* list manipulation */
6583 halfword n; /* attribute to match */
6585 if ( type(p)!=mp_structured ) return;
6586 n=info(t); t=mp_link(t);
6587 if ( n==collective_subscript ) {
6588 r=subscr_head_loc(p); q=mp_link(r); /* |q=subscr_head(p)| */
6589 while ( name_type(q)==mp_subscr ){
6590 mp_flush_variable(mp, q,t,discard_suffixes);
6592 if ( type(q)==mp_structured ) r=q;
6593 else { mp_link(r)=mp_link(q); mp_free_node(mp, q,subscr_node_size); }
6603 } while (attr_loc(p)<n);
6604 if ( attr_loc(p)!=n ) return;
6606 if ( discard_suffixes ) {
6607 mp_flush_below_variable(mp, p);
6609 if ( type(p)==mp_structured ) p=attr_head(p);
6610 mp_recycle_value(mp, p);
6614 @ The next procedure is simpler; it wipes out everything but |p| itself,
6615 which becomes undefined.
6618 static void mp_flush_below_variable (MP mp, pointer p);
6621 void mp_flush_below_variable (MP mp,pointer p) {
6622 pointer q,r; /* list manipulation registers */
6623 if ( type(p)!=mp_structured ) {
6624 mp_recycle_value(mp, p); /* this sets |type(p)=undefined| */
6627 while ( name_type(q)==mp_subscr ) {
6628 mp_flush_below_variable(mp, q); r=q; q=mp_link(q);
6629 mp_free_node(mp, r,subscr_node_size);
6631 r=attr_head(p); q=mp_link(r); mp_recycle_value(mp, r);
6632 if ( name_type(p)<=mp_saved_root ) mp_free_node(mp, r,value_node_size);
6633 else mp_free_node(mp, r,subscr_node_size);
6634 /* we assume that |subscr_node_size=attr_node_size| */
6636 mp_flush_below_variable(mp, q); r=q; q=mp_link(q); mp_free_node(mp, r,attr_node_size);
6637 } while (q!=end_attr);
6642 @ Just before assigning a new value to a variable, we will recycle the
6643 old value and make the old value undefined. The |und_type| routine
6644 determines what type of undefined value should be given, based on
6645 the current type before recycling.
6648 static quarterword mp_und_type (MP mp,pointer p) {
6650 case undefined: case mp_vacuous:
6652 case mp_boolean_type: case mp_unknown_boolean:
6653 return mp_unknown_boolean;
6654 case mp_string_type: case mp_unknown_string:
6655 return mp_unknown_string;
6656 case mp_pen_type: case mp_unknown_pen:
6657 return mp_unknown_pen;
6658 case mp_path_type: case mp_unknown_path:
6659 return mp_unknown_path;
6660 case mp_picture_type: case mp_unknown_picture:
6661 return mp_unknown_picture;
6662 case mp_transform_type: case mp_color_type: case mp_cmykcolor_type:
6663 case mp_pair_type: case mp_numeric_type:
6665 case mp_known: case mp_dependent: case mp_proto_dependent: case mp_independent:
6666 return mp_numeric_type;
6667 } /* there are no other cases */
6671 @ The |clear_symbol| routine is used when we want to redefine the equivalent
6672 of a symbolic token. It must remove any variable structure or macro
6673 definition that is currently attached to that symbol. If the |saving|
6674 parameter is true, a subsidiary structure is saved instead of destroyed.
6677 static void mp_clear_symbol (MP mp,pointer p, boolean saving) {
6678 pointer q; /* |equiv(p)| */
6680 switch (eq_type(p) % outer_tag) {
6682 case secondary_primary_macro:
6683 case tertiary_secondary_macro:
6684 case expression_tertiary_macro:
6685 if ( ! saving ) mp_delete_mac_ref(mp, q);
6690 name_type(q)=mp_saved_root;
6692 mp_flush_below_variable(mp, q);
6693 mp_free_node(mp,q,value_node_size);
6700 mp->eqtb[p]=mp->eqtb[frozen_undefined];
6703 @* \[16] Saving and restoring equivalents.
6704 The nested structure given by \&{begingroup} and \&{endgroup}
6705 allows |eqtb| entries to be saved and restored, so that temporary changes
6706 can be made without difficulty. When the user requests a current value to
6707 be saved, \MP\ puts that value into its ``save stack.'' An appearance of
6708 \&{endgroup} ultimately causes the old values to be removed from the save
6709 stack and put back in their former places.
6711 The save stack is a linked list containing three kinds of entries,
6712 distinguished by their |info| fields. If |p| points to a saved item,
6716 |info(p)=0| stands for a group boundary; each \&{begingroup} contributes
6717 such an item to the save stack and each \&{endgroup} cuts back the stack
6718 until the most recent such entry has been removed.
6721 |info(p)=q|, where |1<=q<=hash_end|, means that |mem[p+1]| holds the former
6722 contents of |eqtb[q]|. Such save stack entries are generated by \&{save}
6726 |info(p)=hash_end+q|, where |q>0|, means that |value(p)| is a |scaled|
6727 integer to be restored to internal parameter number~|q|. Such entries
6728 are generated by \&{interim} commands.
6731 The global variable |save_ptr| points to the top item on the save stack.
6733 @d save_node_size 2 /* number of words per non-boundary save-stack node */
6734 @d saved_equiv(A) mp->mem[(A)+1].hh /* where an |eqtb| entry gets saved */
6735 @d save_boundary_item(A) { (A)=mp_get_avail(mp); info((A))=0;
6736 mp_link((A))=mp->save_ptr; mp->save_ptr=(A);
6740 pointer save_ptr; /* the most recently saved item */
6742 @ @<Set init...@>=mp->save_ptr=null;
6744 @ The |save_variable| routine is given a hash address |q|; it salts this
6745 address in the save stack, together with its current equivalent,
6746 then makes token~|q| behave as though it were brand new.
6748 Nothing is stacked when |save_ptr=null|, however; there's no way to remove
6749 things from the stack when the program is not inside a group, so there's
6750 no point in wasting the space.
6753 static void mp_save_variable (MP mp,pointer q) {
6754 pointer p; /* temporary register */
6755 if ( mp->save_ptr!=null ){
6756 p=mp_get_node(mp, save_node_size); info(p)=q; mp_link(p)=mp->save_ptr;
6757 saved_equiv(p)=mp->eqtb[q]; mp->save_ptr=p;
6759 mp_clear_symbol(mp, q,(mp->save_ptr!=null));
6762 @ Similarly, |save_internal| is given the location |q| of an internal
6763 quantity like |mp_tracing_pens|. It creates a save stack entry of the
6767 static void mp_save_internal (MP mp,halfword q) {
6768 pointer p; /* new item for the save stack */
6769 if ( mp->save_ptr!=null ){
6770 p=mp_get_node(mp, save_node_size); info(p)=hash_end+q;
6771 mp_link(p)=mp->save_ptr; value(p)=mp->internal[q]; mp->save_ptr=p;
6775 @ At the end of a group, the |unsave| routine restores all of the saved
6776 equivalents in reverse order. This routine will be called only when there
6777 is at least one boundary item on the save stack.
6780 static void mp_unsave (MP mp) {
6781 pointer q; /* index to saved item */
6782 pointer p; /* temporary register */
6783 while ( info(mp->save_ptr)!=0 ) {
6784 q=info(mp->save_ptr);
6786 if ( mp->internal[mp_tracing_restores]>0 ) {
6787 mp_begin_diagnostic(mp); mp_print_nl(mp, "{restoring ");
6788 mp_print(mp, mp->int_name[q-(hash_end)]); mp_print_char(mp, xord('='));
6789 mp_print_scaled(mp, value(mp->save_ptr)); mp_print_char(mp, xord('}'));
6790 mp_end_diagnostic(mp, false);
6792 mp->internal[q-(hash_end)]=value(mp->save_ptr);
6794 if ( mp->internal[mp_tracing_restores]>0 ) {
6795 mp_begin_diagnostic(mp); mp_print_nl(mp, "{restoring ");
6796 mp_print_text(q); mp_print_char(mp, xord('}'));
6797 mp_end_diagnostic(mp, false);
6799 mp_clear_symbol(mp, q,false);
6800 mp->eqtb[q]=saved_equiv(mp->save_ptr);
6801 if ( eq_type(q) % outer_tag==tag_token ) {
6803 if ( p!=null ) name_type(p)=mp_root;
6806 p=mp_link(mp->save_ptr);
6807 mp_free_node(mp, mp->save_ptr,save_node_size); mp->save_ptr=p;
6809 p=mp_link(mp->save_ptr); free_avail(mp->save_ptr); mp->save_ptr=p;
6812 @* \[17] Data structures for paths.
6813 When a \MP\ user specifies a path, \MP\ will create a list of knots
6814 and control points for the associated cubic spline curves. If the
6815 knots are $z_0$, $z_1$, \dots, $z_n$, there are control points
6816 $z_k^+$ and $z_{k+1}^-$ such that the cubic splines between knots
6817 $z_k$ and $z_{k+1}$ are defined by B\'ezier's formula
6818 @:Bezier}{B\'ezier, Pierre Etienne@>
6819 $$\eqalign{z(t)&=B(z_k,z_k^+,z_{k+1}^-,z_{k+1};t)\cr
6820 &=(1-t)^3z_k+3(1-t)^2tz_k^++3(1-t)t^2z_{k+1}^-+t^3z_{k+1}\cr}$$
6823 There is a 8-word node for each knot $z_k$, containing one word of
6824 control information and six words for the |x| and |y| coordinates of
6825 $z_k^-$ and $z_k$ and~$z_k^+$. The control information appears in the
6826 |left_type| and |right_type| fields, which each occupy a quarter of
6827 the first word in the node; they specify properties of the curve as it
6828 enters and leaves the knot. There's also a halfword |link| field,
6829 which points to the following knot, and a final supplementary word (of
6830 which only a quarter is used).
6832 If the path is a closed contour, knots 0 and |n| are identical;
6833 i.e., the |link| in knot |n-1| points to knot~0. But if the path
6834 is not closed, the |left_type| of knot~0 and the |right_type| of knot~|n|
6835 are equal to |endpoint|. In the latter case the |link| in knot~|n| points
6836 to knot~0, and the control points $z_0^-$ and $z_n^+$ are not used.
6838 @d left_type(A) mp->mem[(A)].hh.b0 /* characterizes the path entering this knot */
6839 @d right_type(A) mp->mem[(A)].hh.b1 /* characterizes the path leaving this knot */
6840 @d x_coord(A) mp->mem[(A)+1].sc /* the |x| coordinate of this knot */
6841 @d y_coord(A) mp->mem[(A)+2].sc /* the |y| coordinate of this knot */
6842 @d left_x(A) mp->mem[(A)+3].sc /* the |x| coordinate of previous control point */
6843 @d left_y(A) mp->mem[(A)+4].sc /* the |y| coordinate of previous control point */
6844 @d right_x(A) mp->mem[(A)+5].sc /* the |x| coordinate of next control point */
6845 @d right_y(A) mp->mem[(A)+6].sc /* the |y| coordinate of next control point */
6846 @d x_loc(A) ((A)+1) /* where the |x| coordinate is stored in a knot */
6847 @d y_loc(A) ((A)+2) /* where the |y| coordinate is stored in a knot */
6848 @d knot_coord(A) mp->mem[(A)].sc /* |x| or |y| coordinate given |x_loc| or |y_loc| */
6849 @d left_coord(A) mp->mem[(A)+2].sc
6850 /* coordinate of previous control point given |x_loc| or |y_loc| */
6851 @d right_coord(A) mp->mem[(A)+4].sc
6852 /* coordinate of next control point given |x_loc| or |y_loc| */
6853 @d knot_node_size 8 /* number of words in a knot node */
6857 mp_endpoint=0, /* |left_type| at path beginning and |right_type| at path end */
6858 mp_explicit, /* |left_type| or |right_type| when control points are known */
6859 mp_given, /* |left_type| or |right_type| when a direction is given */
6860 mp_curl, /* |left_type| or |right_type| when a curl is desired */
6861 mp_open, /* |left_type| or |right_type| when \MP\ should choose the direction */
6865 @ Before the B\'ezier control points have been calculated, the memory
6866 space they will ultimately occupy is taken up by information that can be
6867 used to compute them. There are four cases:
6870 \textindent{$\bullet$} If |right_type=mp_open|, the curve should leave
6871 the knot in the same direction it entered; \MP\ will figure out a
6875 \textindent{$\bullet$} If |right_type=mp_curl|, the curve should leave the
6876 knot in a direction depending on the angle at which it enters the next
6877 knot and on the curl parameter stored in |right_curl|.
6880 \textindent{$\bullet$} If |right_type=mp_given|, the curve should leave the
6881 knot in a nonzero direction stored as an |angle| in |right_given|.
6884 \textindent{$\bullet$} If |right_type=mp_explicit|, the B\'ezier control
6885 point for leaving this knot has already been computed; it is in the
6886 |right_x| and |right_y| fields.
6889 The rules for |left_type| are similar, but they refer to the curve entering
6890 the knot, and to \\{left} fields instead of \\{right} fields.
6892 Non-|explicit| control points will be chosen based on ``tension'' parameters
6893 in the |left_tension| and |right_tension| fields. The
6894 `\&{atleast}' option is represented by negative tension values.
6895 @:at_least_}{\&{atleast} primitive@>
6897 For example, the \MP\ path specification
6898 $$\.{z0..z1..tension atleast 1..\{curl 2\}z2..z3\{-1,-2\}..tension
6900 where \.p is the path `\.{z4..controls z45 and z54..z5}', will be represented
6902 \def\lodash{\hbox to 1.1em{\thinspace\hrulefill\thinspace}}
6903 $$\vbox{\halign{#\hfil&&\qquad#\hfil\cr
6904 |left_type|&\\{left} info&|x_coord,y_coord|&|right_type|&\\{right} info\cr
6906 |endpoint|&\lodash$,\,$\lodash&$x_0,y_0$&|curl|&$1.0,1.0$\cr
6907 |open|&\lodash$,1.0$&$x_1,y_1$&|open|&\lodash$,-1.0$\cr
6908 |curl|&$2.0,-1.0$&$x_2,y_2$&|curl|&$2.0,1.0$\cr
6909 |given|&$d,1.0$&$x_3,y_3$&|given|&$d,3.0$\cr
6910 |open|&\lodash$,4.0$&$x_4,y_4$&|explicit|&$x_{45},y_{45}$\cr
6911 |explicit|&$x_{54},y_{54}$&$x_5,y_5$&|endpoint|&\lodash$,\,$\lodash\cr}}$$
6912 Here |d| is the |angle| obtained by calling |n_arg(-unity,-two)|.
6913 Of course, this example is more complicated than anything a normal user
6916 These types must satisfy certain restrictions because of the form of \MP's
6918 (i)~|open| type never appears in the same node together with |endpoint|,
6920 (ii)~The |right_type| of a node is |explicit| if and only if the
6921 |left_type| of the following node is |explicit|.
6922 (iii)~|endpoint| types occur only at the ends, as mentioned above.
6924 @d left_curl left_x /* curl information when entering this knot */
6925 @d left_given left_x /* given direction when entering this knot */
6926 @d left_tension left_y /* tension information when entering this knot */
6927 @d right_curl right_x /* curl information when leaving this knot */
6928 @d right_given right_x /* given direction when leaving this knot */
6929 @d right_tension right_y /* tension information when leaving this knot */
6931 @ Knots can be user-supplied, or they can be created by program code,
6932 like the |split_cubic| function, or |copy_path|. The distinction is
6933 needed for the cleanup routine that runs after |split_cubic|, because
6934 it should only delete knots it has previously inserted, and never
6935 anything that was user-supplied. In order to be able to differentiate
6936 one knot from another, we will set |originator(p):=mp_metapost_user| when
6937 it appeared in the actual metapost program, and
6938 |originator(p):=mp_program_code| in all other cases.
6940 @d originator(A) mp->mem[(A)+7].hh.b0 /* the creator of this knot */
6944 mp_program_code=0, /* not created by a user */
6945 mp_metapost_user /* created by a user */
6948 @ Here is a routine that prints a given knot list
6949 in symbolic form. It illustrates the conventions discussed above,
6950 and checks for anomalies that might arise while \MP\ is being debugged.
6953 static void mp_pr_path (MP mp,pointer h);
6956 void mp_pr_path (MP mp,pointer h) {
6957 pointer p,q; /* for list traversal */
6961 if ( (p==null)||(q==null) ) {
6962 mp_print_nl(mp, "???"); return; /* this won't happen */
6965 @<Print information for adjacent knots |p| and |q|@>;
6968 if ( (p!=h)||(left_type(h)!=mp_endpoint) ) {
6969 @<Print two dots, followed by |given| or |curl| if present@>;
6972 if ( left_type(h)!=mp_endpoint )
6973 mp_print(mp, "cycle");
6976 @ @<Print information for adjacent knots...@>=
6977 mp_print_two(mp, x_coord(p),y_coord(p));
6978 switch (right_type(p)) {
6980 if ( left_type(p)==mp_open ) mp_print(mp, "{open?}"); /* can't happen */
6982 if ( (left_type(q)!=mp_endpoint)||(q!=h) ) q=null; /* force an error */
6986 @<Print control points between |p| and |q|, then |goto done1|@>;
6989 @<Print information for a curve that begins |open|@>;
6993 @<Print information for a curve that begins |curl| or |given|@>;
6996 mp_print(mp, "???"); /* can't happen */
7000 if ( left_type(q)<=mp_explicit ) {
7001 mp_print(mp, "..control?"); /* can't happen */
7003 } else if ( (right_tension(p)!=unity)||(left_tension(q)!=unity) ) {
7004 @<Print tension between |p| and |q|@>;
7007 @ Since |n_sin_cos| produces |fraction| results, which we will print as if they
7008 were |scaled|, the magnitude of a |given| direction vector will be~4096.
7010 @<Print two dots...@>=
7012 mp_print_nl(mp, " ..");
7013 if ( left_type(p)==mp_given ) {
7014 mp_n_sin_cos(mp, left_given(p)); mp_print_char(mp, xord('{'));
7015 mp_print_scaled(mp, mp->n_cos); mp_print_char(mp, xord(','));
7016 mp_print_scaled(mp, mp->n_sin); mp_print_char(mp, xord('}'));
7017 } else if ( left_type(p)==mp_curl ){
7018 mp_print(mp, "{curl ");
7019 mp_print_scaled(mp, left_curl(p)); mp_print_char(mp, xord('}'));
7023 @ @<Print tension between |p| and |q|@>=
7025 mp_print(mp, "..tension ");
7026 if ( right_tension(p)<0 ) mp_print(mp, "atleast");
7027 mp_print_scaled(mp, abs(right_tension(p)));
7028 if ( right_tension(p)!=left_tension(q) ){
7029 mp_print(mp, " and ");
7030 if ( left_tension(q)<0 ) mp_print(mp, "atleast");
7031 mp_print_scaled(mp, abs(left_tension(q)));
7035 @ @<Print control points between |p| and |q|, then |goto done1|@>=
7037 mp_print(mp, "..controls ");
7038 mp_print_two(mp, right_x(p),right_y(p));
7039 mp_print(mp, " and ");
7040 if ( left_type(q)!=mp_explicit ) {
7041 mp_print(mp, "??"); /* can't happen */
7044 mp_print_two(mp, left_x(q),left_y(q));
7049 @ @<Print information for a curve that begins |open|@>=
7050 if ( (left_type(p)!=mp_explicit)&&(left_type(p)!=mp_open) ) {
7051 mp_print(mp, "{open?}"); /* can't happen */
7055 @ A curl of 1 is shown explicitly, so that the user sees clearly that
7056 \MP's default curl is present.
7058 @<Print information for a curve that begins |curl|...@>=
7060 if ( left_type(p)==mp_open )
7061 mp_print(mp, "??"); /* can't happen */
7063 if ( right_type(p)==mp_curl ) {
7064 mp_print(mp, "{curl "); mp_print_scaled(mp, right_curl(p));
7066 mp_n_sin_cos(mp, right_given(p)); mp_print_char(mp, xord('{'));
7067 mp_print_scaled(mp, mp->n_cos); mp_print_char(mp, xord(','));
7068 mp_print_scaled(mp, mp->n_sin);
7070 mp_print_char(mp, xord('}'));
7073 @ It is convenient to have another version of |pr_path| that prints the path
7074 as a diagnostic message.
7077 static void mp_print_path (MP mp,pointer h, const char *s, boolean nuline) ;
7080 void mp_print_path (MP mp,pointer h, const char *s, boolean nuline) {
7081 mp_print_diagnostic(mp, "Path", s, nuline); mp_print_ln(mp);
7084 mp_end_diagnostic(mp, true);
7087 @ If we want to duplicate a knot node, we can say |copy_knot|:
7090 static pointer mp_copy_knot (MP mp,pointer p) {
7091 pointer q; /* the copy */
7092 int k; /* runs through the words of a knot node */
7093 q=mp_get_node(mp, knot_node_size);
7094 for (k=0;k<knot_node_size;k++) {
7095 mp->mem[q+k]=mp->mem[p+k];
7097 originator(q)=originator(p);
7101 @ The |copy_path| routine makes a clone of a given path.
7104 static pointer mp_copy_path (MP mp, pointer p) {
7105 pointer q,pp,qq; /* for list manipulation */
7106 q=mp_copy_knot(mp, p);
7107 qq=q; pp=mp_link(p);
7109 mp_link(qq)=mp_copy_knot(mp, pp);
7118 @ Just before |ship_out|, knot lists are exported for printing.
7120 The |gr_XXXX| macros are defined in |mppsout.h|.
7123 static mp_knot *mp_export_knot (MP mp,pointer p) {
7124 mp_knot *q; /* the copy */
7127 q = xmalloc(1, sizeof (mp_knot));
7128 memset(q,0,sizeof (mp_knot));
7129 gr_left_type(q) = (unsigned short)left_type(p);
7130 gr_right_type(q) = (unsigned short)right_type(p);
7131 gr_x_coord(q) = x_coord(p);
7132 gr_y_coord(q) = y_coord(p);
7133 gr_left_x(q) = left_x(p);
7134 gr_left_y(q) = left_y(p);
7135 gr_right_x(q) = right_x(p);
7136 gr_right_y(q) = right_y(p);
7137 gr_originator(q) = (unsigned char)originator(p);
7141 @ The |export_knot_list| routine therefore also makes a clone
7145 static mp_knot *mp_export_knot_list (MP mp, pointer p) {
7146 mp_knot *q, *qq; /* for list manipulation */
7147 pointer pp; /* for list manipulation */
7150 q=mp_export_knot(mp, p);
7151 qq=q; pp=mp_link(p);
7153 gr_next_knot(qq)=mp_export_knot(mp, pp);
7154 qq=gr_next_knot(qq);
7162 @ Similarly, there's a way to copy the {\sl reverse\/} of a path. This procedure
7163 returns a pointer to the first node of the copy, if the path is a cycle,
7164 but to the final node of a non-cyclic copy. The global
7165 variable |path_tail| will point to the final node of the original path;
7166 this trick makes it easier to implement `\&{doublepath}'.
7168 All node types are assumed to be |endpoint| or |explicit| only.
7171 static pointer mp_htap_ypoc (MP mp,pointer p) {
7172 pointer q,pp,qq,rr; /* for list manipulation */
7173 q=mp_get_node(mp, knot_node_size); /* this will correspond to |p| */
7176 right_type(qq)=left_type(pp); left_type(qq)=right_type(pp);
7177 x_coord(qq)=x_coord(pp); y_coord(qq)=y_coord(pp);
7178 right_x(qq)=left_x(pp); right_y(qq)=left_y(pp);
7179 left_x(qq)=right_x(pp); left_y(qq)=right_y(pp);
7180 originator(qq)=originator(pp);
7181 if ( mp_link(pp)==p ) {
7182 mp_link(q)=qq; mp->path_tail=pp; return q;
7184 rr=mp_get_node(mp, knot_node_size); mp_link(rr)=qq; qq=rr; pp=mp_link(pp);
7189 pointer path_tail; /* the node that links to the beginning of a path */
7191 @ When a cyclic list of knot nodes is no longer needed, it can be recycled by
7192 calling the following subroutine.
7195 static void mp_toss_knot_list (MP mp,pointer p) ;
7198 void mp_toss_knot_list (MP mp,pointer p) {
7199 pointer q; /* the node being freed */
7200 pointer r; /* the next node */
7204 mp_free_node(mp, q,knot_node_size); q=r;
7208 @* \[18] Choosing control points.
7209 Now we must actually delve into one of \MP's more difficult routines,
7210 the |make_choices| procedure that chooses angles and control points for
7211 the splines of a curve when the user has not specified them explicitly.
7212 The parameter to |make_choices| points to a list of knots and
7213 path information, as described above.
7215 A path decomposes into independent segments at ``breakpoint'' knots,
7216 which are knots whose left and right angles are both prespecified in
7217 some way (i.e., their |left_type| and |right_type| aren't both open).
7220 static void mp_make_choices (MP mp,pointer knots) {
7221 pointer h; /* the first breakpoint */
7222 pointer p,q; /* consecutive breakpoints being processed */
7223 @<Other local variables for |make_choices|@>;
7224 check_arith; /* make sure that |arith_error=false| */
7225 if ( mp->internal[mp_tracing_choices]>0 )
7226 mp_print_path(mp, knots,", before choices",true);
7227 @<If consecutive knots are equal, join them explicitly@>;
7228 @<Find the first breakpoint, |h|, on the path;
7229 insert an artificial breakpoint if the path is an unbroken cycle@>;
7232 @<Fill in the control points between |p| and the next breakpoint,
7233 then advance |p| to that breakpoint@>;
7235 if ( mp->internal[mp_tracing_choices]>0 )
7236 mp_print_path(mp, knots,", after choices",true);
7237 if ( mp->arith_error ) {
7238 @<Report an unexpected problem during the choice-making@>;
7242 @ @<Report an unexpected problem during the choice...@>=
7244 print_err("Some number got too big");
7245 @.Some number got too big@>
7246 help2("The path that I just computed is out of range.",
7247 "So it will probably look funny. Proceed, for a laugh.");
7248 mp_put_get_error(mp); mp->arith_error=false;
7251 @ Two knots in a row with the same coordinates will always be joined
7252 by an explicit ``curve'' whose control points are identical with the
7255 @<If consecutive knots are equal, join them explicitly@>=
7259 if ( x_coord(p)==x_coord(q) && y_coord(p)==y_coord(q) && right_type(p)>mp_explicit ) {
7260 right_type(p)=mp_explicit;
7261 if ( left_type(p)==mp_open ) {
7262 left_type(p)=mp_curl; left_curl(p)=unity;
7264 left_type(q)=mp_explicit;
7265 if ( right_type(q)==mp_open ) {
7266 right_type(q)=mp_curl; right_curl(q)=unity;
7268 right_x(p)=x_coord(p); left_x(q)=x_coord(p);
7269 right_y(p)=y_coord(p); left_y(q)=y_coord(p);
7274 @ If there are no breakpoints, it is necessary to compute the direction
7275 angles around an entire cycle. In this case the |left_type| of the first
7276 node is temporarily changed to |end_cycle|.
7278 @<Find the first breakpoint, |h|, on the path...@>=
7281 if ( left_type(h)!=mp_open ) break;
7282 if ( right_type(h)!=mp_open ) break;
7285 left_type(h)=mp_end_cycle; break;
7289 @ If |right_type(p)<given| and |q=mp_link(p)|, we must have
7290 |right_type(p)=left_type(q)=mp_explicit| or |endpoint|.
7292 @<Fill in the control points between |p| and the next breakpoint...@>=
7294 if ( right_type(p)>=mp_given ) {
7295 while ( (left_type(q)==mp_open)&&(right_type(q)==mp_open) ) q=mp_link(q);
7296 @<Fill in the control information between
7297 consecutive breakpoints |p| and |q|@>;
7298 } else if ( right_type(p)==mp_endpoint ) {
7299 @<Give reasonable values for the unused control points between |p| and~|q|@>;
7303 @ This step makes it possible to transform an explicitly computed path without
7304 checking the |left_type| and |right_type| fields.
7306 @<Give reasonable values for the unused control points between |p| and~|q|@>=
7308 right_x(p)=x_coord(p); right_y(p)=y_coord(p);
7309 left_x(q)=x_coord(q); left_y(q)=y_coord(q);
7312 @ Before we can go further into the way choices are made, we need to
7313 consider the underlying theory. The basic ideas implemented in |make_choices|
7314 are due to John Hobby, who introduced the notion of ``mock curvature''
7315 @^Hobby, John Douglas@>
7316 at a knot. Angles are chosen so that they preserve mock curvature when
7317 a knot is passed, and this has been found to produce excellent results.
7319 It is convenient to introduce some notations that simplify the necessary
7320 formulas. Let $d_{k,k+1}=\vert z\k-z_k\vert$ be the (nonzero) distance
7321 between knots |k| and |k+1|; and let
7322 $${z\k-z_k\over z_k-z_{k-1}}={d_{k,k+1}\over d_{k-1,k}}e^{i\psi_k}$$
7323 so that a polygonal line from $z_{k-1}$ to $z_k$ to $z\k$ turns left
7324 through an angle of~$\psi_k$. We assume that $\vert\psi_k\vert\L180^\circ$.
7325 The control points for the spline from $z_k$ to $z\k$ will be denoted by
7326 $$\eqalign{z_k^+&=z_k+
7327 \textstyle{1\over3}\rho_k e^{i\theta_k}(z\k-z_k),\cr
7329 \textstyle{1\over3}\sigma\k e^{-i\phi\k}(z\k-z_k),\cr}$$
7330 where $\rho_k$ and $\sigma\k$ are nonnegative ``velocity ratios'' at the
7331 beginning and end of the curve, while $\theta_k$ and $\phi\k$ are the
7332 corresponding ``offset angles.'' These angles satisfy the condition
7333 $$\theta_k+\phi_k+\psi_k=0,\eqno(*)$$
7334 whenever the curve leaves an intermediate knot~|k| in the direction that
7337 @ Let $\alpha_k$ and $\beta\k$ be the reciprocals of the ``tension'' of
7338 the curve at its beginning and ending points. This means that
7339 $\rho_k=\alpha_k f(\theta_k,\phi\k)$ and $\sigma\k=\beta\k f(\phi\k,\theta_k)$,
7340 where $f(\theta,\phi)$ is \MP's standard velocity function defined in
7341 the |velocity| subroutine. The cubic spline $B(z_k^{\phantom+},z_k^+,
7342 z\k^-,z\k^{\phantom+};t)$
7345 $${2\sigma\k\sin(\theta_k+\phi\k)-6\sin\theta_k\over\rho_k^2d_{k,k+1}}
7346 \qquad{\rm and}\qquad
7347 {2\rho_k\sin(\theta_k+\phi\k)-6\sin\phi\k\over\sigma\k^2d_{k,k+1}}$$
7348 at |t=0| and |t=1|, respectively. The mock curvature is the linear
7350 approximation to this true curvature that arises in the limit for
7351 small $\theta_k$ and~$\phi\k$, if second-order terms are discarded.
7352 The standard velocity function satisfies
7353 $$f(\theta,\phi)=1+O(\theta^2+\theta\phi+\phi^2);$$
7354 hence the mock curvatures are respectively
7355 $${2\beta\k(\theta_k+\phi\k)-6\theta_k\over\alpha_k^2d_{k,k+1}}
7356 \qquad{\rm and}\qquad
7357 {2\alpha_k(\theta_k+\phi\k)-6\phi\k\over\beta\k^2d_{k,k+1}}.\eqno(**)$$
7359 @ The turning angles $\psi_k$ are given, and equation $(*)$ above
7360 determines $\phi_k$ when $\theta_k$ is known, so the task of
7361 angle selection is essentially to choose appropriate values for each
7362 $\theta_k$. When equation~$(*)$ is used to eliminate $\phi$~variables
7363 from $(**)$, we obtain a system of linear equations of the form
7364 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
7366 $$A_k={\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
7367 \qquad B_k={3-\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
7368 \qquad C_k={3-\beta\k\over\alpha_k^2d_{k,k+1}},
7369 \qquad D_k={\beta\k\over\alpha_k^2d_{k,k+1}}.$$
7370 The tensions are always $3\over4$ or more, hence each $\alpha$ and~$\beta$
7371 will be at most $4\over3$. It follows that $B_k\G{5\over4}A_k$ and
7372 $C_k\G{5\over4}D_k$; hence the equations are diagonally dominant;
7373 hence they have a unique solution. Moreover, in most cases the tensions
7374 are equal to~1, so that $B_k=2A_k$ and $C_k=2D_k$. This makes the
7375 solution numerically stable, and there is an exponential damping
7376 effect: The data at knot $k\pm j$ affects the angle at knot~$k$ by
7377 a factor of~$O(2^{-j})$.
7379 @ However, we still must consider the angles at the starting and ending
7380 knots of a non-cyclic path. These angles might be given explicitly, or
7381 they might be specified implicitly in terms of an amount of ``curl.''
7383 Let's assume that angles need to be determined for a non-cyclic path
7384 starting at $z_0$ and ending at~$z_n$. Then equations of the form
7385 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta_{k+1}=R_k$$
7386 have been given for $0<k<n$, and it will be convenient to introduce
7387 equations of the same form for $k=0$ and $k=n$, where
7388 $$A_0=B_0=C_n=D_n=0.$$
7389 If $\theta_0$ is supposed to have a given value $E_0$, we simply
7390 define $C_0=1$, $D_0=0$, and $R_0=E_0$. Otherwise a curl
7391 parameter, $\gamma_0$, has been specified at~$z_0$; this means
7392 that the mock curvature at $z_0$ should be $\gamma_0$ times the
7393 mock curvature at $z_1$; i.e.,
7394 $${2\beta_1(\theta_0+\phi_1)-6\theta_0\over\alpha_0^2d_{01}}
7395 =\gamma_0{2\alpha_0(\theta_0+\phi_1)-6\phi_1\over\beta_1^2d_{01}}.$$
7396 This equation simplifies to
7397 $$(\alpha_0\chi_0+3-\beta_1)\theta_0+
7398 \bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\theta_1=
7399 -\bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\psi_1,$$
7400 where $\chi_0=\alpha_0^2\gamma_0/\beta_1^2$; so we can set $C_0=
7401 \chi_0\alpha_0+3-\beta_1$, $D_0=(3-\alpha_0)\chi_0+\beta_1$, $R_0=-D_0\psi_1$.
7402 It can be shown that $C_0>0$ and $C_0B_1-A_1D_0>0$ when $\gamma_0\G0$,
7403 hence the linear equations remain nonsingular.
7405 Similar considerations apply at the right end, when the final angle $\phi_n$
7406 may or may not need to be determined. It is convenient to let $\psi_n=0$,
7407 hence $\theta_n=-\phi_n$. We either have an explicit equation $\theta_n=E_n$,
7409 $$\bigl((3-\beta_n)\chi_n+\alpha_{n-1}\bigr)\theta_{n-1}+
7410 (\beta_n\chi_n+3-\alpha_{n-1})\theta_n=0,\qquad
7411 \chi_n={\beta_n^2\gamma_n\over\alpha_{n-1}^2}.$$
7413 When |make_choices| chooses angles, it must compute the coefficients of
7414 these linear equations, then solve the equations. To compute the coefficients,
7415 it is necessary to compute arctangents of the given turning angles~$\psi_k$.
7416 When the equations are solved, the chosen directions $\theta_k$ are put
7417 back into the form of control points by essentially computing sines and
7420 @ OK, we are ready to make the hard choices of |make_choices|.
7421 Most of the work is relegated to an auxiliary procedure
7422 called |solve_choices|, which has been introduced to keep
7423 |make_choices| from being extremely long.
7425 @<Fill in the control information between...@>=
7426 @<Calculate the turning angles $\psi_k$ and the distances $d_{k,k+1}$;
7427 set $n$ to the length of the path@>;
7428 @<Remove |open| types at the breakpoints@>;
7429 mp_solve_choices(mp, p,q,n)
7431 @ It's convenient to precompute quantities that will be needed several
7432 times later. The values of |delta_x[k]| and |delta_y[k]| will be the
7433 coordinates of $z\k-z_k$, and the magnitude of this vector will be
7434 |delta[k]=@t$d_{k,k+1}$@>|. The path angle $\psi_k$ between $z_k-z_{k-1}$
7435 and $z\k-z_k$ will be stored in |psi[k]|.
7438 int path_size; /* maximum number of knots between breakpoints of a path */
7441 scaled *delta; /* knot differences */
7442 angle *psi; /* turning angles */
7444 @ @<Dealloc variables@>=
7450 @ @<Other local variables for |make_choices|@>=
7451 int k,n; /* current and final knot numbers */
7452 pointer s,t; /* registers for list traversal */
7453 scaled delx,dely; /* directions where |open| meets |explicit| */
7454 fraction sine,cosine; /* trig functions of various angles */
7456 @ @<Calculate the turning angles...@>=
7459 k=0; s=p; n=mp->path_size;
7462 mp->delta_x[k]=x_coord(t)-x_coord(s);
7463 mp->delta_y[k]=y_coord(t)-y_coord(s);
7464 mp->delta[k]=mp_pyth_add(mp, mp->delta_x[k],mp->delta_y[k]);
7466 sine=mp_make_fraction(mp, mp->delta_y[k-1],mp->delta[k-1]);
7467 cosine=mp_make_fraction(mp, mp->delta_x[k-1],mp->delta[k-1]);
7468 mp->psi[k]=mp_n_arg(mp, mp_take_fraction(mp, mp->delta_x[k],cosine)+
7469 mp_take_fraction(mp, mp->delta_y[k],sine),
7470 mp_take_fraction(mp, mp->delta_y[k],cosine)-
7471 mp_take_fraction(mp, mp->delta_x[k],sine));
7474 if ( k==mp->path_size ) {
7475 mp_reallocate_paths(mp, mp->path_size+(mp->path_size/4));
7476 goto RESTART; /* retry, loop size has changed */
7479 } while (!((k>=n)&&(left_type(s)!=mp_end_cycle)));
7480 if ( k==n ) mp->psi[n]=0; else mp->psi[k]=mp->psi[1];
7483 @ When we get to this point of the code, |right_type(p)| is either
7484 |given| or |curl| or |open|. If it is |open|, we must have
7485 |left_type(p)=mp_end_cycle| or |left_type(p)=mp_explicit|. In the latter
7486 case, the |open| type is converted to |given|; however, if the
7487 velocity coming into this knot is zero, the |open| type is
7488 converted to a |curl|, since we don't know the incoming direction.
7490 Similarly, |left_type(q)| is either |given| or |curl| or |open| or
7491 |mp_end_cycle|. The |open| possibility is reduced either to |given| or to |curl|.
7493 @<Remove |open| types at the breakpoints@>=
7494 if ( left_type(q)==mp_open ) {
7495 delx=right_x(q)-x_coord(q); dely=right_y(q)-y_coord(q);
7496 if ( (delx==0)&&(dely==0) ) {
7497 left_type(q)=mp_curl; left_curl(q)=unity;
7499 left_type(q)=mp_given; left_given(q)=mp_n_arg(mp, delx,dely);
7502 if ( (right_type(p)==mp_open)&&(left_type(p)==mp_explicit) ) {
7503 delx=x_coord(p)-left_x(p); dely=y_coord(p)-left_y(p);
7504 if ( (delx==0)&&(dely==0) ) {
7505 right_type(p)=mp_curl; right_curl(p)=unity;
7507 right_type(p)=mp_given; right_given(p)=mp_n_arg(mp, delx,dely);
7511 @ Linear equations need to be solved whenever |n>1|; and also when |n=1|
7512 and exactly one of the breakpoints involves a curl. The simplest case occurs
7513 when |n=1| and there is a curl at both breakpoints; then we simply draw
7516 But before coding up the simple cases, we might as well face the general case,
7517 since we must deal with it sooner or later, and since the general case
7518 is likely to give some insight into the way simple cases can be handled best.
7520 When there is no cycle, the linear equations to be solved form a tridiagonal
7521 system, and we can apply the standard technique of Gaussian elimination
7522 to convert that system to a sequence of equations of the form
7523 $$\theta_0+u_0\theta_1=v_0,\quad
7524 \theta_1+u_1\theta_2=v_1,\quad\ldots,\quad
7525 \theta_{n-1}+u_{n-1}\theta_n=v_{n-1},\quad
7527 It is possible to do this diagonalization while generating the equations.
7528 Once $\theta_n$ is known, it is easy to determine $\theta_{n-1}$, \dots,
7529 $\theta_1$, $\theta_0$; thus, the equations will be solved.
7531 The procedure is slightly more complex when there is a cycle, but the
7532 basic idea will be nearly the same. In the cyclic case the right-hand
7533 sides will be $v_k+w_k\theta_0$ instead of simply $v_k$, and we will start
7534 the process off with $u_0=v_0=0$, $w_0=1$. The final equation will be not
7535 $\theta_n=v_n$ but $\theta_n+u_n\theta_1=v_n+w_n\theta_0$; an appropriate
7536 ending routine will take account of the fact that $\theta_n=\theta_0$ and
7537 eliminate the $w$'s from the system, after which the solution can be
7540 When $u_k$, $v_k$, and $w_k$ are being computed, the three pointer
7541 variables |r|, |s|,~|t| will point respectively to knots |k-1|, |k|,
7542 and~|k+1|. The $u$'s and $w$'s are scaled by $2^{28}$, i.e., they are
7543 of type |fraction|; the $\theta$'s and $v$'s are of type |angle|.
7546 angle *theta; /* values of $\theta_k$ */
7547 fraction *uu; /* values of $u_k$ */
7548 angle *vv; /* values of $v_k$ */
7549 fraction *ww; /* values of $w_k$ */
7551 @ @<Dealloc variables@>=
7558 static void mp_reallocate_paths (MP mp, int l);
7561 void mp_reallocate_paths (MP mp, int l) {
7562 XREALLOC (mp->delta_x, l, scaled);
7563 XREALLOC (mp->delta_y, l, scaled);
7564 XREALLOC (mp->delta, l, scaled);
7565 XREALLOC (mp->psi, l, angle);
7566 XREALLOC (mp->theta, l, angle);
7567 XREALLOC (mp->uu, l, fraction);
7568 XREALLOC (mp->vv, l, angle);
7569 XREALLOC (mp->ww, l, fraction);
7573 @ Our immediate problem is to get the ball rolling by setting up the
7574 first equation or by realizing that no equations are needed, and to fit
7575 this initialization into a framework suitable for the overall computation.
7578 static void mp_solve_choices (MP mp,pointer p, pointer q, halfword n) ;
7581 void mp_solve_choices (MP mp,pointer p, pointer q, halfword n) {
7582 int k; /* current knot number */
7583 pointer r,s,t; /* registers for list traversal */
7584 @<Other local variables for |solve_choices|@>;
7589 @<Get the linear equations started; or |return|
7590 with the control points in place, if linear equations
7593 switch (left_type(s)) {
7594 case mp_end_cycle: case mp_open:
7595 @<Set up equation to match mock curvatures
7596 at $z_k$; then |goto found| with $\theta_n$
7597 adjusted to equal $\theta_0$, if a cycle has ended@>;
7600 @<Set up equation for a curl at $\theta_n$
7604 @<Calculate the given value of $\theta_n$
7607 } /* there are no other cases */
7612 @<Finish choosing angles and assigning control points@>;
7615 @ On the first time through the loop, we have |k=0| and |r| is not yet
7616 defined. The first linear equation, if any, will have $A_0=B_0=0$.
7618 @<Get the linear equations started...@>=
7619 switch (right_type(s)) {
7621 if ( left_type(t)==mp_given ) {
7622 @<Reduce to simple case of two givens and |return|@>
7624 @<Set up the equation for a given value of $\theta_0$@>;
7628 if ( left_type(t)==mp_curl ) {
7629 @<Reduce to simple case of straight line and |return|@>
7631 @<Set up the equation for a curl at $\theta_0$@>;
7635 mp->uu[0]=0; mp->vv[0]=0; mp->ww[0]=fraction_one;
7636 /* this begins a cycle */
7638 } /* there are no other cases */
7640 @ The general equation that specifies equality of mock curvature at $z_k$ is
7641 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
7642 as derived above. We want to combine this with the already-derived equation
7643 $\theta_{k-1}+u_{k-1}\theta_k=v_{k-1}+w_{k-1}\theta_0$ in order to obtain
7645 $\theta_k+u_k\theta\k=v_k+w_k\theta_0$. This can be done by dividing the
7647 $$(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}
7648 -A_kw_{k-1}\theta_0$$
7649 by $B_k-u_{k-1}A_k+C_k$. The trick is to do this carefully with
7650 fixed-point arithmetic, avoiding the chance of overflow while retaining
7653 The calculations will be performed in several registers that
7654 provide temporary storage for intermediate quantities.
7656 @<Other local variables for |solve_choices|@>=
7657 fraction aa,bb,cc,ff,acc; /* temporary registers */
7658 scaled dd,ee; /* likewise, but |scaled| */
7659 scaled lt,rt; /* tension values */
7661 @ @<Set up equation to match mock curvatures...@>=
7662 { @<Calculate the values $\\{aa}=A_k/B_k$, $\\{bb}=D_k/C_k$,
7663 $\\{dd}=(3-\alpha_{k-1})d_{k,k+1}$, $\\{ee}=(3-\beta\k)d_{k-1,k}$,
7664 and $\\{cc}=(B_k-u_{k-1}A_k)/B_k$@>;
7665 @<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>;
7666 mp->uu[k]=mp_take_fraction(mp, ff,bb);
7667 @<Calculate the values of $v_k$ and $w_k$@>;
7668 if ( left_type(s)==mp_end_cycle ) {
7669 @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>;
7673 @ Since tension values are never less than 3/4, the values |aa| and
7674 |bb| computed here are never more than 4/5.
7676 @<Calculate the values $\\{aa}=...@>=
7677 if ( abs(right_tension(r))==unity) {
7678 aa=fraction_half; dd=2*mp->delta[k];
7680 aa=mp_make_fraction(mp, unity,3*abs(right_tension(r))-unity);
7681 dd=mp_take_fraction(mp, mp->delta[k],
7682 fraction_three-mp_make_fraction(mp, unity,abs(right_tension(r))));
7684 if ( abs(left_tension(t))==unity ){
7685 bb=fraction_half; ee=2*mp->delta[k-1];
7687 bb=mp_make_fraction(mp, unity,3*abs(left_tension(t))-unity);
7688 ee=mp_take_fraction(mp, mp->delta[k-1],
7689 fraction_three-mp_make_fraction(mp, unity,abs(left_tension(t))));
7691 cc=fraction_one-mp_take_fraction(mp, mp->uu[k-1],aa)
7693 @ The ratio to be calculated in this step can be written in the form
7694 $$\beta_k^2\cdot\\{ee}\over\beta_k^2\cdot\\{ee}+\alpha_k^2\cdot
7695 \\{cc}\cdot\\{dd},$$
7696 because of the quantities just calculated. The values of |dd| and |ee|
7697 will not be needed after this step has been performed.
7699 @<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>=
7700 dd=mp_take_fraction(mp, dd,cc); lt=abs(left_tension(s)); rt=abs(right_tension(s));
7701 if ( lt!=rt ) { /* $\beta_k^{-1}\ne\alpha_k^{-1}$ */
7703 ff=mp_make_fraction(mp, lt,rt);
7704 ff=mp_take_fraction(mp, ff,ff); /* $\alpha_k^2/\beta_k^2$ */
7705 dd=mp_take_fraction(mp, dd,ff);
7707 ff=mp_make_fraction(mp, rt,lt);
7708 ff=mp_take_fraction(mp, ff,ff); /* $\beta_k^2/\alpha_k^2$ */
7709 ee=mp_take_fraction(mp, ee,ff);
7712 ff=mp_make_fraction(mp, ee,ee+dd)
7714 @ The value of $u_{k-1}$ will be |<=1| except when $k=1$ and the previous
7715 equation was specified by a curl. In that case we must use a special
7716 method of computation to prevent overflow.
7718 Fortunately, the calculations turn out to be even simpler in this ``hard''
7719 case. The curl equation makes $w_0=0$ and $v_0=-u_0\psi_1$, hence
7720 $-B_1\psi_1-A_1v_0=-(B_1-u_0A_1)\psi_1=-\\{cc}\cdot B_1\psi_1$.
7722 @<Calculate the values of $v_k$ and $w_k$@>=
7723 acc=-mp_take_fraction(mp, mp->psi[k+1],mp->uu[k]);
7724 if ( right_type(r)==mp_curl ) {
7726 mp->vv[k]=acc-mp_take_fraction(mp, mp->psi[1],fraction_one-ff);
7728 ff=mp_make_fraction(mp, fraction_one-ff,cc); /* this is
7729 $B_k/(C_k+B_k-u_{k-1}A_k)<5$ */
7730 acc=acc-mp_take_fraction(mp, mp->psi[k],ff);
7731 ff=mp_take_fraction(mp, ff,aa); /* this is $A_k/(C_k+B_k-u_{k-1}A_k)$ */
7732 mp->vv[k]=acc-mp_take_fraction(mp, mp->vv[k-1],ff);
7733 if ( mp->ww[k-1]==0 ) mp->ww[k]=0;
7734 else mp->ww[k]=-mp_take_fraction(mp, mp->ww[k-1],ff);
7737 @ When a complete cycle has been traversed, we have $\theta_k+u_k\theta\k=
7738 v_k+w_k\theta_0$, for |1<=k<=n|. We would like to determine the value of
7739 $\theta_n$ and reduce the system to the form $\theta_k+u_k\theta\k=v_k$
7740 for |0<=k<n|, so that the cyclic case can be finished up just as if there
7743 The idea in the following code is to observe that
7744 $$\eqalign{\theta_n&=v_n+w_n\theta_0-u_n\theta_1=\cdots\cr
7745 &=v_n+w_n\theta_0-u_n\bigl(v_1+w_1\theta_0-u_1(v_2+\cdots
7746 -u_{n-2}(v_{n-1}+w_{n-1}\theta_0-u_{n-1}\theta_0))\bigr),\cr}$$
7747 so we can solve for $\theta_n=\theta_0$.
7749 @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>=
7751 aa=0; bb=fraction_one; /* we have |k=n| */
7754 aa=mp->vv[k]-mp_take_fraction(mp, aa,mp->uu[k]);
7755 bb=mp->ww[k]-mp_take_fraction(mp, bb,mp->uu[k]);
7756 } while (k!=n); /* now $\theta_n=\\{aa}+\\{bb}\cdot\theta_n$ */
7757 aa=mp_make_fraction(mp, aa,fraction_one-bb);
7758 mp->theta[n]=aa; mp->vv[0]=aa;
7759 for (k=1;k<=n-1;k++) {
7760 mp->vv[k]=mp->vv[k]+mp_take_fraction(mp, aa,mp->ww[k]);
7765 @ @d reduce_angle(A) if ( abs((A))>one_eighty_deg ) {
7766 if ( (A)>0 ) (A)=(A)-three_sixty_deg; else (A)=(A)+three_sixty_deg; }
7768 @<Calculate the given value of $\theta_n$...@>=
7770 mp->theta[n]=left_given(s)-mp_n_arg(mp, mp->delta_x[n-1],mp->delta_y[n-1]);
7771 reduce_angle(mp->theta[n]);
7775 @ @<Set up the equation for a given value of $\theta_0$@>=
7777 mp->vv[0]=right_given(s)-mp_n_arg(mp, mp->delta_x[0],mp->delta_y[0]);
7778 reduce_angle(mp->vv[0]);
7779 mp->uu[0]=0; mp->ww[0]=0;
7782 @ @<Set up the equation for a curl at $\theta_0$@>=
7783 { cc=right_curl(s); lt=abs(left_tension(t)); rt=abs(right_tension(s));
7784 if ( (rt==unity)&&(lt==unity) )
7785 mp->uu[0]=mp_make_fraction(mp, cc+cc+unity,cc+two);
7787 mp->uu[0]=mp_curl_ratio(mp, cc,rt,lt);
7788 mp->vv[0]=-mp_take_fraction(mp, mp->psi[1],mp->uu[0]); mp->ww[0]=0;
7791 @ @<Set up equation for a curl at $\theta_n$...@>=
7792 { cc=left_curl(s); lt=abs(left_tension(s)); rt=abs(right_tension(r));
7793 if ( (rt==unity)&&(lt==unity) )
7794 ff=mp_make_fraction(mp, cc+cc+unity,cc+two);
7796 ff=mp_curl_ratio(mp, cc,lt,rt);
7797 mp->theta[n]=-mp_make_fraction(mp, mp_take_fraction(mp, mp->vv[n-1],ff),
7798 fraction_one-mp_take_fraction(mp, ff,mp->uu[n-1]));
7802 @ The |curl_ratio| subroutine has three arguments, which our previous notation
7803 encourages us to call $\gamma$, $\alpha^{-1}$, and $\beta^{-1}$. It is
7804 a somewhat tedious program to calculate
7805 $${(3-\alpha)\alpha^2\gamma+\beta^3\over
7806 \alpha^3\gamma+(3-\beta)\beta^2},$$
7807 with the result reduced to 4 if it exceeds 4. (This reduction of curl
7808 is necessary only if the curl and tension are both large.)
7809 The values of $\alpha$ and $\beta$ will be at most~4/3.
7812 static fraction mp_curl_ratio (MP mp,scaled gamma, scaled a_tension,
7816 fraction mp_curl_ratio (MP mp,scaled gamma, scaled a_tension,
7818 fraction alpha,beta,num,denom,ff; /* registers */
7819 alpha=mp_make_fraction(mp, unity,a_tension);
7820 beta=mp_make_fraction(mp, unity,b_tension);
7821 if ( alpha<=beta ) {
7822 ff=mp_make_fraction(mp, alpha,beta); ff=mp_take_fraction(mp, ff,ff);
7823 gamma=mp_take_fraction(mp, gamma,ff);
7824 beta=beta / 010000; /* convert |fraction| to |scaled| */
7825 denom=mp_take_fraction(mp, gamma,alpha)+three-beta;
7826 num=mp_take_fraction(mp, gamma,fraction_three-alpha)+beta;
7828 ff=mp_make_fraction(mp, beta,alpha); ff=mp_take_fraction(mp, ff,ff);
7829 beta=mp_take_fraction(mp, beta,ff) / 010000; /* convert |fraction| to |scaled| */
7830 denom=mp_take_fraction(mp, gamma,alpha)+(ff / 1365)-beta;
7831 /* $1365\approx 2^{12}/3$ */
7832 num=mp_take_fraction(mp, gamma,fraction_three-alpha)+beta;
7834 if ( num>=denom+denom+denom+denom ) return fraction_four;
7835 else return mp_make_fraction(mp, num,denom);
7838 @ We're in the home stretch now.
7840 @<Finish choosing angles and assigning control points@>=
7841 for (k=n-1;k>=0;k--) {
7842 mp->theta[k]=mp->vv[k]-mp_take_fraction(mp,mp->theta[k+1],mp->uu[k]);
7847 mp_n_sin_cos(mp, mp->theta[k]); mp->st=mp->n_sin; mp->ct=mp->n_cos;
7848 mp_n_sin_cos(mp, -mp->psi[k+1]-mp->theta[k+1]); mp->sf=mp->n_sin; mp->cf=mp->n_cos;
7849 mp_set_controls(mp, s,t,k);
7853 @ The |set_controls| routine actually puts the control points into
7854 a pair of consecutive nodes |p| and~|q|. Global variables are used to
7855 record the values of $\sin\theta$, $\cos\theta$, $\sin\phi$, and
7856 $\cos\phi$ needed in this calculation.
7862 fraction cf; /* sines and cosines */
7865 static void mp_set_controls (MP mp,pointer p, pointer q, integer k);
7868 void mp_set_controls (MP mp,pointer p, pointer q, integer k) {
7869 fraction rr,ss; /* velocities, divided by thrice the tension */
7870 scaled lt,rt; /* tensions */
7871 fraction sine; /* $\sin(\theta+\phi)$ */
7872 lt=abs(left_tension(q)); rt=abs(right_tension(p));
7873 rr=mp_velocity(mp, mp->st,mp->ct,mp->sf,mp->cf,rt);
7874 ss=mp_velocity(mp, mp->sf,mp->cf,mp->st,mp->ct,lt);
7875 if ( (right_tension(p)<0)||(left_tension(q)<0) ) {
7876 @<Decrease the velocities,
7877 if necessary, to stay inside the bounding triangle@>;
7879 right_x(p)=x_coord(p)+mp_take_fraction(mp,
7880 mp_take_fraction(mp, mp->delta_x[k],mp->ct)-
7881 mp_take_fraction(mp, mp->delta_y[k],mp->st),rr);
7882 right_y(p)=y_coord(p)+mp_take_fraction(mp,
7883 mp_take_fraction(mp, mp->delta_y[k],mp->ct)+
7884 mp_take_fraction(mp, mp->delta_x[k],mp->st),rr);
7885 left_x(q)=x_coord(q)-mp_take_fraction(mp,
7886 mp_take_fraction(mp, mp->delta_x[k],mp->cf)+
7887 mp_take_fraction(mp, mp->delta_y[k],mp->sf),ss);
7888 left_y(q)=y_coord(q)-mp_take_fraction(mp,
7889 mp_take_fraction(mp, mp->delta_y[k],mp->cf)-
7890 mp_take_fraction(mp, mp->delta_x[k],mp->sf),ss);
7891 right_type(p)=mp_explicit; left_type(q)=mp_explicit;
7894 @ The boundedness conditions $\\{rr}\L\sin\phi\,/\sin(\theta+\phi)$ and
7895 $\\{ss}\L\sin\theta\,/\sin(\theta+\phi)$ are to be enforced if $\sin\theta$,
7896 $\sin\phi$, and $\sin(\theta+\phi)$ all have the same sign. Otherwise
7897 there is no ``bounding triangle.''
7899 @<Decrease the velocities, if necessary...@>=
7900 if (((mp->st>=0)&&(mp->sf>=0))||((mp->st<=0)&&(mp->sf<=0)) ) {
7901 sine=mp_take_fraction(mp, abs(mp->st),mp->cf)+
7902 mp_take_fraction(mp, abs(mp->sf),mp->ct);
7904 sine=mp_take_fraction(mp, sine,fraction_one+unity); /* safety factor */
7905 if ( right_tension(p)<0 )
7906 if ( mp_ab_vs_cd(mp, abs(mp->sf),fraction_one,rr,sine)<0 )
7907 rr=mp_make_fraction(mp, abs(mp->sf),sine);
7908 if ( left_tension(q)<0 )
7909 if ( mp_ab_vs_cd(mp, abs(mp->st),fraction_one,ss,sine)<0 )
7910 ss=mp_make_fraction(mp, abs(mp->st),sine);
7914 @ Only the simple cases remain to be handled.
7916 @<Reduce to simple case of two givens and |return|@>=
7918 aa=mp_n_arg(mp, mp->delta_x[0],mp->delta_y[0]);
7919 mp_n_sin_cos(mp, right_given(p)-aa); mp->ct=mp->n_cos; mp->st=mp->n_sin;
7920 mp_n_sin_cos(mp, left_given(q)-aa); mp->cf=mp->n_cos; mp->sf=-mp->n_sin;
7921 mp_set_controls(mp, p,q,0); return;
7924 @ @<Reduce to simple case of straight line and |return|@>=
7926 right_type(p)=mp_explicit; left_type(q)=mp_explicit;
7927 lt=abs(left_tension(q)); rt=abs(right_tension(p));
7929 if ( mp->delta_x[0]>=0 ) right_x(p)=x_coord(p)+((mp->delta_x[0]+1) / 3);
7930 else right_x(p)=x_coord(p)+((mp->delta_x[0]-1) / 3);
7931 if ( mp->delta_y[0]>=0 ) right_y(p)=y_coord(p)+((mp->delta_y[0]+1) / 3);
7932 else right_y(p)=y_coord(p)+((mp->delta_y[0]-1) / 3);
7934 ff=mp_make_fraction(mp, unity,3*rt); /* $\alpha/3$ */
7935 right_x(p)=x_coord(p)+mp_take_fraction(mp, mp->delta_x[0],ff);
7936 right_y(p)=y_coord(p)+mp_take_fraction(mp, mp->delta_y[0],ff);
7939 if ( mp->delta_x[0]>=0 ) left_x(q)=x_coord(q)-((mp->delta_x[0]+1) / 3);
7940 else left_x(q)=x_coord(q)-((mp->delta_x[0]-1) / 3);
7941 if ( mp->delta_y[0]>=0 ) left_y(q)=y_coord(q)-((mp->delta_y[0]+1) / 3);
7942 else left_y(q)=y_coord(q)-((mp->delta_y[0]-1) / 3);
7944 ff=mp_make_fraction(mp, unity,3*lt); /* $\beta/3$ */
7945 left_x(q)=x_coord(q)-mp_take_fraction(mp, mp->delta_x[0],ff);
7946 left_y(q)=y_coord(q)-mp_take_fraction(mp, mp->delta_y[0],ff);
7951 @* \[19] Measuring paths.
7952 \MP's \&{llcorner}, \&{lrcorner}, \&{ulcorner}, and \&{urcorner} operators
7953 allow the user to measure the bounding box of anything that can go into a
7954 picture. It's easy to get rough bounds on the $x$ and $y$ extent of a path
7955 by just finding the bounding box of the knots and the control points. We
7956 need a more accurate version of the bounding box, but we can still use the
7957 easy estimate to save time by focusing on the interesting parts of the path.
7959 @ Computing an accurate bounding box involves a theme that will come up again
7960 and again. Given a Bernshte{\u\i}n polynomial
7961 @^Bernshte{\u\i}n, Serge{\u\i} Natanovich@>
7962 $$B(z_0,z_1,\ldots,z_n;t)=\sum_k{n\choose k}t^k(1-t)^{n-k}z_k,$$
7963 we can conveniently bisect its range as follows:
7966 \textindent{1)} Let $z_k^{(0)}=z_k$, for |0<=k<=n|.
7969 \textindent{2)} Let $z_k^{(j+1)}={1\over2}(z_k^{(j)}+z\k^{(j)})$, for
7970 |0<=k<n-j|, for |0<=j<n|.
7974 $$B(z_0,z_1,\ldots,z_n;t)=B(z_0^{(0)},z_0^{(1)},\ldots,z_0^{(n)};2t)
7975 =B(z_0^{(n)},z_1^{(n-1)},\ldots,z_n^{(0)};2t-1).$$
7976 This formula gives us the coefficients of polynomials to use over the ranges
7977 $0\L t\L{1\over2}$ and ${1\over2}\L t\L1$.
7979 @ Now here's a subroutine that's handy for all sorts of path computations:
7980 Given a quadratic polynomial $B(a,b,c;t)$, the |crossing_point| function
7981 returns the unique |fraction| value |t| between 0 and~1 at which
7982 $B(a,b,c;t)$ changes from positive to negative, or returns
7983 |t=fraction_one+1| if no such value exists. If |a<0| (so that $B(a,b,c;t)$
7984 is already negative at |t=0|), |crossing_point| returns the value zero.
7986 @d no_crossing { return (fraction_one+1); }
7987 @d one_crossing { return fraction_one; }
7988 @d zero_crossing { return 0; }
7989 @d mp_crossing_point(M,A,B,C) mp_do_crossing_point(A,B,C)
7991 @c static fraction mp_do_crossing_point (integer a, integer b, integer c) {
7992 integer d; /* recursive counter */
7993 integer x,xx,x0,x1,x2; /* temporary registers for bisection */
7994 if ( a<0 ) zero_crossing;
7997 if ( c>0 ) { no_crossing; }
7998 else if ( (a==0)&&(b==0) ) { no_crossing;}
7999 else { one_crossing; }
8001 if ( a==0 ) zero_crossing;
8002 } else if ( a==0 ) {
8003 if ( b<=0 ) zero_crossing;
8005 @<Use bisection to find the crossing point, if one exists@>;
8008 @ The general bisection method is quite simple when $n=2$, hence
8009 |crossing_point| does not take much time. At each stage in the
8010 recursion we have a subinterval defined by |l| and~|j| such that
8011 $B(a,b,c;2^{-l}(j+t))=B(x_0,x_1,x_2;t)$, and we want to ``zero in'' on
8012 the subinterval where $x_0\G0$ and $\min(x_1,x_2)<0$.
8014 It is convenient for purposes of calculation to combine the values
8015 of |l| and~|j| in a single variable $d=2^l+j$, because the operation
8016 of bisection then corresponds simply to doubling $d$ and possibly
8017 adding~1. Furthermore it proves to be convenient to modify
8018 our previous conventions for bisection slightly, maintaining the
8019 variables $X_0=2^lx_0$, $X_1=2^l(x_0-x_1)$, and $X_2=2^l(x_1-x_2)$.
8020 With these variables the conditions $x_0\ge0$ and $\min(x_1,x_2)<0$ are
8021 equivalent to $\max(X_1,X_1+X_2)>X_0\ge0$.
8023 The following code maintains the invariant relations
8024 $0\L|x0|<\max(|x1|,|x1|+|x2|)$,
8025 $\vert|x1|\vert<2^{30}$, $\vert|x2|\vert<2^{30}$;
8026 it has been constructed in such a way that no arithmetic overflow
8027 will occur if the inputs satisfy
8028 $a<2^{30}$, $\vert a-b\vert<2^{30}$, and $\vert b-c\vert<2^{30}$.
8030 @<Use bisection to find the crossing point...@>=
8031 d=1; x0=a; x1=a-b; x2=b-c;
8042 if ( x<=x0 ) { if ( x+x2<=x0 ) no_crossing; }
8046 } while (d<fraction_one);
8047 return (d-fraction_one)
8049 @ Here is a routine that computes the $x$ or $y$ coordinate of the point on
8050 a cubic corresponding to the |fraction| value~|t|.
8052 It is convenient to define a \.{WEB} macro |t_of_the_way| such that
8053 |t_of_the_way(a,b)| expands to |a-(a-b)*t|, i.e., to |t[a,b]|.
8055 @d t_of_the_way(A,B) ((A)-mp_take_fraction(mp,((A)-(B)),t))
8057 @c static scaled mp_eval_cubic (MP mp,pointer p, pointer q, fraction t) {
8058 scaled x1,x2,x3; /* intermediate values */
8059 x1=t_of_the_way(knot_coord(p),right_coord(p));
8060 x2=t_of_the_way(right_coord(p),left_coord(q));
8061 x3=t_of_the_way(left_coord(q),knot_coord(q));
8062 x1=t_of_the_way(x1,x2);
8063 x2=t_of_the_way(x2,x3);
8064 return t_of_the_way(x1,x2);
8067 @ The actual bounding box information is stored in global variables.
8068 Since it is convenient to address the $x$ and $y$ information
8069 separately, we define arrays indexed by |x_code..y_code| and use
8070 macros to give them more convenient names.
8074 mp_x_code=0, /* index for |minx| and |maxx| */
8075 mp_y_code /* index for |miny| and |maxy| */
8079 @d minx mp->bbmin[mp_x_code]
8080 @d maxx mp->bbmax[mp_x_code]
8081 @d miny mp->bbmin[mp_y_code]
8082 @d maxy mp->bbmax[mp_y_code]
8085 scaled bbmin[mp_y_code+1];
8086 scaled bbmax[mp_y_code+1];
8087 /* the result of procedures that compute bounding box information */
8089 @ Now we're ready for the key part of the bounding box computation.
8090 The |bound_cubic| procedure updates |bbmin[c]| and |bbmax[c]| based on
8091 $$B(\hbox{|knot_coord(p)|}, \hbox{|right_coord(p)|},
8092 \hbox{|left_coord(q)|}, \hbox{|knot_coord(q)|};t)
8094 for $0<t\le1$. In other words, the procedure adjusts the bounds to
8095 accommodate |knot_coord(q)| and any extremes over the range $0<t<1$.
8096 The |c| parameter is |x_code| or |y_code|.
8098 @c static void mp_bound_cubic (MP mp,pointer p, pointer q, quarterword c) {
8099 boolean wavy; /* whether we need to look for extremes */
8100 scaled del1,del2,del3,del,dmax; /* proportional to the control
8101 points of a quadratic derived from a cubic */
8102 fraction t,tt; /* where a quadratic crosses zero */
8103 scaled x; /* a value that |bbmin[c]| and |bbmax[c]| must accommodate */
8105 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8106 @<Check the control points against the bounding box and set |wavy:=true|
8107 if any of them lie outside@>;
8109 del1=right_coord(p)-knot_coord(p);
8110 del2=left_coord(q)-right_coord(p);
8111 del3=knot_coord(q)-left_coord(q);
8112 @<Scale up |del1|, |del2|, and |del3| for greater accuracy;
8113 also set |del| to the first nonzero element of |(del1,del2,del3)|@>;
8115 negate(del1); negate(del2); negate(del3);
8117 t=mp_crossing_point(mp, del1,del2,del3);
8118 if ( t<fraction_one ) {
8119 @<Test the extremes of the cubic against the bounding box@>;
8124 @ @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>=
8125 if ( x<mp->bbmin[c] ) mp->bbmin[c]=x;
8126 if ( x>mp->bbmax[c] ) mp->bbmax[c]=x
8128 @ @<Check the control points against the bounding box and set...@>=
8130 if ( mp->bbmin[c]<=right_coord(p) )
8131 if ( right_coord(p)<=mp->bbmax[c] )
8132 if ( mp->bbmin[c]<=left_coord(q) )
8133 if ( left_coord(q)<=mp->bbmax[c] )
8136 @ If |del1=del2=del3=0|, it's impossible to obey the title of this
8137 section. We just set |del=0| in that case.
8139 @<Scale up |del1|, |del2|, and |del3| for greater accuracy...@>=
8140 if ( del1!=0 ) del=del1;
8141 else if ( del2!=0 ) del=del2;
8145 if ( abs(del2)>dmax ) dmax=abs(del2);
8146 if ( abs(del3)>dmax ) dmax=abs(del3);
8147 while ( dmax<fraction_half ) {
8148 dmax+=dmax; del1+=del1; del2+=del2; del3+=del3;
8152 @ Since |crossing_point| has tried to choose |t| so that
8153 $B(|del1|,|del2|,|del3|;\tau)$ crosses zero at $\tau=|t|$ with negative
8154 slope, the value of |del2| computed below should not be positive.
8155 But rounding error could make it slightly positive in which case we
8156 must cut it to zero to avoid confusion.
8158 @<Test the extremes of the cubic against the bounding box@>=
8160 x=mp_eval_cubic(mp, p,q,t);
8161 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8162 del2=t_of_the_way(del2,del3);
8163 /* now |0,del2,del3| represent the derivative on the remaining interval */
8164 if ( del2>0 ) del2=0;
8165 tt=mp_crossing_point(mp, 0,-del2,-del3);
8166 if ( tt<fraction_one ) {
8167 @<Test the second extreme against the bounding box@>;
8171 @ @<Test the second extreme against the bounding box@>=
8173 x=mp_eval_cubic(mp, p,q,t_of_the_way(tt,fraction_one));
8174 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8177 @ Finding the bounding box of a path is basically a matter of applying
8178 |bound_cubic| twice for each pair of adjacent knots.
8180 @c static void mp_path_bbox (MP mp,pointer h) {
8181 pointer p,q; /* a pair of adjacent knots */
8182 minx=x_coord(h); miny=y_coord(h);
8183 maxx=minx; maxy=miny;
8186 if ( right_type(p)==mp_endpoint ) return;
8188 mp_bound_cubic(mp, x_loc(p),x_loc(q),mp_x_code);
8189 mp_bound_cubic(mp, y_loc(p),y_loc(q),mp_y_code);
8194 @ Another important way to measure a path is to find its arc length. This
8195 is best done by using the general bisection algorithm to subdivide the path
8196 until obtaining ``well behaved'' subpaths whose arc lengths can be approximated
8199 Since the arc length is the integral with respect to time of the magnitude of
8200 the velocity, it is natural to use Simpson's rule for the approximation.
8202 If $\dot B(t)$ is the spline velocity, Simpson's rule gives
8203 $$ \vb\dot B(0)\vb + 4\vb\dot B({1\over2})\vb + \vb\dot B(1)\vb \over 6 $$
8204 for the arc length of a path of length~1. For a cubic spline
8205 $B(z_0,z_1,z_2,z_3;t)$, the time derivative $\dot B(t)$ is
8206 $3B(dz_0,dz_1,dz_2;t)$, where $dz_i=z_{i+1}-z_i$. Hence the arc length
8208 $$ {\vb dz_0\vb \over 2} + 2\vb dz_{02}\vb + {\vb dz_2\vb \over 2}, $$
8210 $$ dz_{02}={1\over2}\left({dz_0+dz_1\over 2}+{dz_1+dz_2\over 2}\right)$$
8211 is the result of the bisection algorithm.
8213 @ The remaining problem is how to decide when a subpath is ``well behaved.''
8214 This could be done via the theoretical error bound for Simpson's rule,
8216 but this is impractical because it requires an estimate of the fourth
8217 derivative of the quantity being integrated. It is much easier to just perform
8218 a bisection step and see how much the arc length estimate changes. Since the
8219 error for Simpson's rule is proportional to the fourth power of the sample
8220 spacing, the remaining error is typically about $1\over16$ of the amount of
8221 the change. We say ``typically'' because the error has a pseudo-random behavior
8222 that could cause the two estimates to agree when each contain large errors.
8224 To protect against disasters such as undetected cusps, the bisection process
8225 should always continue until all the $dz_i$ vectors belong to a single
8226 $90^\circ$ sector. This ensures that no point on the spline can have velocity
8227 less than 70\% of the minimum of $\vb dz_0\vb$, $\vb dz_1\vb$ and $\vb dz_2\vb$.
8228 If such a spline happens to produce an erroneous arc length estimate that
8229 is little changed by bisection, the amount of the error is likely to be fairly
8230 small. We will try to arrange things so that freak accidents of this type do
8231 not destroy the inverse relationship between the \&{arclength} and
8232 \&{arctime} operations.
8233 @:arclength_}{\&{arclength} primitive@>
8234 @:arctime_}{\&{arctime} primitive@>
8236 @ The \&{arclength} and \&{arctime} operations are both based on a recursive
8238 function that finds the arc length of a cubic spline given $dz_0$, $dz_1$,
8239 $dz_2$. This |arc_test| routine also takes an arc length goal |a_goal| and
8240 returns the time when the arc length reaches |a_goal| if there is such a time.
8241 Thus the return value is either an arc length less than |a_goal| or, if the
8242 arc length would be at least |a_goal|, it returns a time value decreased by
8243 |two|. This allows the caller to use the sign of the result to distinguish
8244 between arc lengths and time values. On certain types of overflow, it is
8245 possible for |a_goal| and the result of |arc_test| both to be |el_gordo|.
8246 Otherwise, the result is always less than |a_goal|.
8248 Rather than halving the control point coordinates on each recursive call to
8249 |arc_test|, it is better to keep them proportional to velocity on the original
8250 curve and halve the results instead. This means that recursive calls can
8251 potentially use larger error tolerances in their arc length estimates. How
8252 much larger depends on to what extent the errors behave as though they are
8253 independent of each other. To save computing time, we use optimistic assumptions
8254 and increase the tolerance by a factor of about $\sqrt2$ for each recursive
8257 In addition to the tolerance parameter, |arc_test| should also have parameters
8258 for ${1\over3}\vb\dot B(0)\vb$, ${2\over3}\vb\dot B({1\over2})\vb$, and
8259 ${1\over3}\vb\dot B(1)\vb$. These quantities are relatively expensive to compute
8260 and they are needed in different instances of |arc_test|.
8263 static scaled mp_arc_test (MP mp, scaled dx0, scaled dy0, scaled dx1, scaled dy1,
8264 scaled dx2, scaled dy2, scaled v0, scaled v02,
8265 scaled v2, scaled a_goal, scaled tol) {
8266 boolean simple; /* are the control points confined to a $90^\circ$ sector? */
8267 scaled dx01, dy01, dx12, dy12, dx02, dy02; /* bisection results */
8269 /* twice the velocity magnitudes at $t={1\over4}$ and $t={3\over4}$ */
8270 scaled arc; /* best arc length estimate before recursion */
8271 @<Other local variables in |arc_test|@>;
8272 @<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,
8274 @<Initialize |v002|, |v022|, and the arc length estimate |arc|; if it overflows
8275 set |arc_test| and |return|@>;
8276 @<Test if the control points are confined to one quadrant or rotating them
8277 $45^\circ$ would put them in one quadrant. Then set |simple| appropriately@>;
8278 if ( simple && (abs(arc-v02-halfp(v0+v2)) <= tol) ) {
8279 if ( arc < a_goal ) {
8282 @<Estimate when the arc length reaches |a_goal| and set |arc_test| to
8283 that time minus |two|@>;
8286 @<Use one or two recursive calls to compute the |arc_test| function@>;
8290 @ The |tol| value should by multiplied by $\sqrt 2$ before making recursive
8291 calls, but $1.5$ is an adequate approximation. It is best to avoid using
8292 |make_fraction| in this inner loop.
8295 @<Use one or two recursive calls to compute the |arc_test| function@>=
8297 @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is as
8298 large as possible@>;
8299 tol = tol + halfp(tol);
8300 a = mp_arc_test(mp, dx0,dy0, dx01,dy01, dx02,dy02, v0, v002,
8301 halfp(v02), a_new, tol);
8303 return (-halfp(two-a));
8305 @<Update |a_new| to reduce |a_new+a_aux| by |a|@>;
8306 b = mp_arc_test(mp, dx02,dy02, dx12,dy12, dx2,dy2,
8307 halfp(v02), v022, v2, a_new, tol);
8309 return (-halfp(-b) - half_unit);
8311 return (a + half(b-a));
8315 @ @<Other local variables in |arc_test|@>=
8316 scaled a,b; /* results of recursive calls */
8317 scaled a_new,a_aux; /* the sum of these gives the |a_goal| */
8319 @ @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is...@>=
8320 a_aux = el_gordo - a_goal;
8321 if ( a_goal > a_aux ) {
8322 a_aux = a_goal - a_aux;
8325 a_new = a_goal + a_goal;
8329 @ There is no need to maintain |a_aux| at this point so we use it as a temporary
8330 to force the additions and subtractions to be done in an order that avoids
8333 @<Update |a_new| to reduce |a_new+a_aux| by |a|@>=
8336 a_new = a_new + a_aux;
8339 @ This code assumes all {\it dx} and {\it dy} variables have magnitude less than
8340 |fraction_four|. To simplify the rest of the |arc_test| routine, we strengthen
8341 this assumption by requiring the norm of each $({\it dx},{\it dy})$ pair to obey
8342 this bound. Note that recursive calls will maintain this invariant.
8344 @<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,...@>=
8345 dx01 = half(dx0 + dx1);
8346 dx12 = half(dx1 + dx2);
8347 dx02 = half(dx01 + dx12);
8348 dy01 = half(dy0 + dy1);
8349 dy12 = half(dy1 + dy2);
8350 dy02 = half(dy01 + dy12)
8352 @ We should be careful to keep |arc<el_gordo| so that calling |arc_test| with
8353 |a_goal=el_gordo| is guaranteed to yield the arc length.
8355 @<Initialize |v002|, |v022|, and the arc length estimate |arc|;...@>=
8356 v002 = mp_pyth_add(mp, dx01+half(dx0+dx02), dy01+half(dy0+dy02));
8357 v022 = mp_pyth_add(mp, dx12+half(dx02+dx2), dy12+half(dy02+dy2));
8359 arc1 = v002 + half(halfp(v0+tmp) - v002);
8360 arc = v022 + half(halfp(v2+tmp) - v022);
8361 if ( (arc < el_gordo-arc1) ) {
8364 mp->arith_error = true;
8365 if ( a_goal==el_gordo ) return (el_gordo);
8369 @ @<Other local variables in |arc_test|@>=
8370 scaled tmp, tmp2; /* all purpose temporary registers */
8371 scaled arc1; /* arc length estimate for the first half */
8373 @ @<Test if the control points are confined to one quadrant or rotating...@>=
8374 simple = ((dx0>=0) && (dx1>=0) && (dx2>=0)) ||
8375 ((dx0<=0) && (dx1<=0) && (dx2<=0));
8377 simple = ((dy0>=0) && (dy1>=0) && (dy2>=0)) ||
8378 ((dy0<=0) && (dy1<=0) && (dy2<=0));
8380 simple = ((dx0>=dy0) && (dx1>=dy1) && (dx2>=dy2)) ||
8381 ((dx0<=dy0) && (dx1<=dy1) && (dx2<=dy2));
8383 simple = ((-dx0>=dy0) && (-dx1>=dy1) && (-dx2>=dy2)) ||
8384 ((-dx0<=dy0) && (-dx1<=dy1) && (-dx2<=dy2));
8387 @ Since Simpson's rule is based on approximating the integrand by a parabola,
8389 it is appropriate to use the same approximation to decide when the integral
8390 reaches the intermediate value |a_goal|. At this point
8392 {\vb\dot B(0)\vb\over 3} &= \hbox{|v0|}, \qquad
8393 {\vb\dot B({1\over4})\vb\over 3} = {\hbox{|v002|}\over 2}, \qquad
8394 {\vb\dot B({1\over2})\vb\over 3} = {\hbox{|v02|}\over 2}, \cr
8395 {\vb\dot B({3\over4})\vb\over 3} &= {\hbox{|v022|}\over 2}, \qquad
8396 {\vb\dot B(1)\vb\over 3} = \hbox{|v2|} \cr
8400 $$ {\vb\dot B(t)\vb\over 3} \approx
8401 \cases{B\left(\hbox{|v0|},
8402 \hbox{|v002|}-{1\over 2}\hbox{|v0|}-{1\over 4}\hbox{|v02|},
8403 {1\over 2}\hbox{|v02|}; 2t \right)&
8404 if $t\le{1\over 2}$\cr
8405 B\left({1\over 2}\hbox{|v02|},
8406 \hbox{|v022|}-{1\over 4}\hbox{|v02|}-{1\over 2}\hbox{|v2|},
8407 \hbox{|v2|}; 2t-1 \right)&
8408 if $t\ge{1\over 2}$.\cr}
8411 We can integrate $\vb\dot B(t)\vb$ by using
8412 $$\int 3B(a,b,c;\tau)\,dt =
8413 {B(0,a,a+b,a+b+c;\tau) + {\rm constant} \over {d\tau\over dt}}.
8416 This construction allows us to find the time when the arc length reaches
8417 |a_goal| by solving a cubic equation of the form
8418 $$ B(0,a,a+b,a+b+c;\tau) = x, $$
8419 where $\tau$ is $2t$ or $2t+1$, $x$ is |a_goal| or |a_goal-arc1|, and $a$, $b$,
8420 and $c$ are the Bernshte{\u\i}n coefficients from $(*)$ divided by
8421 @^Bernshte{\u\i}n, Serge{\u\i} Natanovich@>
8422 $d\tau\over dt$. We shall define a function |solve_rising_cubic| that finds
8423 $\tau$ given $a$, $b$, $c$, and $x$.
8425 @<Estimate when the arc length reaches |a_goal| and set |arc_test| to...@>=
8427 tmp = (v02 + 2) / 4;
8428 if ( a_goal<=arc1 ) {
8431 (halfp(mp_solve_rising_cubic(mp, tmp2, arc1-tmp2-tmp, tmp, a_goal))- two);
8434 return ((half_unit - two) +
8435 halfp(mp_solve_rising_cubic(mp, tmp, arc-arc1-tmp-tmp2, tmp2, a_goal-arc1)));
8439 @ Here is the |solve_rising_cubic| routine that finds the time~$t$ when
8440 $$ B(0, a, a+b, a+b+c; t) = x. $$
8441 This routine is based on |crossing_point| but is simplified by the
8442 assumptions that $B(a,b,c;t)\ge0$ for $0\le t\le1$ and that |0<=x<=a+b+c|.
8443 If rounding error causes this condition to be violated slightly, we just ignore
8444 it and proceed with binary search. This finds a time when the function value
8445 reaches |x| and the slope is positive.
8448 static scaled mp_solve_rising_cubic (MP mp,scaled a, scaled b, scaled c, scaled x) ;
8451 scaled mp_solve_rising_cubic (MP mp,scaled a, scaled b, scaled c, scaled x) {
8452 scaled ab, bc, ac; /* bisection results */
8453 integer t; /* $2^k+q$ where unscaled answer is in $[q2^{-k},(q+1)2^{-k})$ */
8454 integer xx; /* temporary for updating |x| */
8455 if ( (a<0) || (c<0) ) mp_confusion(mp, "rising?");
8456 @:this can't happen rising?}{\quad rising?@>
8459 } else if ( x >= a+b+c ) {
8463 @<Rescale if necessary to make sure |a|, |b|, and |c| are all less than
8467 @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>;
8468 xx = x - a - ab - ac;
8469 if ( xx < -x ) { x+=x; b=ab; c=ac; }
8470 else { x = x + xx; a=ac; b=bc; t = t+1; };
8471 } while (t < unity);
8476 @ @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>=
8481 @ @d one_third_el_gordo 05252525252 /* upper bound on |a|, |b|, and |c| */
8483 @<Rescale if necessary to make sure |a|, |b|, and |c| are all less than...@>=
8484 while ((a>one_third_el_gordo)||(b>one_third_el_gordo)||(c>one_third_el_gordo)) {
8491 @ It is convenient to have a simpler interface to |arc_test| that requires no
8492 unnecessary arguments and ensures that each $({\it dx},{\it dy})$ pair has
8493 length less than |fraction_four|.
8495 @d arc_tol 16 /* quit when change in arc length estimate reaches this */
8497 @c static scaled mp_do_arc_test (MP mp,scaled dx0, scaled dy0, scaled dx1,
8498 scaled dy1, scaled dx2, scaled dy2, scaled a_goal) {
8499 scaled v0,v1,v2; /* length of each $({\it dx},{\it dy})$ pair */
8500 scaled v02; /* twice the norm of the quadratic at $t={1\over2}$ */
8501 v0 = mp_pyth_add(mp, dx0,dy0);
8502 v1 = mp_pyth_add(mp, dx1,dy1);
8503 v2 = mp_pyth_add(mp, dx2,dy2);
8504 if ( (v0>=fraction_four) || (v1>=fraction_four) || (v2>=fraction_four) ) {
8505 mp->arith_error = true;
8506 if ( a_goal==el_gordo ) return el_gordo;
8509 v02 = mp_pyth_add(mp, dx1+half(dx0+dx2), dy1+half(dy0+dy2));
8510 return (mp_arc_test(mp, dx0,dy0, dx1,dy1, dx2,dy2,
8511 v0, v02, v2, a_goal, arc_tol));
8515 @ Now it is easy to find the arc length of an entire path.
8517 @c static scaled mp_get_arc_length (MP mp,pointer h) {
8518 pointer p,q; /* for traversing the path */
8519 scaled a,a_tot; /* current and total arc lengths */
8522 while ( right_type(p)!=mp_endpoint ){
8524 a = mp_do_arc_test(mp, right_x(p)-x_coord(p), right_y(p)-y_coord(p),
8525 left_x(q)-right_x(p), left_y(q)-right_y(p),
8526 x_coord(q)-left_x(q), y_coord(q)-left_y(q), el_gordo);
8527 a_tot = mp_slow_add(mp, a, a_tot);
8528 if ( q==h ) break; else p=q;
8534 @ The inverse operation of finding the time on a path~|h| when the arc length
8535 reaches some value |arc0| can also be accomplished via |do_arc_test|. Some care
8536 is required to handle very large times or negative times on cyclic paths. For
8537 non-cyclic paths, |arc0| values that are negative or too large cause
8538 |get_arc_time| to return 0 or the length of path~|h|.
8540 If |arc0| is greater than the arc length of a cyclic path~|h|, the result is a
8541 time value greater than the length of the path. Since it could be much greater,
8542 we must be prepared to compute the arc length of path~|h| and divide this into
8543 |arc0| to find how many multiples of the length of path~|h| to add.
8545 @c static scaled mp_get_arc_time (MP mp,pointer h, scaled arc0) {
8546 pointer p,q; /* for traversing the path */
8547 scaled t_tot; /* accumulator for the result */
8548 scaled t; /* the result of |do_arc_test| */
8549 scaled arc; /* portion of |arc0| not used up so far */
8550 integer n; /* number of extra times to go around the cycle */
8552 @<Deal with a negative |arc0| value and |return|@>;
8554 if ( arc0==el_gordo ) decr(arc0);
8558 while ( (right_type(p)!=mp_endpoint) && (arc>0) ) {
8560 t = mp_do_arc_test(mp, right_x(p)-x_coord(p), right_y(p)-y_coord(p),
8561 left_x(q)-right_x(p), left_y(q)-right_y(p),
8562 x_coord(q)-left_x(q), y_coord(q)-left_y(q), arc);
8563 @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>;
8565 @<Update |t_tot| and |arc| to avoid going around the cyclic
8566 path too many times but set |arith_error:=true| and |goto done| on
8575 @ @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>=
8576 if ( t<0 ) { t_tot = t_tot + t + two; arc = 0; }
8577 else { t_tot = t_tot + unity; arc = arc - t; }
8579 @ @<Deal with a negative |arc0| value and |return|@>=
8581 if ( left_type(h)==mp_endpoint ) {
8584 p = mp_htap_ypoc(mp, h);
8585 t_tot = -mp_get_arc_time(mp, p, -arc0);
8586 mp_toss_knot_list(mp, p);
8592 @ @<Update |t_tot| and |arc| to avoid going around the cyclic...@>=
8594 n = arc / (arc0 - arc);
8595 arc = arc - n*(arc0 - arc);
8596 if ( t_tot > (el_gordo / (n+1)) ) {
8599 t_tot = (n + 1)*t_tot;
8602 @* \[20] Data structures for pens.
8603 A Pen in \MP\ can be either elliptical or polygonal. Elliptical pens result
8604 in \ps\ \&{stroke} commands, while anything drawn with a polygonal pen is
8605 @:stroke}{\&{stroke} command@>
8606 converted into an area fill as described in the next part of this program.
8607 The mathematics behind this process is based on simple aspects of the theory
8608 of tracings developed by Leo Guibas, Lyle Ramshaw, and Jorge Stolfi
8609 [``A kinematic framework for computational geometry,'' Proc.\ IEEE Symp.\
8610 Foundations of Computer Science {\bf 24} (1983), 100--111].
8612 Polygonal pens are created from paths via \MP's \&{makepen} primitive.
8613 @:makepen_}{\&{makepen} primitive@>
8614 This path representation is almost sufficient for our purposes except that
8615 a pen path should always be a convex polygon with the vertices in
8616 counter-clockwise order.
8617 Since we will need to scan pen polygons both forward and backward, a pen
8618 should be represented as a doubly linked ring of knot nodes. There is
8619 room for the extra back pointer because we do not need the
8620 |left_type| or |right_type| fields. In fact, we don't need the |left_x|,
8621 |left_y|, |right_x|, or |right_y| fields either but we leave these alone
8622 so that certain procedures can operate on both pens and paths. In particular,
8623 pens can be copied using |copy_path| and recycled using |toss_knot_list|.
8626 /* this replaces the |left_type| and |right_type| fields in a pen knot */
8628 @ The |make_pen| procedure turns a path into a pen by initializing
8629 the |knil| pointers and making sure the knots form a convex polygon.
8630 Thus each cubic in the given path becomes a straight line and the control
8631 points are ignored. If the path is not cyclic, the ends are connected by a
8634 @d copy_pen(A) mp_make_pen(mp, mp_copy_path(mp, (A)),false)
8637 static pointer mp_make_pen (MP mp,pointer h, boolean need_hull) {
8638 pointer p,q; /* two consecutive knots */
8645 h=mp_convex_hull(mp, h);
8646 @<Make sure |h| isn't confused with an elliptical pen@>;
8651 @ The only information required about an elliptical pen is the overall
8652 transformation that has been applied to the original \&{pencircle}.
8653 @:pencircle_}{\&{pencircle} primitive@>
8654 Since it suffices to keep track of how the three points $(0,0)$, $(1,0)$,
8655 and $(0,1)$ are transformed, an elliptical pen can be stored in a single
8656 knot node and transformed as if it were a path.
8658 @d pen_is_elliptical(A) ((A)==mp_link((A)))
8661 static pointer mp_get_pen_circle (MP mp,scaled diam) {
8662 pointer h; /* the knot node to return */
8663 h=mp_get_node(mp, knot_node_size);
8664 mp_link(h)=h; knil(h)=h;
8665 originator(h)=mp_program_code;
8666 x_coord(h)=0; y_coord(h)=0;
8667 left_x(h)=diam; left_y(h)=0;
8668 right_x(h)=0; right_y(h)=diam;
8672 @ If the polygon being returned by |make_pen| has only one vertex, it will
8673 be interpreted as an elliptical pen. This is no problem since a degenerate
8674 polygon can equally well be thought of as a degenerate ellipse. We need only
8675 initialize the |left_x|, |left_y|, |right_x|, and |right_y| fields.
8677 @<Make sure |h| isn't confused with an elliptical pen@>=
8678 if ( pen_is_elliptical( h) ){
8679 left_x(h)=x_coord(h); left_y(h)=y_coord(h);
8680 right_x(h)=x_coord(h); right_y(h)=y_coord(h);
8683 @ We have to cheat a little here but most operations on pens only use
8684 the first three words in each knot node.
8685 @^data structure assumptions@>
8687 @<Initialize a pen at |test_pen| so that it fits in nine words@>=
8688 x_coord(test_pen)=-half_unit;
8689 y_coord(test_pen)=0;
8690 x_coord(test_pen+3)=half_unit;
8691 y_coord(test_pen+3)=0;
8692 x_coord(test_pen+6)=0;
8693 y_coord(test_pen+6)=unity;
8694 mp_link(test_pen)=test_pen+3;
8695 mp_link(test_pen+3)=test_pen+6;
8696 mp_link(test_pen+6)=test_pen;
8697 knil(test_pen)=test_pen+6;
8698 knil(test_pen+3)=test_pen;
8699 knil(test_pen+6)=test_pen+3
8701 @ Printing a polygonal pen is very much like printing a path
8704 static void mp_pr_pen (MP mp,pointer h) ;
8707 void mp_pr_pen (MP mp,pointer h) {
8708 pointer p,q; /* for list traversal */
8709 if ( pen_is_elliptical(h) ) {
8710 @<Print the elliptical pen |h|@>;
8714 mp_print_two(mp, x_coord(p),y_coord(p));
8715 mp_print_nl(mp, " .. ");
8716 @<Advance |p| making sure the links are OK and |return| if there is
8719 mp_print(mp, "cycle");
8723 @ @<Advance |p| making sure the links are OK and |return| if there is...@>=
8725 if ( (q==null) || (knil(q)!=p) ) {
8726 mp_print_nl(mp, "???"); return; /* this won't happen */
8731 @ @<Print the elliptical pen |h|@>=
8733 mp_print(mp, "pencircle transformed (");
8734 mp_print_scaled(mp, x_coord(h));
8735 mp_print_char(mp, xord(','));
8736 mp_print_scaled(mp, y_coord(h));
8737 mp_print_char(mp, xord(','));
8738 mp_print_scaled(mp, left_x(h)-x_coord(h));
8739 mp_print_char(mp, xord(','));
8740 mp_print_scaled(mp, right_x(h)-x_coord(h));
8741 mp_print_char(mp, xord(','));
8742 mp_print_scaled(mp, left_y(h)-y_coord(h));
8743 mp_print_char(mp, xord(','));
8744 mp_print_scaled(mp, right_y(h)-y_coord(h));
8745 mp_print_char(mp, xord(')'));
8748 @ Here us another version of |pr_pen| that prints the pen as a diagnostic
8752 static void mp_print_pen (MP mp,pointer h, const char *s, boolean nuline) ;
8755 void mp_print_pen (MP mp,pointer h, const char *s, boolean nuline) {
8756 mp_print_diagnostic(mp, "Pen",s,nuline); mp_print_ln(mp);
8759 mp_end_diagnostic(mp, true);
8762 @ Making a polygonal pen into a path involves restoring the |left_type| and
8763 |right_type| fields and setting the control points so as to make a polygonal
8767 static void mp_make_path (MP mp,pointer h) {
8768 pointer p; /* for traversing the knot list */
8769 quarterword k; /* a loop counter */
8770 @<Other local variables in |make_path|@>;
8771 if ( pen_is_elliptical(h) ) {
8772 @<Make the elliptical pen |h| into a path@>;
8776 left_type(p)=mp_explicit;
8777 right_type(p)=mp_explicit;
8778 @<copy the coordinates of knot |p| into its control points@>;
8784 @ @<copy the coordinates of knot |p| into its control points@>=
8785 left_x(p)=x_coord(p);
8786 left_y(p)=y_coord(p);
8787 right_x(p)=x_coord(p);
8788 right_y(p)=y_coord(p)
8790 @ We need an eight knot path to get a good approximation to an ellipse.
8792 @<Make the elliptical pen |h| into a path@>=
8794 @<Extract the transformation parameters from the elliptical pen~|h|@>;
8796 for (k=0;k<=7;k++ ) {
8797 @<Initialize |p| as the |k|th knot of a circle of unit diameter,
8798 transforming it appropriately@>;
8799 if ( k==7 ) mp_link(p)=h; else mp_link(p)=mp_get_node(mp, knot_node_size);
8804 @ @<Extract the transformation parameters from the elliptical pen~|h|@>=
8805 center_x=x_coord(h);
8806 center_y=y_coord(h);
8807 width_x=left_x(h)-center_x;
8808 width_y=left_y(h)-center_y;
8809 height_x=right_x(h)-center_x;
8810 height_y=right_y(h)-center_y
8812 @ @<Other local variables in |make_path|@>=
8813 scaled center_x,center_y; /* translation parameters for an elliptical pen */
8814 scaled width_x,width_y; /* the effect of a unit change in $x$ */
8815 scaled height_x,height_y; /* the effect of a unit change in $y$ */
8816 scaled dx,dy; /* the vector from knot |p| to its right control point */
8818 /* |k| advanced $270^\circ$ around the ring (cf. $\sin\theta=\cos(\theta+270)$) */
8820 @ The only tricky thing here are the tables |half_cos| and |d_cos| used to
8821 find the point $k/8$ of the way around the circle and the direction vector
8824 @<Initialize |p| as the |k|th knot of a circle of unit diameter,...@>=
8826 x_coord(p)=center_x+mp_take_fraction(mp, mp->half_cos[k],width_x)
8827 +mp_take_fraction(mp, mp->half_cos[kk],height_x);
8828 y_coord(p)=center_y+mp_take_fraction(mp, mp->half_cos[k],width_y)
8829 +mp_take_fraction(mp, mp->half_cos[kk],height_y);
8830 dx=-mp_take_fraction(mp, mp->d_cos[kk],width_x)
8831 +mp_take_fraction(mp, mp->d_cos[k],height_x);
8832 dy=-mp_take_fraction(mp, mp->d_cos[kk],width_y)
8833 +mp_take_fraction(mp, mp->d_cos[k],height_y);
8834 right_x(p)=x_coord(p)+dx;
8835 right_y(p)=y_coord(p)+dy;
8836 left_x(p)=x_coord(p)-dx;
8837 left_y(p)=y_coord(p)-dy;
8838 left_type(p)=mp_explicit;
8839 right_type(p)=mp_explicit;
8840 originator(p)=mp_program_code
8843 fraction half_cos[8]; /* ${1\over2}\cos(45k)$ */
8844 fraction d_cos[8]; /* a magic constant times $\cos(45k)$ */
8846 @ The magic constant for |d_cos| is the distance between $({1\over2},0)$ and
8847 $({1\over4}\sqrt2,{1\over4}\sqrt2)$ times the result of the |velocity|
8848 function for $\theta=\phi=22.5^\circ$. This comes out to be
8849 $$ d = {\sqrt{2-\sqrt2}\over 3+3\cos22.5^\circ}
8850 \approx 0.132608244919772.
8854 mp->half_cos[0]=fraction_half;
8855 mp->half_cos[1]=94906266; /* $2^{26}\sqrt2\approx94906265.62$ */
8857 mp->d_cos[0]=35596755; /* $2^{28}d\approx35596754.69$ */
8858 mp->d_cos[1]=25170707; /* $2^{27}\sqrt2\,d\approx25170706.63$ */
8860 for (k=3;k<= 4;k++ ) {
8861 mp->half_cos[k]=-mp->half_cos[4-k];
8862 mp->d_cos[k]=-mp->d_cos[4-k];
8864 for (k=5;k<= 7;k++ ) {
8865 mp->half_cos[k]=mp->half_cos[8-k];
8866 mp->d_cos[k]=mp->d_cos[8-k];
8869 @ The |convex_hull| function forces a pen polygon to be convex when it is
8870 returned by |make_pen| and after any subsequent transformation where rounding
8871 error might allow the convexity to be lost.
8872 The convex hull algorithm used here is described by F.~P. Preparata and
8873 M.~I. Shamos [{\sl Computational Geometry}, Springer-Verlag, 1985].
8876 static pointer mp_convex_hull (MP mp,pointer h);
8879 pointer mp_convex_hull (MP mp,pointer h) { /* Make a polygonal pen convex */
8880 pointer l,r; /* the leftmost and rightmost knots */
8881 pointer p,q; /* knots being scanned */
8882 pointer s; /* the starting point for an upcoming scan */
8883 scaled dx,dy; /* a temporary pointer */
8884 if ( pen_is_elliptical(h) ) {
8887 @<Set |l| to the leftmost knot in polygon~|h|@>;
8888 @<Set |r| to the rightmost knot in polygon~|h|@>;
8891 @<Find any knots on the path from |l| to |r| above the |l|-|r| line and
8892 move them past~|r|@>;
8893 @<Find any knots on the path from |s| to |l| below the |l|-|r| line and
8894 move them past~|l|@>;
8895 @<Sort the path from |l| to |r| by increasing $x$@>;
8896 @<Sort the path from |r| to |l| by decreasing $x$@>;
8898 if ( l!=mp_link(l) ) {
8899 @<Do a Gramm scan and remove vertices where there is no left turn@>;
8905 @ All comparisons are done primarily on $x$ and secondarily on $y$.
8907 @<Set |l| to the leftmost knot in polygon~|h|@>=
8911 if ( x_coord(p)<=x_coord(l) )
8912 if ( (x_coord(p)<x_coord(l)) || (y_coord(p)<y_coord(l)) )
8917 @ @<Set |r| to the rightmost knot in polygon~|h|@>=
8921 if ( x_coord(p)>=x_coord(r) )
8922 if ( (x_coord(p)>x_coord(r)) || (y_coord(p)>y_coord(r)) )
8927 @ @<Find any knots on the path from |l| to |r| above the |l|-|r| line...@>=
8928 dx=x_coord(r)-x_coord(l);
8929 dy=y_coord(r)-y_coord(l);
8933 if ( mp_ab_vs_cd(mp, dx,y_coord(p)-y_coord(l),dy,x_coord(p)-x_coord(l))>0 )
8934 mp_move_knot(mp, p, r);
8938 @ The |move_knot| procedure removes |p| from a doubly linked list and inserts
8942 static void mp_move_knot (MP mp,pointer p, pointer q) ;
8945 void mp_move_knot (MP mp,pointer p, pointer q) {
8946 mp_link(knil(p))=mp_link(p);
8947 knil(mp_link(p))=knil(p);
8949 mp_link(p)=mp_link(q);
8954 @ @<Find any knots on the path from |s| to |l| below the |l|-|r| line...@>=
8958 if ( mp_ab_vs_cd(mp, dx,y_coord(p)-y_coord(l),dy,x_coord(p)-x_coord(l))<0 )
8959 mp_move_knot(mp, p,l);
8963 @ The list is likely to be in order already so we just do linear insertions.
8964 Secondary comparisons on $y$ ensure that the sort is consistent with the
8965 choice of |l| and |r|.
8967 @<Sort the path from |l| to |r| by increasing $x$@>=
8971 while ( x_coord(q)>x_coord(p) ) q=knil(q);
8972 while ( x_coord(q)==x_coord(p) ) {
8973 if ( y_coord(q)>y_coord(p) ) q=knil(q); else break;
8975 if ( q==knil(p) ) p=mp_link(p);
8976 else { p=mp_link(p); mp_move_knot(mp, knil(p),q); };
8979 @ @<Sort the path from |r| to |l| by decreasing $x$@>=
8983 while ( x_coord(q)<x_coord(p) ) q=knil(q);
8984 while ( x_coord(q)==x_coord(p) ) {
8985 if ( y_coord(q)<y_coord(p) ) q=knil(q); else break;
8987 if ( q==knil(p) ) p=mp_link(p);
8988 else { p=mp_link(p); mp_move_knot(mp, knil(p),q); };
8991 @ The condition involving |ab_vs_cd| tests if there is not a left turn
8992 at knot |q|. There usually will be a left turn so we streamline the case
8993 where the |then| clause is not executed.
8995 @<Do a Gramm scan and remove vertices where there...@>=
8999 dx=x_coord(q)-x_coord(p);
9000 dy=y_coord(q)-y_coord(p);
9004 if ( mp_ab_vs_cd(mp, dx,y_coord(q)-y_coord(p),dy,x_coord(q)-x_coord(p))<=0 ) {
9005 @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>;
9010 @ @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>=
9013 mp_free_node(mp, p,knot_node_size);
9014 mp_link(s)=q; knil(q)=s;
9016 else { p=knil(s); q=s; };
9019 @ The |find_offset| procedure sets global variables |(cur_x,cur_y)| to the
9020 offset associated with the given direction |(x,y)|. If two different offsets
9021 apply, it chooses one of them.
9024 static void mp_find_offset (MP mp,scaled x, scaled y, pointer h) {
9025 pointer p,q; /* consecutive knots */
9027 /* the transformation matrix for an elliptical pen */
9028 fraction xx,yy; /* untransformed offset for an elliptical pen */
9029 fraction d; /* a temporary register */
9030 if ( pen_is_elliptical(h) ) {
9031 @<Find the offset for |(x,y)| on the elliptical pen~|h|@>
9036 } while (!(mp_ab_vs_cd(mp, x_coord(q)-x_coord(p),y, y_coord(q)-y_coord(p),x)>=0));
9039 } while (!(mp_ab_vs_cd(mp, x_coord(q)-x_coord(p),y, y_coord(q)-y_coord(p),x)<=0));
9040 mp->cur_x=x_coord(p);
9041 mp->cur_y=y_coord(p);
9047 scaled cur_y; /* all-purpose return value registers */
9049 @ @<Find the offset for |(x,y)| on the elliptical pen~|h|@>=
9050 if ( (x==0) && (y==0) ) {
9051 mp->cur_x=x_coord(h); mp->cur_y=y_coord(h);
9053 @<Find the non-constant part of the transformation for |h|@>;
9054 while ( (abs(x)<fraction_half) && (abs(y)<fraction_half) ){
9057 @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the
9058 untransformed version of |(x,y)|@>;
9059 mp->cur_x=x_coord(h)+mp_take_fraction(mp, xx,wx)+mp_take_fraction(mp, yy,hx);
9060 mp->cur_y=y_coord(h)+mp_take_fraction(mp, xx,wy)+mp_take_fraction(mp, yy,hy);
9063 @ @<Find the non-constant part of the transformation for |h|@>=
9064 wx=left_x(h)-x_coord(h);
9065 wy=left_y(h)-y_coord(h);
9066 hx=right_x(h)-x_coord(h);
9067 hy=right_y(h)-y_coord(h)
9069 @ @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the...@>=
9070 yy=-(mp_take_fraction(mp, x,hy)+mp_take_fraction(mp, y,-hx));
9071 xx=mp_take_fraction(mp, x,-wy)+mp_take_fraction(mp, y,wx);
9072 d=mp_pyth_add(mp, xx,yy);
9074 xx=half(mp_make_fraction(mp, xx,d));
9075 yy=half(mp_make_fraction(mp, yy,d));
9078 @ Finding the bounding box of a pen is easy except if the pen is elliptical.
9079 But we can handle that case by just calling |find_offset| twice. The answer
9080 is stored in the global variables |minx|, |maxx|, |miny|, and |maxy|.
9083 static void mp_pen_bbox (MP mp,pointer h) {
9084 pointer p; /* for scanning the knot list */
9085 if ( pen_is_elliptical(h) ) {
9086 @<Find the bounding box of an elliptical pen@>;
9088 minx=x_coord(h); maxx=minx;
9089 miny=y_coord(h); maxy=miny;
9092 if ( x_coord(p)<minx ) minx=x_coord(p);
9093 if ( y_coord(p)<miny ) miny=y_coord(p);
9094 if ( x_coord(p)>maxx ) maxx=x_coord(p);
9095 if ( y_coord(p)>maxy ) maxy=y_coord(p);
9101 @ @<Find the bounding box of an elliptical pen@>=
9103 mp_find_offset(mp, 0,fraction_one,h);
9105 minx=2*x_coord(h)-mp->cur_x;
9106 mp_find_offset(mp, -fraction_one,0,h);
9108 miny=2*y_coord(h)-mp->cur_y;
9111 @* \[21] Edge structures.
9112 Now we come to \MP's internal scheme for representing pictures.
9113 The representation is very different from \MF's edge structures
9114 because \MP\ pictures contain \ps\ graphics objects instead of pixel
9115 images. However, the basic idea is somewhat similar in that shapes
9116 are represented via their boundaries.
9118 The main purpose of edge structures is to keep track of graphical objects
9119 until it is time to translate them into \ps. Since \MP\ does not need to
9120 know anything about an edge structure other than how to translate it into
9121 \ps\ and how to find its bounding box, edge structures can be just linked
9122 lists of graphical objects. \MP\ has no easy way to determine whether
9123 two such objects overlap, but it suffices to draw the first one first and
9124 let the second one overwrite it if necessary.
9127 enum mp_graphical_object_code {
9128 @<Graphical object codes@>
9132 @ Let's consider the types of graphical objects one at a time.
9133 First of all, a filled contour is represented by a eight-word node. The first
9134 word contains |type| and |link| fields, and the next six words contain a
9135 pointer to a cyclic path and the value to use for \ps' \&{currentrgbcolor}
9136 parameter. If a pen is used for filling |pen_p|, |ljoin_val| and |miterlim_val|
9137 give the relevant information.
9139 @d path_p(A) mp_link((A)+1)
9140 /* a pointer to the path that needs filling */
9141 @d pen_p(A) info((A)+1)
9142 /* a pointer to the pen to fill or stroke with */
9143 @d color_model(A) type((A)+2) /* the color model */
9144 @d obj_red_loc(A) ((A)+3) /* the first of three locations for the color */
9145 @d obj_cyan_loc obj_red_loc /* the first of four locations for the color */
9146 @d obj_grey_loc obj_red_loc /* the location for the color */
9147 @d red_val(A) mp->mem[(A)+3].sc
9148 /* the red component of the color in the range $0\ldots1$ */
9151 @d green_val(A) mp->mem[(A)+4].sc
9152 /* the green component of the color in the range $0\ldots1$ */
9153 @d magenta_val green_val
9154 @d blue_val(A) mp->mem[(A)+5].sc
9155 /* the blue component of the color in the range $0\ldots1$ */
9156 @d yellow_val blue_val
9157 @d black_val(A) mp->mem[(A)+6].sc
9158 /* the blue component of the color in the range $0\ldots1$ */
9159 @d ljoin_val(A) name_type((A)) /* the value of \&{linejoin} */
9160 @:mp_linejoin_}{\&{linejoin} primitive@>
9161 @d miterlim_val(A) mp->mem[(A)+7].sc /* the value of \&{miterlimit} */
9162 @:mp_miterlimit_}{\&{miterlimit} primitive@>
9163 @d obj_color_part(A) mp->mem[(A)+3-red_part].sc
9164 /* interpret an object pointer that has been offset by |red_part..blue_part| */
9165 @d pre_script(A) mp->mem[(A)+8].hh.lh
9166 @d post_script(A) mp->mem[(A)+8].hh.rh
9169 @ @<Graphical object codes@>=
9173 static pointer mp_new_fill_node (MP mp,pointer p) {
9174 /* make a fill node for cyclic path |p| and color black */
9175 pointer t; /* the new node */
9176 t=mp_get_node(mp, fill_node_size);
9177 type(t)=mp_fill_code;
9179 pen_p(t)=null; /* |null| means don't use a pen */
9184 color_model(t)=mp_uninitialized_model;
9186 post_script(t)=null;
9187 @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>;
9191 @ @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>=
9192 if ( mp->internal[mp_linejoin]>unity ) ljoin_val(t)=2;
9193 else if ( mp->internal[mp_linejoin]>0 ) ljoin_val(t)=1;
9194 else ljoin_val(t)=0;
9195 if ( mp->internal[mp_miterlimit]<unity )
9196 miterlim_val(t)=unity;
9198 miterlim_val(t)=mp->internal[mp_miterlimit]
9200 @ A stroked path is represented by an eight-word node that is like a filled
9201 contour node except that it contains the current \&{linecap} value, a scale
9202 factor for the dash pattern, and a pointer that is non-null if the stroke
9203 is to be dashed. The purpose of the scale factor is to allow a picture to
9204 be transformed without touching the picture that |dash_p| points to.
9206 @d dash_p(A) mp_link((A)+9)
9207 /* a pointer to the edge structure that gives the dash pattern */
9208 @d lcap_val(A) type((A)+9)
9209 /* the value of \&{linecap} */
9210 @:mp_linecap_}{\&{linecap} primitive@>
9211 @d dash_scale(A) mp->mem[(A)+10].sc /* dash lengths are scaled by this factor */
9212 @d stroked_node_size 11
9214 @ @<Graphical object codes@>=
9218 static pointer mp_new_stroked_node (MP mp,pointer p) {
9219 /* make a stroked node for path |p| with |pen_p(p)| temporarily |null| */
9220 pointer t; /* the new node */
9221 t=mp_get_node(mp, stroked_node_size);
9222 type(t)=mp_stroked_code;
9223 path_p(t)=p; pen_p(t)=null;
9225 dash_scale(t)=unity;
9230 color_model(t)=mp_uninitialized_model;
9232 post_script(t)=null;
9233 @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>;
9234 if ( mp->internal[mp_linecap]>unity ) lcap_val(t)=2;
9235 else if ( mp->internal[mp_linecap]>0 ) lcap_val(t)=1;
9240 @ When a dashed line is computed in a transformed coordinate system, the dash
9241 lengths get scaled like the pen shape and we need to compensate for this. Since
9242 there is no unique scale factor for an arbitrary transformation, we use the
9243 the square root of the determinant. The properties of the determinant make it
9244 easier to maintain the |dash_scale|. The computation is fairly straight-forward
9245 except for the initialization of the scale factor |s|. The factor of 64 is
9246 needed because |square_rt| scales its result by $2^8$ while we need $2^{14}$
9247 to counteract the effect of |take_fraction|.
9250 scaled mp_sqrt_det (MP mp,scaled a, scaled b, scaled c, scaled d) {
9251 scaled maxabs; /* $max(|a|,|b|,|c|,|d|)$ */
9252 unsigned s; /* amount by which the result of |square_rt| needs to be scaled */
9253 @<Initialize |maxabs|@>;
9255 while ( (maxabs<fraction_one) && (s>1) ){
9256 a+=a; b+=b; c+=c; d+=d;
9257 maxabs+=maxabs; s=(unsigned)(halfp(s));
9259 return (scaled)(s*mp_square_rt(mp, abs(mp_take_fraction(mp, a,d)-mp_take_fraction(mp, b,c))));
9262 static scaled mp_get_pen_scale (MP mp,pointer p) {
9263 return mp_sqrt_det(mp,
9264 left_x(p)-x_coord(p), right_x(p)-x_coord(p),
9265 left_y(p)-y_coord(p), right_y(p)-y_coord(p));
9269 static scaled mp_sqrt_det (MP mp,scaled a, scaled b, scaled c, scaled d) ;
9272 @ @<Initialize |maxabs|@>=
9274 if ( abs(b)>maxabs ) maxabs=abs(b);
9275 if ( abs(c)>maxabs ) maxabs=abs(c);
9276 if ( abs(d)>maxabs ) maxabs=abs(d)
9278 @ When a picture contains text, this is represented by a fourteen-word node
9279 where the color information and |type| and |link| fields are augmented by
9280 additional fields that describe the text and how it is transformed.
9281 The |path_p| and |pen_p| pointers are replaced by a number that identifies
9282 the font and a string number that gives the text to be displayed.
9283 The |width|, |height|, and |depth| fields
9284 give the dimensions of the text at its design size, and the remaining six
9285 words give a transformation to be applied to the text. The |new_text_node|
9286 function initializes everything to default values so that the text comes out
9287 black with its reference point at the origin.
9289 @d text_p(A) mp_link((A)+1) /* a string pointer for the text to display */
9290 @d font_n(A) info((A)+1) /* the font number */
9291 @d width_val(A) mp->mem[(A)+7].sc /* unscaled width of the text */
9292 @d height_val(A) mp->mem[(A)+9].sc /* unscaled height of the text */
9293 @d depth_val(A) mp->mem[(A)+10].sc /* unscaled depth of the text */
9294 @d text_tx_loc(A) ((A)+11)
9295 /* the first of six locations for transformation parameters */
9296 @d tx_val(A) mp->mem[(A)+11].sc /* $x$ shift amount */
9297 @d ty_val(A) mp->mem[(A)+12].sc /* $y$ shift amount */
9298 @d txx_val(A) mp->mem[(A)+13].sc /* |txx| transformation parameter */
9299 @d txy_val(A) mp->mem[(A)+14].sc /* |txy| transformation parameter */
9300 @d tyx_val(A) mp->mem[(A)+15].sc /* |tyx| transformation parameter */
9301 @d tyy_val(A) mp->mem[(A)+16].sc /* |tyy| transformation parameter */
9302 @d text_trans_part(A) mp->mem[(A)+11-x_part].sc
9303 /* interpret a text node pointer that has been offset by |x_part..yy_part| */
9304 @d text_node_size 17
9306 @ @<Graphical object codes@>=
9310 static pointer mp_new_text_node (MP mp,char *f,str_number s) {
9311 /* make a text node for font |f| and text string |s| */
9312 pointer t; /* the new node */
9313 t=mp_get_node(mp, text_node_size);
9314 type(t)=mp_text_code;
9316 font_n(t)=(halfword)mp_find_font(mp, f); /* this identifies the font */
9321 color_model(t)=mp_uninitialized_model;
9323 post_script(t)=null;
9324 tx_val(t)=0; ty_val(t)=0;
9325 txx_val(t)=unity; txy_val(t)=0;
9326 tyx_val(t)=0; tyy_val(t)=unity;
9327 mp_set_text_box(mp, t); /* this finds the bounding box */
9331 @ The last two types of graphical objects that can occur in an edge structure
9332 are clipping paths and \&{setbounds} paths. These are slightly more difficult
9333 @:set_bounds_}{\&{setbounds} primitive@>
9334 to implement because we must keep track of exactly what is being clipped or
9335 bounded when pictures get merged together. For this reason, each clipping or
9336 \&{setbounds} operation is represented by a pair of nodes: first comes a
9337 two-word node whose |path_p| gives the relevant path, then there is the list
9338 of objects to clip or bound followed by a two-word node whose second word is
9341 Using at least two words for each graphical object node allows them all to be
9342 allocated and deallocated similarly with a global array |gr_object_size| to
9343 give the size in words for each object type.
9345 @d start_clip_size 2
9346 @d start_bounds_size 2
9347 @d stop_clip_size 2 /* the second word is not used here */
9348 @d stop_bounds_size 2 /* the second word is not used here */
9350 @d stop_type(A) ((A)+2)
9351 /* matching |type| for |start_clip_code| or |start_bounds_code| */
9352 @d has_color(A) (type((A))<mp_start_clip_code)
9353 /* does a graphical object have color fields? */
9354 @d has_pen(A) (type((A))<mp_text_code)
9355 /* does a graphical object have a |pen_p| field? */
9356 @d is_start_or_stop(A) (type((A))>=mp_start_clip_code)
9357 @d is_stop(A) (type((A))>=mp_stop_clip_code)
9359 @ @<Graphical object codes@>=
9360 mp_start_clip_code=4, /* |type| of a node that starts clipping */
9361 mp_start_bounds_code=5, /* |type| of a node that gives a \&{setbounds} path */
9362 mp_stop_clip_code=6, /* |type| of a node that stops clipping */
9363 mp_stop_bounds_code=7, /* |type| of a node that stops \&{setbounds} */
9366 static pointer mp_new_bounds_node (MP mp,pointer p, quarterword c) {
9367 /* make a node of type |c| where |p| is the clipping or \&{setbounds} path */
9368 pointer t; /* the new node */
9369 t=mp_get_node(mp, mp->gr_object_size[c]);
9375 @ We need an array to keep track of the sizes of graphical objects.
9378 quarterword gr_object_size[mp_stop_bounds_code+1];
9381 mp->gr_object_size[mp_fill_code]=fill_node_size;
9382 mp->gr_object_size[mp_stroked_code]=stroked_node_size;
9383 mp->gr_object_size[mp_text_code]=text_node_size;
9384 mp->gr_object_size[mp_start_clip_code]=start_clip_size;
9385 mp->gr_object_size[mp_stop_clip_code]=stop_clip_size;
9386 mp->gr_object_size[mp_start_bounds_code]=start_bounds_size;
9387 mp->gr_object_size[mp_stop_bounds_code]=stop_bounds_size;
9389 @ All the essential information in an edge structure is encoded as a linked list
9390 of graphical objects as we have just seen, but it is helpful to add some
9391 redundant information. A single edge structure might be used as a dash pattern
9392 many times, and it would be nice to avoid scanning the same structure
9393 repeatedly. Thus, an edge structure known to be a suitable dash pattern
9394 has a header that gives a list of dashes in a sorted order designed for rapid
9395 translation into \ps.
9397 Each dash is represented by a three-word node containing the initial and final
9398 $x$~coordinates as well as the usual |link| field. The |link| fields points to
9399 the dash node with the next higher $x$-coordinates and the final link points
9400 to a special location called |null_dash|. (There should be no overlap between
9401 dashes). Since the $y$~coordinate of the dash pattern is needed to determine
9402 the period of repetition, this needs to be stored in the edge header along
9403 with a pointer to the list of dash nodes.
9405 @d start_x(A) mp->mem[(A)+1].sc /* the starting $x$~coordinate in a dash node */
9406 @d stop_x(A) mp->mem[(A)+2].sc /* the ending $x$~coordinate in a dash node */
9408 @d dash_list mp_link
9409 /* in an edge header this points to the first dash node */
9410 @d dash_y(A) mp->mem[(A)+1].sc /* $y$ value for the dash list in an edge header */
9412 @ It is also convenient for an edge header to contain the bounding
9413 box information needed by the \&{llcorner} and \&{urcorner} operators
9414 so that this does not have to be recomputed unnecessarily. This is done by
9415 adding fields for the $x$~and $y$ extremes as well as a pointer that indicates
9416 how far the bounding box computation has gotten. Thus if the user asks for
9417 the bounding box and then adds some more text to the picture before asking
9418 for more bounding box information, the second computation need only look at
9419 the additional text.
9421 When the bounding box has not been computed, the |bblast| pointer points
9422 to a dummy link at the head of the graphical object list while the |minx_val|
9423 and |miny_val| fields contain |el_gordo| and the |maxx_val| and |maxy_val|
9424 fields contain |-el_gordo|.
9426 Since the bounding box of pictures containing objects of type
9427 |mp_start_bounds_code| depends on the value of \&{truecorners}, the bounding box
9428 @:mp_true_corners_}{\&{truecorners} primitive@>
9429 data might not be valid for all values of this parameter. Hence, the |bbtype|
9430 field is needed to keep track of this.
9432 @d minx_val(A) mp->mem[(A)+2].sc
9433 @d miny_val(A) mp->mem[(A)+3].sc
9434 @d maxx_val(A) mp->mem[(A)+4].sc
9435 @d maxy_val(A) mp->mem[(A)+5].sc
9436 @d bblast(A) mp_link((A)+6) /* last item considered in bounding box computation */
9437 @d bbtype(A) info((A)+6) /* tells how bounding box data depends on \&{truecorners} */
9438 @d dummy_loc(A) ((A)+7) /* where the object list begins in an edge header */
9440 /* |bbtype| value when bounding box data is valid for all \&{truecorners} values */
9442 /* |bbtype| value when bounding box data is for \&{truecorners}${}\le 0$ */
9444 /* |bbtype| value when bounding box data is for \&{truecorners}${}>0$ */
9447 static void mp_init_bbox (MP mp,pointer h) {
9448 /* Initialize the bounding box information in edge structure |h| */
9449 bblast(h)=dummy_loc(h);
9450 bbtype(h)=no_bounds;
9451 minx_val(h)=el_gordo;
9452 miny_val(h)=el_gordo;
9453 maxx_val(h)=-el_gordo;
9454 maxy_val(h)=-el_gordo;
9457 @ The only other entries in an edge header are a reference count in the first
9458 word and a pointer to the tail of the object list in the last word.
9460 @d obj_tail(A) info((A)+7) /* points to the last entry in the object list */
9461 @d edge_header_size 8
9464 static void mp_init_edges (MP mp,pointer h) {
9465 /* initialize an edge header to null values */
9466 dash_list(h)=null_dash;
9467 obj_tail(h)=dummy_loc(h);
9468 mp_link(dummy_loc(h))=null;
9470 mp_init_bbox(mp, h);
9473 @ Here is how edge structures are deleted. The process can be recursive because
9474 of the need to dereference edge structures that are used as dash patterns.
9477 @d add_edge_ref(A) incr(ref_count(A))
9478 @d delete_edge_ref(A) {
9479 if ( ref_count((A))==null )
9480 mp_toss_edges(mp, A);
9486 static void mp_flush_dash_list (MP mp,pointer h);
9487 static pointer mp_toss_gr_object (MP mp,pointer p) ;
9488 static void mp_toss_edges (MP mp,pointer h) ;
9490 @ @c void mp_toss_edges (MP mp,pointer h) {
9491 pointer p,q; /* pointers that scan the list being recycled */
9492 pointer r; /* an edge structure that object |p| refers to */
9493 mp_flush_dash_list(mp, h);
9494 q=mp_link(dummy_loc(h));
9495 while ( (q!=null) ) {
9497 r=mp_toss_gr_object(mp, p);
9498 if ( r!=null ) delete_edge_ref(r);
9500 mp_free_node(mp, h,edge_header_size);
9502 void mp_flush_dash_list (MP mp,pointer h) {
9503 pointer p,q; /* pointers that scan the list being recycled */
9505 while ( q!=null_dash ) {
9507 mp_free_node(mp, p,dash_node_size);
9509 dash_list(h)=null_dash;
9511 pointer mp_toss_gr_object (MP mp,pointer p) {
9512 /* returns an edge structure that needs to be dereferenced */
9513 pointer e; /* the edge structure to return */
9515 @<Prepare to recycle graphical object |p|@>;
9516 mp_free_node(mp, p,mp->gr_object_size[type(p)]);
9520 @ @<Prepare to recycle graphical object |p|@>=
9523 mp_toss_knot_list(mp, path_p(p));
9524 if ( pen_p(p)!=null ) mp_toss_knot_list(mp, pen_p(p));
9525 if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
9526 if ( post_script(p)!=null ) delete_str_ref(post_script(p));
9528 case mp_stroked_code:
9529 mp_toss_knot_list(mp, path_p(p));
9530 if ( pen_p(p)!=null ) mp_toss_knot_list(mp, pen_p(p));
9531 if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
9532 if ( post_script(p)!=null ) delete_str_ref(post_script(p));
9536 delete_str_ref(text_p(p));
9537 if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
9538 if ( post_script(p)!=null ) delete_str_ref(post_script(p));
9540 case mp_start_clip_code:
9541 case mp_start_bounds_code:
9542 mp_toss_knot_list(mp, path_p(p));
9544 case mp_stop_clip_code:
9545 case mp_stop_bounds_code:
9547 } /* there are no other cases */
9549 @ If we use |add_edge_ref| to ``copy'' edge structures, the real copying needs
9550 to be done before making a significant change to an edge structure. Much of
9551 the work is done in a separate routine |copy_objects| that copies a list of
9552 graphical objects into a new edge header.
9555 static pointer mp_private_edges (MP mp,pointer h) {
9556 /* make a private copy of the edge structure headed by |h| */
9557 pointer hh; /* the edge header for the new copy */
9558 pointer p,pp; /* pointers for copying the dash list */
9559 if ( ref_count(h)==null ) {
9563 hh=mp_copy_objects(mp, mp_link(dummy_loc(h)),null);
9564 @<Copy the dash list from |h| to |hh|@>;
9565 @<Copy the bounding box information from |h| to |hh| and make |bblast(hh)|
9566 point into the new object list@>;
9571 @ Here we use the fact that |dash_list(hh)=mp_link(hh)|.
9572 @^data structure assumptions@>
9574 @<Copy the dash list from |h| to |hh|@>=
9575 pp=hh; p=dash_list(h);
9576 while ( (p!=null_dash) ) {
9577 mp_link(pp)=mp_get_node(mp, dash_node_size);
9579 start_x(pp)=start_x(p);
9580 stop_x(pp)=stop_x(p);
9583 mp_link(pp)=null_dash;
9584 dash_y(hh)=dash_y(h)
9587 @ |h| is an edge structure
9590 static mp_dash_object *mp_export_dashes (MP mp, pointer q, scaled *w) {
9593 scaled scf; /* scale factor */
9597 if (h==null || dash_list(h)==null_dash)
9600 scf=mp_get_pen_scale(mp, pen_p(q));
9602 if (*w==0) scf = dash_scale(q); else return NULL;
9604 scf=mp_make_scaled(mp, *w,scf);
9605 scf=mp_take_scaled(mp, scf,dash_scale(q));
9608 d = xmalloc(1,sizeof(mp_dash_object));
9609 start_x(null_dash)=start_x(p)+dash_y(h);
9610 while (p != null_dash) {
9611 dashes = xrealloc(dashes, (num_dashes+2), sizeof(scaled));
9612 dashes[(num_dashes-1)] =
9613 mp_take_scaled(mp,(stop_x(p)-start_x(p)),scf);
9614 dashes[(num_dashes)] =
9615 mp_take_scaled(mp,(start_x(mp_link(p))-stop_x(p)),scf);
9616 dashes[(num_dashes+1)] = -1; /* terminus */
9620 d->array_field = dashes;
9622 mp_take_scaled(mp,mp_dash_offset(mp, h),scf);
9628 @ @<Copy the bounding box information from |h| to |hh|...@>=
9629 minx_val(hh)=minx_val(h);
9630 miny_val(hh)=miny_val(h);
9631 maxx_val(hh)=maxx_val(h);
9632 maxy_val(hh)=maxy_val(h);
9633 bbtype(hh)=bbtype(h);
9634 p=dummy_loc(h); pp=dummy_loc(hh);
9635 while ((p!=bblast(h)) ) {
9636 if ( p==null ) mp_confusion(mp, "bblast");
9637 @:this can't happen bblast}{\quad bblast@>
9638 p=mp_link(p); pp=mp_link(pp);
9642 @ Here is the promised routine for copying graphical objects into a new edge
9643 structure. It starts copying at object~|p| and stops just before object~|q|.
9644 If |q| is null, it copies the entire sublist headed at |p|. The resulting edge
9645 structure requires further initialization by |init_bbox|.
9648 static pointer mp_copy_objects (MP mp, pointer p, pointer q);
9651 pointer mp_copy_objects (MP mp, pointer p, pointer q) {
9652 pointer hh; /* the new edge header */
9653 pointer pp; /* the last newly copied object */
9654 quarterword k; /* temporary register */
9655 hh=mp_get_node(mp, edge_header_size);
9656 dash_list(hh)=null_dash;
9660 @<Make |mp_link(pp)| point to a copy of object |p|, and update |p| and |pp|@>;
9667 @ @<Make |mp_link(pp)| point to a copy of object |p|, and update |p| and |pp|@>=
9668 { k=mp->gr_object_size[type(p)];
9669 mp_link(pp)=mp_get_node(mp, k);
9671 while ( (k>0) ) { decr(k); mp->mem[pp+k]=mp->mem[p+k]; };
9672 @<Fix anything in graphical object |pp| that should differ from the
9673 corresponding field in |p|@>;
9677 @ @<Fix anything in graphical object |pp| that should differ from the...@>=
9679 case mp_start_clip_code:
9680 case mp_start_bounds_code:
9681 path_p(pp)=mp_copy_path(mp, path_p(p));
9684 path_p(pp)=mp_copy_path(mp, path_p(p));
9685 if ( pre_script(p)!=null ) add_str_ref(pre_script(p));
9686 if ( post_script(p)!=null ) add_str_ref(post_script(p));
9687 if ( pen_p(p)!=null ) pen_p(pp)=copy_pen(pen_p(p));
9689 case mp_stroked_code:
9690 if ( pre_script(p)!=null ) add_str_ref(pre_script(p));
9691 if ( post_script(p)!=null ) add_str_ref(post_script(p));
9692 path_p(pp)=mp_copy_path(mp, path_p(p));
9693 pen_p(pp)=copy_pen(pen_p(p));
9694 if ( dash_p(p)!=null ) add_edge_ref(dash_p(pp));
9697 if ( pre_script(p)!=null ) add_str_ref(pre_script(p));
9698 if ( post_script(p)!=null ) add_str_ref(post_script(p));
9699 add_str_ref(text_p(pp));
9701 case mp_stop_clip_code:
9702 case mp_stop_bounds_code:
9704 } /* there are no other cases */
9706 @ Here is one way to find an acceptable value for the second argument to
9707 |copy_objects|. Given a non-null graphical object list, |skip_1component|
9708 skips past one picture component, where a ``picture component'' is a single
9709 graphical object, or a start bounds or start clip object and everything up
9710 through the matching stop bounds or stop clip object. The macro version avoids
9711 procedure call overhead and error handling: |skip_component(p)(e)| advances |p|
9712 unless |p| points to a stop bounds or stop clip node, in which case it executes
9715 @d skip_component(A)
9716 if ( ! is_start_or_stop((A)) ) (A)=mp_link((A));
9717 else if ( ! is_stop((A)) ) (A)=mp_skip_1component(mp, (A));
9721 static pointer mp_skip_1component (MP mp,pointer p) {
9722 integer lev; /* current nesting level */
9725 if ( is_start_or_stop(p) ) {
9726 if ( is_stop(p) ) decr(lev); else incr(lev);
9733 @ Here is a diagnostic routine for printing an edge structure in symbolic form.
9736 static void mp_print_edges (MP mp,pointer h, const char *s, boolean nuline) ;
9739 void mp_print_edges (MP mp,pointer h, const char *s, boolean nuline) {
9740 pointer p; /* a graphical object to be printed */
9741 pointer hh,pp; /* temporary pointers */
9742 scaled scf; /* a scale factor for the dash pattern */
9743 boolean ok_to_dash; /* |false| for polygonal pen strokes */
9744 mp_print_diagnostic(mp, "Edge structure",s,nuline);
9746 while ( mp_link(p)!=null ) {
9750 @<Cases for printing graphical object node |p|@>;
9752 mp_print(mp, "[unknown object type!]");
9756 mp_print_nl(mp, "End edges");
9757 if ( p!=obj_tail(h) ) mp_print(mp, "?");
9759 mp_end_diagnostic(mp, true);
9762 @ @<Cases for printing graphical object node |p|@>=
9764 mp_print(mp, "Filled contour ");
9765 mp_print_obj_color(mp, p);
9766 mp_print_char(mp, xord(':')); mp_print_ln(mp);
9767 mp_pr_path(mp, path_p(p)); mp_print_ln(mp);
9768 if ( (pen_p(p)!=null) ) {
9769 @<Print join type for graphical object |p|@>;
9770 mp_print(mp, " with pen"); mp_print_ln(mp);
9771 mp_pr_pen(mp, pen_p(p));
9775 @ @<Print join type for graphical object |p|@>=
9776 switch (ljoin_val(p)) {
9778 mp_print(mp, "mitered joins limited ");
9779 mp_print_scaled(mp, miterlim_val(p));
9782 mp_print(mp, "round joins");
9785 mp_print(mp, "beveled joins");
9788 mp_print(mp, "?? joins");
9793 @ For stroked nodes, we need to print |lcap_val(p)| as well.
9795 @<Print join and cap types for stroked node |p|@>=
9796 switch (lcap_val(p)) {
9797 case 0:mp_print(mp, "butt"); break;
9798 case 1:mp_print(mp, "round"); break;
9799 case 2:mp_print(mp, "square"); break;
9800 default: mp_print(mp, "??"); break;
9803 mp_print(mp, " ends, ");
9804 @<Print join type for graphical object |p|@>
9806 @ Here is a routine that prints the color of a graphical object if it isn't
9807 black (the default color).
9810 static void mp_print_obj_color (MP mp,pointer p) ;
9813 void mp_print_obj_color (MP mp,pointer p) {
9814 if ( color_model(p)==mp_grey_model ) {
9815 if ( grey_val(p)>0 ) {
9816 mp_print(mp, "greyed ");
9817 mp_print_compact_node(mp, obj_grey_loc(p),1);
9819 } else if ( color_model(p)==mp_cmyk_model ) {
9820 if ( (cyan_val(p)>0) || (magenta_val(p)>0) ||
9821 (yellow_val(p)>0) || (black_val(p)>0) ) {
9822 mp_print(mp, "processcolored ");
9823 mp_print_compact_node(mp, obj_cyan_loc(p),4);
9825 } else if ( color_model(p)==mp_rgb_model ) {
9826 if ( (red_val(p)>0) || (green_val(p)>0) || (blue_val(p)>0) ) {
9827 mp_print(mp, "colored ");
9828 mp_print_compact_node(mp, obj_red_loc(p),3);
9833 @ We also need a procedure for printing consecutive scaled values as if they
9834 were a known big node.
9837 static void mp_print_compact_node (MP mp,pointer p, quarterword k) ;
9840 void mp_print_compact_node (MP mp,pointer p, quarterword k) {
9841 pointer q; /* last location to print */
9843 mp_print_char(mp, xord('('));
9845 mp_print_scaled(mp, mp->mem[p].sc);
9846 if ( p<q ) mp_print_char(mp, xord(','));
9849 mp_print_char(mp, xord(')'));
9852 @ @<Cases for printing graphical object node |p|@>=
9853 case mp_stroked_code:
9854 mp_print(mp, "Filled pen stroke ");
9855 mp_print_obj_color(mp, p);
9856 mp_print_char(mp, xord(':')); mp_print_ln(mp);
9857 mp_pr_path(mp, path_p(p));
9858 if ( dash_p(p)!=null ) {
9859 mp_print_nl(mp, "dashed (");
9860 @<Finish printing the dash pattern that |p| refers to@>;
9863 @<Print join and cap types for stroked node |p|@>;
9864 mp_print(mp, " with pen"); mp_print_ln(mp);
9865 if ( pen_p(p)==null ) mp_print(mp, "???"); /* shouldn't happen */
9867 else mp_pr_pen(mp, pen_p(p));
9870 @ Normally, the |dash_list| field in an edge header is set to |null_dash|
9871 when it is not known to define a suitable dash pattern. This is disallowed
9872 here because the |dash_p| field should never point to such an edge header.
9873 Note that memory is allocated for |start_x(null_dash)| and we are free to
9874 give it any convenient value.
9876 @<Finish printing the dash pattern that |p| refers to@>=
9877 ok_to_dash=pen_is_elliptical(pen_p(p));
9878 if ( ! ok_to_dash ) scf=unity; else scf=dash_scale(p);
9881 if ( (pp==null_dash) || (dash_y(hh)<0) ) {
9882 mp_print(mp, " ??");
9883 } else { start_x(null_dash)=start_x(pp)+dash_y(hh);
9884 while ( pp!=null_dash ) {
9885 mp_print(mp, "on ");
9886 mp_print_scaled(mp, mp_take_scaled(mp, stop_x(pp)-start_x(pp),scf));
9887 mp_print(mp, " off ");
9888 mp_print_scaled(mp, mp_take_scaled(mp, start_x(mp_link(pp))-stop_x(pp),scf));
9890 if ( pp!=null_dash ) mp_print_char(mp, xord(' '));
9892 mp_print(mp, ") shifted ");
9893 mp_print_scaled(mp, -mp_take_scaled(mp, mp_dash_offset(mp, hh),scf));
9894 if ( ! ok_to_dash || (dash_y(hh)==0) ) mp_print(mp, " (this will be ignored)");
9898 static scaled mp_dash_offset (MP mp,pointer h) ;
9901 scaled mp_dash_offset (MP mp,pointer h) {
9902 scaled x; /* the answer */
9903 if (dash_list(h)==null_dash || dash_y(h)<0) mp_confusion(mp, "dash0");
9904 @:this can't happen dash0}{\quad dash0@>
9905 if ( dash_y(h)==0 ) {
9908 x=-(start_x(dash_list(h)) % dash_y(h));
9909 if ( x<0 ) x=x+dash_y(h);
9914 @ @<Cases for printing graphical object node |p|@>=
9916 mp_print_char(mp, xord('"')); mp_print_str(mp,text_p(p));
9917 mp_print(mp, "\" infont \""); mp_print(mp, mp->font_name[font_n(p)]);
9918 mp_print_char(mp, xord('"')); mp_print_ln(mp);
9919 mp_print_obj_color(mp, p);
9920 mp_print(mp, "transformed ");
9921 mp_print_compact_node(mp, text_tx_loc(p),6);
9924 @ @<Cases for printing graphical object node |p|@>=
9925 case mp_start_clip_code:
9926 mp_print(mp, "clipping path:");
9928 mp_pr_path(mp, path_p(p));
9930 case mp_stop_clip_code:
9931 mp_print(mp, "stop clipping");
9934 @ @<Cases for printing graphical object node |p|@>=
9935 case mp_start_bounds_code:
9936 mp_print(mp, "setbounds path:");
9938 mp_pr_path(mp, path_p(p));
9940 case mp_stop_bounds_code:
9941 mp_print(mp, "end of setbounds");
9944 @ To initialize the |dash_list| field in an edge header~|h|, we need a
9945 subroutine that scans an edge structure and tries to interpret it as a dash
9946 pattern. This can only be done when there are no filled regions or clipping
9947 paths and all the pen strokes have the same color. The first step is to let
9948 $y_0$ be the initial $y$~coordinate of the first pen stroke. Then we implicitly
9949 project all the pen stroke paths onto the line $y=y_0$ and require that there
9950 be no retracing. If the resulting paths cover a range of $x$~coordinates of
9951 length $\Delta x$, we set |dash_y(h)| to the length of the dash pattern by
9952 finding the maximum of $\Delta x$ and the absolute value of~$y_0$.
9955 static pointer mp_make_dashes (MP mp,pointer h) { /* returns |h| or |null| */
9956 pointer p; /* this scans the stroked nodes in the object list */
9957 pointer p0; /* if not |null| this points to the first stroked node */
9958 pointer pp,qq,rr; /* pointers into |path_p(p)| */
9959 pointer d,dd; /* pointers used to create the dash list */
9961 @<Other local variables in |make_dashes|@>;
9962 y0=0; /* the initial $y$ coordinate */
9963 if ( dash_list(h)!=null_dash )
9966 p=mp_link(dummy_loc(h));
9968 if ( type(p)!=mp_stroked_code ) {
9969 @<Compain that the edge structure contains a node of the wrong type
9970 and |goto not_found|@>;
9973 if ( p0==null ){ p0=p; y0=y_coord(pp); };
9974 @<Make |d| point to a new dash node created from stroke |p| and path |pp|
9975 or |goto not_found| if there is an error@>;
9976 @<Insert |d| into the dash list and |goto not_found| if there is an error@>;
9979 if ( dash_list(h)==null_dash )
9980 goto NOT_FOUND; /* No error message */
9981 @<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>;
9982 @<Set |dash_y(h)| and merge the first and last dashes if necessary@>;
9985 @<Flush the dash list, recycle |h| and return |null|@>;
9988 @ @<Compain that the edge structure contains a node of the wrong type...@>=
9990 print_err("Picture is too complicated to use as a dash pattern");
9991 help3("When you say `dashed p', picture p should not contain any",
9992 "text, filled regions, or clipping paths. This time it did",
9993 "so I'll just make it a solid line instead.");
9994 mp_put_get_error(mp);
9998 @ A similar error occurs when monotonicity fails.
10001 static void mp_x_retrace_error (MP mp) ;
10004 void mp_x_retrace_error (MP mp) {
10005 print_err("Picture is too complicated to use as a dash pattern");
10006 help3("When you say `dashed p', every path in p should be monotone",
10007 "in x and there must be no overlapping. This failed",
10008 "so I'll just make it a solid line instead.");
10009 mp_put_get_error(mp);
10012 @ We stash |p| in |info(d)| if |dash_p(p)<>0| so that subsequent processing can
10013 handle the case where the pen stroke |p| is itself dashed.
10015 @<Make |d| point to a new dash node created from stroke |p| and path...@>=
10016 @<Make sure |p| and |p0| are the same color and |goto not_found| if there is
10019 if ( mp_link(pp)!=pp ) {
10021 qq=rr; rr=mp_link(rr);
10022 @<Check for retracing between knots |qq| and |rr| and |goto not_found|
10023 if there is a problem@>;
10024 } while (right_type(rr)!=mp_endpoint);
10026 d=mp_get_node(mp, dash_node_size);
10027 if ( dash_p(p)==0 ) info(d)=0; else info(d)=p;
10028 if ( x_coord(pp)<x_coord(rr) ) {
10029 start_x(d)=x_coord(pp);
10030 stop_x(d)=x_coord(rr);
10032 start_x(d)=x_coord(rr);
10033 stop_x(d)=x_coord(pp);
10036 @ We also need to check for the case where the segment from |qq| to |rr| is
10037 monotone in $x$ but is reversed relative to the path from |pp| to |qq|.
10039 @<Check for retracing between knots |qq| and |rr| and |goto not_found|...@>=
10044 if ( (x0>x1) || (x1>x2) || (x2>x3) ) {
10045 if ( (x0<x1) || (x1<x2) || (x2<x3) ) {
10046 if ( mp_ab_vs_cd(mp, x2-x1,x2-x1,x1-x0,x3-x2)>0 ) {
10047 mp_x_retrace_error(mp); goto NOT_FOUND;
10051 if ( (x_coord(pp)>x0) || (x0>x3) ) {
10052 if ( (x_coord(pp)<x0) || (x0<x3) ) {
10053 mp_x_retrace_error(mp); goto NOT_FOUND;
10057 @ @<Other local variables in |make_dashes|@>=
10058 scaled x0,x1,x2,x3; /* $x$ coordinates of the segment from |qq| to |rr| */
10060 @ @<Make sure |p| and |p0| are the same color and |goto not_found|...@>=
10061 if ( (red_val(p)!=red_val(p0)) || (black_val(p)!=black_val(p0)) ||
10062 (green_val(p)!=green_val(p0)) || (blue_val(p)!=blue_val(p0)) ) {
10063 print_err("Picture is too complicated to use as a dash pattern");
10064 help3("When you say `dashed p', everything in picture p should",
10065 "be the same color. I can\'t handle your color changes",
10066 "so I'll just make it a solid line instead.");
10067 mp_put_get_error(mp);
10071 @ @<Insert |d| into the dash list and |goto not_found| if there is an error@>=
10072 start_x(null_dash)=stop_x(d);
10073 dd=h; /* this makes |mp_link(dd)=dash_list(h)| */
10074 while ( start_x(mp_link(dd))<stop_x(d) )
10077 if ( (stop_x(dd)>start_x(d)) )
10078 { mp_x_retrace_error(mp); goto NOT_FOUND; };
10080 mp_link(d)=mp_link(dd);
10083 @ @<Set |dash_y(h)| and merge the first and last dashes if necessary@>=
10085 while ( (mp_link(d)!=null_dash) )
10088 dash_y(h)=stop_x(d)-start_x(dd);
10089 if ( abs(y0)>dash_y(h) ) {
10091 } else if ( d!=dd ) {
10092 dash_list(h)=mp_link(dd);
10093 stop_x(d)=stop_x(dd)+dash_y(h);
10094 mp_free_node(mp, dd,dash_node_size);
10097 @ We get here when the argument is a null picture or when there is an error.
10098 Recovering from an error involves making |dash_list(h)| empty to indicate
10099 that |h| is not known to be a valid dash pattern. We also dereference |h|
10100 since it is not being used for the return value.
10102 @<Flush the dash list, recycle |h| and return |null|@>=
10103 mp_flush_dash_list(mp, h);
10104 delete_edge_ref(h);
10107 @ Having carefully saved the dashed stroked nodes in the
10108 corresponding dash nodes, we must be prepared to break up these dashes into
10111 @<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>=
10112 d=h; /* now |mp_link(d)=dash_list(h)| */
10113 while ( mp_link(d)!=null_dash ) {
10114 ds=info(mp_link(d));
10119 hsf=dash_scale(ds);
10120 if ( (hh==null) ) mp_confusion(mp, "dash1");
10121 @:this can't happen dash0}{\quad dash1@>
10122 if ( dash_y(hh)==0 ) {
10125 if ( dash_list(hh)==null ) mp_confusion(mp, "dash1");
10126 @:this can't happen dash0}{\quad dash1@>
10127 @<Replace |mp_link(d)| by a dashed version as determined by edge header
10128 |hh| and scale factor |ds|@>;
10133 @ @<Other local variables in |make_dashes|@>=
10134 pointer dln; /* |mp_link(d)| */
10135 pointer hh; /* an edge header that tells how to break up |dln| */
10136 scaled hsf; /* the dash pattern from |hh| gets scaled by this */
10137 pointer ds; /* the stroked node from which |hh| and |hsf| are derived */
10138 scaled xoff; /* added to $x$ values in |dash_list(hh)| to match |dln| */
10140 @ @<Replace |mp_link(d)| by a dashed version as determined by edge header...@>=
10143 xoff=start_x(dln)-mp_take_scaled(mp, hsf,start_x(dd))-
10144 mp_take_scaled(mp, hsf,mp_dash_offset(mp, hh));
10145 start_x(null_dash)=mp_take_scaled(mp, hsf,start_x(dd))
10146 +mp_take_scaled(mp, hsf,dash_y(hh));
10147 stop_x(null_dash)=start_x(null_dash);
10148 @<Advance |dd| until finding the first dash that overlaps |dln| when
10149 offset by |xoff|@>;
10150 while ( start_x(dln)<=stop_x(dln) ) {
10151 @<If |dd| has `fallen off the end', back up to the beginning and fix |xoff|@>;
10152 @<Insert a dash between |d| and |dln| for the overlap with the offset version
10155 start_x(dln)=xoff+mp_take_scaled(mp, hsf,start_x(dd));
10157 mp_link(d)=mp_link(dln);
10158 mp_free_node(mp, dln,dash_node_size)
10160 @ The name of this module is a bit of a lie because we just find the
10161 first |dd| where |take_scaled (hsf, stop_x(dd))| is large enough to make an
10162 overlap possible. It could be that the unoffset version of dash |dln| falls
10163 in the gap between |dd| and its predecessor.
10165 @<Advance |dd| until finding the first dash that overlaps |dln| when...@>=
10166 while ( xoff+mp_take_scaled(mp, hsf,stop_x(dd))<start_x(dln) ) {
10170 @ @<If |dd| has `fallen off the end', back up to the beginning and fix...@>=
10171 if ( dd==null_dash ) {
10173 xoff=xoff+mp_take_scaled(mp, hsf,dash_y(hh));
10176 @ At this point we already know that
10177 |start_x(dln)<=xoff+take_scaled(hsf,stop_x(dd))|.
10179 @<Insert a dash between |d| and |dln| for the overlap with the offset...@>=
10180 if ( (xoff+mp_take_scaled(mp, hsf,start_x(dd)))<=stop_x(dln) ) {
10181 mp_link(d)=mp_get_node(mp, dash_node_size);
10184 if ( start_x(dln)>(xoff+mp_take_scaled(mp, hsf,start_x(dd))))
10185 start_x(d)=start_x(dln);
10187 start_x(d)=xoff+mp_take_scaled(mp, hsf,start_x(dd));
10188 if ( stop_x(dln)<(xoff+mp_take_scaled(mp, hsf,stop_x(dd))))
10189 stop_x(d)=stop_x(dln);
10191 stop_x(d)=xoff+mp_take_scaled(mp, hsf,stop_x(dd));
10194 @ The next major task is to update the bounding box information in an edge
10195 header~|h|. This is done via a procedure |adjust_bbox| that enlarges an edge
10196 header's bounding box to accommodate the box computed by |path_bbox| or
10197 |pen_bbox|. (This is stored in global variables |minx|, |miny|, |maxx|, and
10200 @c static void mp_adjust_bbox (MP mp,pointer h) {
10201 if ( minx<minx_val(h) ) minx_val(h)=minx;
10202 if ( miny<miny_val(h) ) miny_val(h)=miny;
10203 if ( maxx>maxx_val(h) ) maxx_val(h)=maxx;
10204 if ( maxy>maxy_val(h) ) maxy_val(h)=maxy;
10207 @ Here is a special routine for updating the bounding box information in
10208 edge header~|h| to account for the squared-off ends of a non-cyclic path~|p|
10209 that is to be stroked with the pen~|pp|.
10211 @c static void mp_box_ends (MP mp, pointer p, pointer pp, pointer h) {
10212 pointer q; /* a knot node adjacent to knot |p| */
10213 fraction dx,dy; /* a unit vector in the direction out of the path at~|p| */
10214 scaled d; /* a factor for adjusting the length of |(dx,dy)| */
10215 scaled z; /* a coordinate being tested against the bounding box */
10216 scaled xx,yy; /* the extreme pen vertex in the |(dx,dy)| direction */
10217 integer i; /* a loop counter */
10218 if ( right_type(p)!=mp_endpoint ) {
10221 @<Make |(dx,dy)| the final direction for the path segment from
10222 |q| to~|p|; set~|d|@>;
10223 d=mp_pyth_add(mp, dx,dy);
10225 @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>;
10226 for (i=1;i<= 2;i++) {
10227 @<Use |(dx,dy)| to generate a vertex of the square end cap and
10228 update the bounding box to accommodate it@>;
10232 if ( right_type(p)==mp_endpoint ) {
10235 @<Advance |p| to the end of the path and make |q| the previous knot@>;
10241 @ @<Make |(dx,dy)| the final direction for the path segment from...@>=
10242 if ( q==mp_link(p) ) {
10243 dx=x_coord(p)-right_x(p);
10244 dy=y_coord(p)-right_y(p);
10245 if ( (dx==0)&&(dy==0) ) {
10246 dx=x_coord(p)-left_x(q);
10247 dy=y_coord(p)-left_y(q);
10250 dx=x_coord(p)-left_x(p);
10251 dy=y_coord(p)-left_y(p);
10252 if ( (dx==0)&&(dy==0) ) {
10253 dx=x_coord(p)-right_x(q);
10254 dy=y_coord(p)-right_y(q);
10257 dx=x_coord(p)-x_coord(q);
10258 dy=y_coord(p)-y_coord(q)
10260 @ @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>=
10261 dx=mp_make_fraction(mp, dx,d);
10262 dy=mp_make_fraction(mp, dy,d);
10263 mp_find_offset(mp, -dy,dx,pp);
10264 xx=mp->cur_x; yy=mp->cur_y
10266 @ @<Use |(dx,dy)| to generate a vertex of the square end cap and...@>=
10267 mp_find_offset(mp, dx,dy,pp);
10268 d=mp_take_fraction(mp, xx-mp->cur_x,dx)+mp_take_fraction(mp, yy-mp->cur_y,dy);
10269 if ( ((d<0)&&(i==1)) || ((d>0)&&(i==2)))
10270 mp_confusion(mp, "box_ends");
10271 @:this can't happen box ends}{\quad\\{box\_ends}@>
10272 z=x_coord(p)+mp->cur_x+mp_take_fraction(mp, d,dx);
10273 if ( z<minx_val(h) ) minx_val(h)=z;
10274 if ( z>maxx_val(h) ) maxx_val(h)=z;
10275 z=y_coord(p)+mp->cur_y+mp_take_fraction(mp, d,dy);
10276 if ( z<miny_val(h) ) miny_val(h)=z;
10277 if ( z>maxy_val(h) ) maxy_val(h)=z
10279 @ @<Advance |p| to the end of the path and make |q| the previous knot@>=
10283 } while (right_type(p)!=mp_endpoint)
10285 @ The major difficulty in finding the bounding box of an edge structure is the
10286 effect of clipping paths. We treat them conservatively by only clipping to the
10287 clipping path's bounding box, but this still
10288 requires recursive calls to |set_bbox| in order to find the bounding box of
10290 the objects to be clipped. Such calls are distinguished by the fact that the
10291 boolean parameter |top_level| is false.
10294 void mp_set_bbox (MP mp,pointer h, boolean top_level) {
10295 pointer p; /* a graphical object being considered */
10296 scaled sminx,sminy,smaxx,smaxy;
10297 /* for saving the bounding box during recursive calls */
10298 scaled x0,x1,y0,y1; /* temporary registers */
10299 integer lev; /* nesting level for |mp_start_bounds_code| nodes */
10300 @<Wipe out any existing bounding box information if |bbtype(h)| is
10301 incompatible with |internal[mp_true_corners]|@>;
10302 while ( mp_link(bblast(h))!=null ) {
10303 p=mp_link(bblast(h));
10306 case mp_stop_clip_code:
10307 if ( top_level ) mp_confusion(mp, "bbox"); else return;
10308 @:this can't happen bbox}{\quad bbox@>
10310 @<Other cases for updating the bounding box based on the type of object |p|@>;
10311 } /* all cases are enumerated above */
10313 if ( ! top_level ) mp_confusion(mp, "bbox");
10316 @ @<Declarations@>=
10317 static void mp_set_bbox (MP mp,pointer h, boolean top_level);
10319 @ @<Wipe out any existing bounding box information if |bbtype(h)| is...@>=
10320 switch (bbtype(h)) {
10324 if ( mp->internal[mp_true_corners]>0 ) mp_init_bbox(mp, h);
10327 if ( mp->internal[mp_true_corners]<=0 ) mp_init_bbox(mp, h);
10329 } /* there are no other cases */
10331 @ @<Other cases for updating the bounding box...@>=
10333 mp_path_bbox(mp, path_p(p));
10334 if ( pen_p(p)!=null ) {
10337 mp_pen_bbox(mp, pen_p(p));
10343 mp_adjust_bbox(mp, h);
10346 @ @<Other cases for updating the bounding box...@>=
10347 case mp_start_bounds_code:
10348 if ( mp->internal[mp_true_corners]>0 ) {
10349 bbtype(h)=bounds_unset;
10351 bbtype(h)=bounds_set;
10352 mp_path_bbox(mp, path_p(p));
10353 mp_adjust_bbox(mp, h);
10354 @<Scan to the matching |mp_stop_bounds_code| node and update |p| and
10358 case mp_stop_bounds_code:
10359 if ( mp->internal[mp_true_corners]<=0 ) mp_confusion(mp, "bbox2");
10360 @:this can't happen bbox2}{\quad bbox2@>
10363 @ @<Scan to the matching |mp_stop_bounds_code| node and update |p| and...@>=
10366 if ( mp_link(p)==null ) mp_confusion(mp, "bbox2");
10367 @:this can't happen bbox2}{\quad bbox2@>
10369 if ( type(p)==mp_start_bounds_code ) incr(lev);
10370 else if ( type(p)==mp_stop_bounds_code ) decr(lev);
10374 @ It saves a lot of grief here to be slightly conservative and not account for
10375 omitted parts of dashed lines. We also don't worry about the material omitted
10376 when using butt end caps. The basic computation is for round end caps and
10377 |box_ends| augments it for square end caps.
10379 @<Other cases for updating the bounding box...@>=
10380 case mp_stroked_code:
10381 mp_path_bbox(mp, path_p(p));
10384 mp_pen_bbox(mp, pen_p(p));
10389 mp_adjust_bbox(mp, h);
10390 if ( (left_type(path_p(p))==mp_endpoint)&&(lcap_val(p)==2) )
10391 mp_box_ends(mp, path_p(p), pen_p(p), h);
10394 @ The height width and depth information stored in a text node determines a
10395 rectangle that needs to be transformed according to the transformation
10396 parameters stored in the text node.
10398 @<Other cases for updating the bounding box...@>=
10400 x1=mp_take_scaled(mp, txx_val(p),width_val(p));
10401 y0=mp_take_scaled(mp, txy_val(p),-depth_val(p));
10402 y1=mp_take_scaled(mp, txy_val(p),height_val(p));
10405 if ( y0<y1 ) { minx=minx+y0; maxx=maxx+y1; }
10406 else { minx=minx+y1; maxx=maxx+y0; }
10407 if ( x1<0 ) minx=minx+x1; else maxx=maxx+x1;
10408 x1=mp_take_scaled(mp, tyx_val(p),width_val(p));
10409 y0=mp_take_scaled(mp, tyy_val(p),-depth_val(p));
10410 y1=mp_take_scaled(mp, tyy_val(p),height_val(p));
10413 if ( y0<y1 ) { miny=miny+y0; maxy=maxy+y1; }
10414 else { miny=miny+y1; maxy=maxy+y0; }
10415 if ( x1<0 ) miny=miny+x1; else maxy=maxy+x1;
10416 mp_adjust_bbox(mp, h);
10419 @ This case involves a recursive call that advances |bblast(h)| to the node of
10420 type |mp_stop_clip_code| that matches |p|.
10422 @<Other cases for updating the bounding box...@>=
10423 case mp_start_clip_code:
10424 mp_path_bbox(mp, path_p(p));
10427 sminx=minx_val(h); sminy=miny_val(h);
10428 smaxx=maxx_val(h); smaxy=maxy_val(h);
10429 @<Reinitialize the bounding box in header |h| and call |set_bbox| recursively
10430 starting at |mp_link(p)|@>;
10431 @<Clip the bounding box in |h| to the rectangle given by |x0|, |x1|,
10433 minx=sminx; miny=sminy;
10434 maxx=smaxx; maxy=smaxy;
10435 mp_adjust_bbox(mp, h);
10438 @ @<Reinitialize the bounding box in header |h| and call |set_bbox|...@>=
10439 minx_val(h)=el_gordo;
10440 miny_val(h)=el_gordo;
10441 maxx_val(h)=-el_gordo;
10442 maxy_val(h)=-el_gordo;
10443 mp_set_bbox(mp, h,false)
10445 @ @<Clip the bounding box in |h| to the rectangle given by |x0|, |x1|,...@>=
10446 if ( minx_val(h)<x0 ) minx_val(h)=x0;
10447 if ( miny_val(h)<y0 ) miny_val(h)=y0;
10448 if ( maxx_val(h)>x1 ) maxx_val(h)=x1;
10449 if ( maxy_val(h)>y1 ) maxy_val(h)=y1
10451 @* \[22] Finding an envelope.
10452 When \MP\ has a path and a polygonal pen, it needs to express the desired
10453 shape in terms of things \ps\ can understand. The present task is to compute
10454 a new path that describes the region to be filled. It is convenient to
10455 define this as a two step process where the first step is determining what
10456 offset to use for each segment of the path.
10458 @ Given a pointer |c| to a cyclic path,
10459 and a pointer~|h| to the first knot of a pen polygon,
10460 the |offset_prep| routine changes the path into cubics that are
10461 associated with particular pen offsets. Thus if the cubic between |p|
10462 and~|q| is associated with the |k|th offset and the cubic between |q| and~|r|
10463 has offset |l| then |info(q)=zero_off+l-k|. (The constant |zero_off| is added
10464 to because |l-k| could be negative.)
10466 After overwriting the type information with offset differences, we no longer
10467 have a true path so we refer to the knot list returned by |offset_prep| as an
10470 Since an envelope spec only determines relative changes in pen offsets,
10471 |offset_prep| sets a global variable |spec_offset| to the relative change from
10472 |h| to the first offset.
10474 @d zero_off 16384 /* added to offset changes to make them positive */
10477 integer spec_offset; /* number of pen edges between |h| and the initial offset */
10480 static pointer mp_offset_prep (MP mp,pointer c, pointer h) {
10481 halfword n; /* the number of vertices in the pen polygon */
10482 pointer c0,p,q,q0,r,w, ww; /* for list manipulation */
10483 integer k_needed; /* amount to be added to |info(p)| when it is computed */
10484 pointer w0; /* a pointer to pen offset to use just before |p| */
10485 scaled dxin,dyin; /* the direction into knot |p| */
10486 integer turn_amt; /* change in pen offsets for the current cubic */
10487 @<Other local variables for |offset_prep|@>;
10489 @<Initialize the pen size~|n|@>;
10490 @<Initialize the incoming direction and pen offset at |c|@>;
10491 p=c; c0=c; k_needed=0;
10494 @<Split the cubic between |p| and |q|, if necessary, into cubics
10495 associated with single offsets, after which |q| should
10496 point to the end of the final such cubic@>;
10498 @<Advance |p| to node |q|, removing any ``dead'' cubics that
10499 might have been introduced by the splitting process@>;
10501 @<Fix the offset change in |info(c)| and set |c| to the return value of
10506 @ We shall want to keep track of where certain knots on the cyclic path
10507 wind up in the envelope spec. It doesn't suffice just to keep pointers to
10508 knot nodes because some nodes are deleted while removing dead cubics. Thus
10509 |offset_prep| updates the following pointers
10513 pointer spec_p2; /* pointers to distinguished knots */
10516 mp->spec_p1=null; mp->spec_p2=null;
10518 @ @<Initialize the pen size~|n|@>=
10525 @ Since the true incoming direction isn't known yet, we just pick a direction
10526 consistent with the pen offset~|h|. If this is wrong, it can be corrected
10529 @<Initialize the incoming direction and pen offset at |c|@>=
10530 dxin=x_coord(mp_link(h))-x_coord(knil(h));
10531 dyin=y_coord(mp_link(h))-y_coord(knil(h));
10532 if ( (dxin==0)&&(dyin==0) ) {
10533 dxin=y_coord(knil(h))-y_coord(h);
10534 dyin=x_coord(h)-x_coord(knil(h));
10538 @ We must be careful not to remove the only cubic in a cycle.
10540 But we must also be careful for another reason. If the user-supplied
10541 path starts with a set of degenerate cubics, the target node |q| can
10542 be collapsed to the initial node |p| which might be the same as the
10543 initial node |c| of the curve. This would cause the |offset_prep| routine
10544 to bail out too early, causing distress later on. (See for example
10545 the testcase reported by Bogus\l{}aw Jackowski in tracker id 267, case 52c
10548 @<Advance |p| to node |q|, removing any ``dead'' cubics...@>=
10552 if ( x_coord(p)==right_x(p) && y_coord(p)==right_y(p) &&
10553 x_coord(p)==left_x(r) && y_coord(p)==left_y(r) &&
10554 x_coord(p)==x_coord(r) && y_coord(p)==y_coord(r) &&
10556 @<Remove the cubic following |p| and update the data structures
10557 to merge |r| into |p|@>;
10561 /* Check if we removed too much */
10562 if ((q!=q0)&&(q!=c||c==c0))
10565 @ @<Remove the cubic following |p| and update the data structures...@>=
10566 { k_needed=info(p)-zero_off;
10570 info(p)=k_needed+info(r);
10573 if ( r==c ) { info(p)=info(c); c=p; };
10574 if ( r==mp->spec_p1 ) mp->spec_p1=p;
10575 if ( r==mp->spec_p2 ) mp->spec_p2=p;
10576 r=p; mp_remove_cubic(mp, p);
10579 @ Not setting the |info| field of the newly created knot allows the splitting
10580 routine to work for paths.
10583 static void mp_split_cubic (MP mp,pointer p, fraction t) ;
10586 void mp_split_cubic (MP mp,pointer p, fraction t) { /* splits the cubic after |p| */
10587 scaled v; /* an intermediate value */
10588 pointer q,r; /* for list manipulation */
10589 q=mp_link(p); r=mp_get_node(mp, knot_node_size); mp_link(p)=r; mp_link(r)=q;
10590 originator(r)=mp_program_code;
10591 left_type(r)=mp_explicit; right_type(r)=mp_explicit;
10592 v=t_of_the_way(right_x(p),left_x(q));
10593 right_x(p)=t_of_the_way(x_coord(p),right_x(p));
10594 left_x(q)=t_of_the_way(left_x(q),x_coord(q));
10595 left_x(r)=t_of_the_way(right_x(p),v);
10596 right_x(r)=t_of_the_way(v,left_x(q));
10597 x_coord(r)=t_of_the_way(left_x(r),right_x(r));
10598 v=t_of_the_way(right_y(p),left_y(q));
10599 right_y(p)=t_of_the_way(y_coord(p),right_y(p));
10600 left_y(q)=t_of_the_way(left_y(q),y_coord(q));
10601 left_y(r)=t_of_the_way(right_y(p),v);
10602 right_y(r)=t_of_the_way(v,left_y(q));
10603 y_coord(r)=t_of_the_way(left_y(r),right_y(r));
10606 @ This does not set |info(p)| or |right_type(p)|.
10609 static void mp_remove_cubic (MP mp,pointer p) ;
10612 void mp_remove_cubic (MP mp,pointer p) { /* removes the dead cubic following~|p| */
10613 pointer q; /* the node that disappears */
10614 q=mp_link(p); mp_link(p)=mp_link(q);
10615 right_x(p)=right_x(q); right_y(p)=right_y(q);
10616 mp_free_node(mp, q,knot_node_size);
10619 @ Let $d\prec d'$ mean that the counter-clockwise angle from $d$ to~$d'$ is
10620 strictly between zero and $180^\circ$. Then we can define $d\preceq d'$ to
10621 mean that the angle could be zero or $180^\circ$. If $w_k=(u_k,v_k)$ is the
10622 $k$th pen offset, the $k$th pen edge direction is defined by the formula
10623 $$d_k=(u\k-u_k,\,v\k-v_k).$$
10624 When listed by increasing $k$, these directions occur in counter-clockwise
10625 order so that $d_k\preceq d\k$ for all~$k$.
10626 The goal of |offset_prep| is to find an offset index~|k| to associate with
10627 each cubic, such that the direction $d(t)$ of the cubic satisfies
10628 $$d_{k-1}\preceq d(t)\preceq d_k\qquad\hbox{for $0\le t\le 1$.}\eqno(*)$$
10629 We may have to split a cubic into many pieces before each
10630 piece corresponds to a unique offset.
10632 @<Split the cubic between |p| and |q|, if necessary, into cubics...@>=
10633 info(p)=zero_off+k_needed;
10635 @<Prepare for derivative computations;
10636 |goto not_found| if the current cubic is dead@>;
10637 @<Find the initial direction |(dx,dy)|@>;
10638 @<Update |info(p)| and find the offset $w_k$ such that
10639 $d_{k-1}\preceq(\\{dx},\\{dy})\prec d_k$; also advance |w0| for
10640 the direction change at |p|@>;
10641 @<Find the final direction |(dxin,dyin)|@>;
10642 @<Decide on the net change in pen offsets and set |turn_amt|@>;
10643 @<Complete the offset splitting process@>;
10644 w0=mp_pen_walk(mp, w0,turn_amt)
10646 @ @<Declarations@>=
10647 static pointer mp_pen_walk (MP mp,pointer w, integer k) ;
10650 pointer mp_pen_walk (MP mp,pointer w, integer k) {
10651 /* walk |k| steps around a pen from |w| */
10652 while ( k>0 ) { w=mp_link(w); decr(k); };
10653 while ( k<0 ) { w=knil(w); incr(k); };
10657 @ The direction of a cubic $B(z_0,z_1,z_2,z_3;t)=\bigl(x(t),y(t)\bigr)$ can be
10658 calculated from the quadratic polynomials
10659 ${1\over3}x'(t)=B(x_1-x_0,x_2-x_1,x_3-x_2;t)$ and
10660 ${1\over3}y'(t)=B(y_1-y_0,y_2-y_1,y_3-y_2;t)$.
10661 Since we may be calculating directions from several cubics
10662 split from the current one, it is desirable to do these calculations
10663 without losing too much precision. ``Scaled up'' values of the
10664 derivatives, which will be less tainted by accumulated errors than
10665 derivatives found from the cubics themselves, are maintained in
10666 local variables |x0|, |x1|, and |x2|, representing $X_0=2^l(x_1-x_0)$,
10667 $X_1=2^l(x_2-x_1)$, and $X_2=2^l(x_3-x_2)$; similarly |y0|, |y1|, and~|y2|
10668 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)$.
10670 @<Other local variables for |offset_prep|@>=
10671 integer x0,x1,x2,y0,y1,y2; /* representatives of derivatives */
10672 integer t0,t1,t2; /* coefficients of polynomial for slope testing */
10673 integer du,dv,dx,dy; /* for directions of the pen and the curve */
10674 integer dx0,dy0; /* initial direction for the first cubic in the curve */
10675 integer max_coef; /* used while scaling */
10676 integer x0a,x1a,x2a,y0a,y1a,y2a; /* intermediate values */
10677 fraction t; /* where the derivative passes through zero */
10678 fraction s; /* a temporary value */
10680 @ @<Prepare for derivative computations...@>=
10681 x0=right_x(p)-x_coord(p);
10682 x2=x_coord(q)-left_x(q);
10683 x1=left_x(q)-right_x(p);
10684 y0=right_y(p)-y_coord(p); y2=y_coord(q)-left_y(q);
10685 y1=left_y(q)-right_y(p);
10687 if ( abs(x1)>max_coef ) max_coef=abs(x1);
10688 if ( abs(x2)>max_coef ) max_coef=abs(x2);
10689 if ( abs(y0)>max_coef ) max_coef=abs(y0);
10690 if ( abs(y1)>max_coef ) max_coef=abs(y1);
10691 if ( abs(y2)>max_coef ) max_coef=abs(y2);
10692 if ( max_coef==0 ) goto NOT_FOUND;
10693 while ( max_coef<fraction_half ) {
10695 double(x0); double(x1); double(x2);
10696 double(y0); double(y1); double(y2);
10699 @ Let us first solve a special case of the problem: Suppose we
10700 know an index~$k$ such that either (i)~$d(t)\succeq d_{k-1}$ for all~$t$
10701 and $d(0)\prec d_k$, or (ii)~$d(t)\preceq d_k$ for all~$t$ and
10702 $d(0)\succ d_{k-1}$.
10703 Then, in a sense, we're halfway done, since one of the two relations
10704 in $(*)$ is satisfied, and the other couldn't be satisfied for
10705 any other value of~|k|.
10707 Actually, the conditions can be relaxed somewhat since a relation such as
10708 $d(t)\succeq d_{k-1}$ restricts $d(t)$ to a half plane when all that really
10709 matters is whether $d(t)$ crosses the ray in the $d_{k-1}$ direction from
10710 the origin. The condition for case~(i) becomes $d_{k-1}\preceq d(0)\prec d_k$
10711 and $d(t)$ never crosses the $d_{k-1}$ ray in the clockwise direction.
10712 Case~(ii) is similar except $d(t)$ cannot cross the $d_k$ ray in the
10713 counterclockwise direction.
10715 The |fin_offset_prep| subroutine solves the stated subproblem.
10716 It has a parameter called |rise| that is |1| in
10717 case~(i), |-1| in case~(ii). Parameters |x0| through |y2| represent
10718 the derivative of the cubic following |p|.
10719 The |w| parameter should point to offset~$w_k$ and |info(p)| should already
10720 be set properly. The |turn_amt| parameter gives the absolute value of the
10721 overall net change in pen offsets.
10724 static void mp_fin_offset_prep (MP mp,pointer p, pointer w, integer
10725 x0,integer x1, integer x2, integer y0, integer y1, integer y2,
10726 integer rise, integer turn_amt) ;
10729 void mp_fin_offset_prep (MP mp,pointer p, pointer w, integer
10730 x0,integer x1, integer x2, integer y0, integer y1, integer y2,
10731 integer rise, integer turn_amt) {
10732 pointer ww; /* for list manipulation */
10733 scaled du,dv; /* for slope calculation */
10734 integer t0,t1,t2; /* test coefficients */
10735 fraction t; /* place where the derivative passes a critical slope */
10736 fraction s; /* slope or reciprocal slope */
10737 integer v; /* intermediate value for updating |x0..y2| */
10738 pointer q; /* original |mp_link(p)| */
10741 if ( rise>0 ) ww=mp_link(w); /* a pointer to $w\k$ */
10742 else ww=knil(w); /* a pointer to $w_{k-1}$ */
10743 @<Compute test coefficients |(t0,t1,t2)|
10744 for $d(t)$ versus $d_k$ or $d_{k-1}$@>;
10745 t=mp_crossing_point(mp, t0,t1,t2);
10746 if ( t>=fraction_one ) {
10747 if ( turn_amt>0 ) t=fraction_one; else return;
10749 @<Split the cubic at $t$,
10750 and split off another cubic if the derivative crosses back@>;
10755 @ We want $B(\\{t0},\\{t1},\\{t2};t)$ to be the dot product of $d(t)$ with a
10756 $-90^\circ$ rotation of the vector from |w| to |ww|. This makes the resulting
10757 function cross from positive to negative when $d_{k-1}\preceq d(t)\preceq d_k$
10760 @<Compute test coefficients |(t0,t1,t2)| for $d(t)$ versus...@>=
10761 du=x_coord(ww)-x_coord(w); dv=y_coord(ww)-y_coord(w);
10762 if ( abs(du)>=abs(dv) ) {
10763 s=mp_make_fraction(mp, dv,du);
10764 t0=mp_take_fraction(mp, x0,s)-y0;
10765 t1=mp_take_fraction(mp, x1,s)-y1;
10766 t2=mp_take_fraction(mp, x2,s)-y2;
10767 if ( du<0 ) { negate(t0); negate(t1); negate(t2); }
10769 s=mp_make_fraction(mp, du,dv);
10770 t0=x0-mp_take_fraction(mp, y0,s);
10771 t1=x1-mp_take_fraction(mp, y1,s);
10772 t2=x2-mp_take_fraction(mp, y2,s);
10773 if ( dv<0 ) { negate(t0); negate(t1); negate(t2); }
10775 if ( t0<0 ) t0=0 /* should be positive without rounding error */
10777 @ The curve has crossed $d_k$ or $d_{k-1}$; its initial segment satisfies
10778 $(*)$, and it might cross again and return towards $s_{k-1}$ or $s_k$,
10779 respectively, yielding another solution of $(*)$.
10781 @<Split the cubic at $t$, and split off another...@>=
10783 mp_split_cubic(mp, p,t); p=mp_link(p); info(p)=zero_off+rise;
10785 v=t_of_the_way(x0,x1); x1=t_of_the_way(x1,x2);
10786 x0=t_of_the_way(v,x1);
10787 v=t_of_the_way(y0,y1); y1=t_of_the_way(y1,y2);
10788 y0=t_of_the_way(v,y1);
10789 if ( turn_amt<0 ) {
10790 t1=t_of_the_way(t1,t2);
10791 if ( t1>0 ) t1=0; /* without rounding error, |t1| would be |<=0| */
10792 t=mp_crossing_point(mp, 0,-t1,-t2);
10793 if ( t>fraction_one ) t=fraction_one;
10795 if ( (t==fraction_one)&&(mp_link(p)!=q) ) {
10796 info(mp_link(p))=info(mp_link(p))-rise;
10798 mp_split_cubic(mp, p,t); info(mp_link(p))=zero_off-rise;
10799 v=t_of_the_way(x1,x2); x1=t_of_the_way(x0,x1);
10800 x2=t_of_the_way(x1,v);
10801 v=t_of_the_way(y1,y2); y1=t_of_the_way(y0,y1);
10802 y2=t_of_the_way(y1,v);
10807 @ Now we must consider the general problem of |offset_prep|, when
10808 nothing is known about a given cubic. We start by finding its
10809 direction in the vicinity of |t=0|.
10811 If $z'(t)=0$, the given cubic is numerically unstable but |offset_prep|
10812 has not yet introduced any more numerical errors. Thus we can compute
10813 the true initial direction for the given cubic, even if it is almost
10816 @<Find the initial direction |(dx,dy)|@>=
10818 if ( dx==0 && dy==0 ) {
10820 if ( dx==0 && dy==0 ) {
10824 if ( p==c ) { dx0=dx; dy0=dy; }
10826 @ @<Find the final direction |(dxin,dyin)|@>=
10828 if ( dxin==0 && dyin==0 ) {
10830 if ( dxin==0 && dyin==0 ) {
10835 @ The next step is to bracket the initial direction between consecutive
10836 edges of the pen polygon. We must be careful to turn clockwise only if
10837 this makes the turn less than $180^\circ$. (A $180^\circ$ turn must be
10838 counter-clockwise in order to make \&{doublepath} envelopes come out
10839 @:double_path_}{\&{doublepath} primitive@>
10840 right.) This code depends on |w0| being the offset for |(dxin,dyin)|.
10842 @<Update |info(p)| and find the offset $w_k$ such that...@>=
10843 turn_amt=mp_get_turn_amt(mp,w0,dx,dy,(mp_ab_vs_cd(mp, dy,dxin,dx,dyin)>=0));
10844 w=mp_pen_walk(mp, w0, turn_amt);
10846 info(p)=info(p)+turn_amt
10848 @ Decide how many pen offsets to go away from |w| in order to find the offset
10849 for |(dx,dy)|, going counterclockwise if |ccw| is |true|. This assumes that
10850 |w| is the offset for some direction $(x',y')$ from which the angle to |(dx,dy)|
10851 in the sense determined by |ccw| is less than or equal to $180^\circ$.
10853 If the pen polygon has only two edges, they could both be parallel
10854 to |(dx,dy)|. In this case, we must be careful to stop after crossing the first
10855 such edge in order to avoid an infinite loop.
10858 static integer mp_get_turn_amt (MP mp,pointer w, scaled dx,
10859 scaled dy, boolean ccw);
10862 integer mp_get_turn_amt (MP mp,pointer w, scaled dx,
10863 scaled dy, boolean ccw) {
10864 pointer ww; /* a neighbor of knot~|w| */
10865 integer s; /* turn amount so far */
10866 integer t; /* |ab_vs_cd| result */
10871 t=mp_ab_vs_cd(mp, dy,(x_coord(ww)-x_coord(w)),
10872 dx,(y_coord(ww)-y_coord(w)));
10875 w=ww; ww=mp_link(ww);
10879 while ( mp_ab_vs_cd(mp, dy,(x_coord(w)-x_coord(ww)),
10880 dx,(y_coord(w)-y_coord(ww))) < 0) {
10888 @ When we're all done, the final offset is |w0| and the final curve direction
10889 is |(dxin,dyin)|. With this knowledge of the incoming direction at |c|, we
10890 can correct |info(c)| which was erroneously based on an incoming offset
10893 @d fix_by(A) info(c)=info(c)+(A)
10895 @<Fix the offset change in |info(c)| and set |c| to the return value of...@>=
10896 mp->spec_offset=info(c)-zero_off;
10897 if ( mp_link(c)==c ) {
10898 info(c)=zero_off+n;
10901 while ( w0!=h ) { fix_by(1); w0=mp_link(w0); };
10902 while ( info(c)<=zero_off-n ) fix_by(n);
10903 while ( info(c)>zero_off ) fix_by(-n);
10904 if ( (info(c)!=zero_off)&&(mp_ab_vs_cd(mp, dy0,dxin,dx0,dyin)>=0) ) fix_by(n);
10907 @ Finally we want to reduce the general problem to situations that
10908 |fin_offset_prep| can handle. We split the cubic into at most three parts
10909 with respect to $d_{k-1}$, and apply |fin_offset_prep| to each part.
10911 @<Complete the offset splitting process@>=
10913 @<Compute test coeff...@>;
10914 @<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set
10915 |t:=fraction_one+1|@>;
10916 if ( t>fraction_one ) {
10917 mp_fin_offset_prep(mp, p,w,x0,x1,x2,y0,y1,y2,1,turn_amt);
10919 mp_split_cubic(mp, p,t); r=mp_link(p);
10920 x1a=t_of_the_way(x0,x1); x1=t_of_the_way(x1,x2);
10921 x2a=t_of_the_way(x1a,x1);
10922 y1a=t_of_the_way(y0,y1); y1=t_of_the_way(y1,y2);
10923 y2a=t_of_the_way(y1a,y1);
10924 mp_fin_offset_prep(mp, p,w,x0,x1a,x2a,y0,y1a,y2a,1,0); x0=x2a; y0=y2a;
10925 info(r)=zero_off-1;
10926 if ( turn_amt>=0 ) {
10927 t1=t_of_the_way(t1,t2);
10929 t=mp_crossing_point(mp, 0,-t1,-t2);
10930 if ( t>fraction_one ) t=fraction_one;
10931 @<Split off another rising cubic for |fin_offset_prep|@>;
10932 mp_fin_offset_prep(mp, r,ww,x0,x1,x2,y0,y1,y2,-1,0);
10934 mp_fin_offset_prep(mp, r,ww,x0,x1,x2,y0,y1,y2,-1,(-1-turn_amt));
10938 @ @<Split off another rising cubic for |fin_offset_prep|@>=
10939 mp_split_cubic(mp, r,t); info(mp_link(r))=zero_off+1;
10940 x1a=t_of_the_way(x1,x2); x1=t_of_the_way(x0,x1);
10941 x0a=t_of_the_way(x1,x1a);
10942 y1a=t_of_the_way(y1,y2); y1=t_of_the_way(y0,y1);
10943 y0a=t_of_the_way(y1,y1a);
10944 mp_fin_offset_prep(mp, mp_link(r),w,x0a,x1a,x2,y0a,y1a,y2,1,turn_amt);
10947 @ At this point, the direction of the incoming pen edge is |(-du,-dv)|.
10948 When the component of $d(t)$ perpendicular to |(-du,-dv)| crosses zero, we
10949 need to decide whether the directions are parallel or antiparallel. We
10950 can test this by finding the dot product of $d(t)$ and |(-du,-dv)|, but this
10951 should be avoided when the value of |turn_amt| already determines the
10952 answer. If |t2<0|, there is one crossing and it is antiparallel only if
10953 |turn_amt>=0|. If |turn_amt<0|, there should always be at least one
10954 crossing and the first crossing cannot be antiparallel.
10956 @<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set...@>=
10957 t=mp_crossing_point(mp, t0,t1,t2);
10958 if ( turn_amt>=0 ) {
10962 u0=t_of_the_way(x0,x1);
10963 u1=t_of_the_way(x1,x2);
10964 ss=mp_take_fraction(mp, -du,t_of_the_way(u0,u1));
10965 v0=t_of_the_way(y0,y1);
10966 v1=t_of_the_way(y1,y2);
10967 ss=ss+mp_take_fraction(mp, -dv,t_of_the_way(v0,v1));
10968 if ( ss<0 ) t=fraction_one+1;
10970 } else if ( t>fraction_one ) {
10974 @ @<Other local variables for |offset_prep|@>=
10975 integer u0,u1,v0,v1; /* intermediate values for $d(t)$ calculation */
10976 integer ss = 0; /* the part of the dot product computed so far */
10977 int d_sign; /* sign of overall change in direction for this cubic */
10979 @ If the cubic almost has a cusp, it is a numerically ill-conditioned
10980 problem to decide which way it loops around but that's OK as long we're
10981 consistent. To make \&{doublepath} envelopes work properly, reversing
10982 the path should always change the sign of |turn_amt|.
10984 @<Decide on the net change in pen offsets and set |turn_amt|@>=
10985 d_sign=mp_ab_vs_cd(mp, dx,dyin, dxin,dy);
10987 @<Check rotation direction based on node position@>
10991 if ( dy>0 ) d_sign=1; else d_sign=-1;
10993 if ( dx>0 ) d_sign=1; else d_sign=-1;
10996 @<Make |ss| negative if and only if the total change in direction is
10997 more than $180^\circ$@>;
10998 turn_amt=mp_get_turn_amt(mp, w, dxin, dyin, (d_sign>0));
10999 if ( ss<0 ) turn_amt=turn_amt-d_sign*n
11001 @ We check rotation direction by looking at the vector connecting the current
11002 node with the next. If its angle with incoming and outgoing tangents has the
11003 same sign, we pick this as |d_sign|, since it means we have a flex, not a cusp.
11004 Otherwise we proceed to the cusp code.
11006 @<Check rotation direction based on node position@>=
11007 u0=x_coord(q)-x_coord(p);
11008 u1=y_coord(q)-y_coord(p);
11009 d_sign = half(mp_ab_vs_cd(mp, dx, u1, u0, dy)+
11010 mp_ab_vs_cd(mp, u0, dyin, dxin, u1));
11012 @ In order to be invariant under path reversal, the result of this computation
11013 should not change when |x0|, |y0|, $\ldots$ are all negated and |(x0,y0)| is
11014 then swapped with |(x2,y2)|. We make use of the identities
11015 |take_fraction(-a,-b)=take_fraction(a,b)| and
11016 |t_of_the_way(-a,-b)=-(t_of_the_way(a,b))|.
11018 @<Make |ss| negative if and only if the total change in direction is...@>=
11019 t0=half(mp_take_fraction(mp, x0,y2))-half(mp_take_fraction(mp, x2,y0));
11020 t1=half(mp_take_fraction(mp, x1,(y0+y2)))-half(mp_take_fraction(mp, y1,(x0+x2)));
11021 if ( t0==0 ) t0=d_sign; /* path reversal always negates |d_sign| */
11023 t=mp_crossing_point(mp, t0,t1,-t0);
11024 u0=t_of_the_way(x0,x1);
11025 u1=t_of_the_way(x1,x2);
11026 v0=t_of_the_way(y0,y1);
11027 v1=t_of_the_way(y1,y2);
11029 t=mp_crossing_point(mp, -t0,t1,t0);
11030 u0=t_of_the_way(x2,x1);
11031 u1=t_of_the_way(x1,x0);
11032 v0=t_of_the_way(y2,y1);
11033 v1=t_of_the_way(y1,y0);
11035 ss=mp_take_fraction(mp, (x0+x2),t_of_the_way(u0,u1))+
11036 mp_take_fraction(mp, (y0+y2),t_of_the_way(v0,v1))
11038 @ Here's a routine that prints an envelope spec in symbolic form. It assumes
11039 that the |cur_pen| has not been walked around to the first offset.
11042 static void mp_print_spec (MP mp,pointer cur_spec, pointer cur_pen, const char *s) {
11043 pointer p,q; /* list traversal */
11044 pointer w; /* the current pen offset */
11045 mp_print_diagnostic(mp, "Envelope spec",s,true);
11046 p=cur_spec; w=mp_pen_walk(mp, cur_pen,mp->spec_offset);
11048 mp_print_two(mp, x_coord(cur_spec),y_coord(cur_spec));
11049 mp_print(mp, " % beginning with offset ");
11050 mp_print_two(mp, x_coord(w),y_coord(w));
11054 @<Print the cubic between |p| and |q|@>;
11056 if ((p==cur_spec) || (info(p)!=zero_off))
11059 if ( info(p)!=zero_off ) {
11060 @<Update |w| as indicated by |info(p)| and print an explanation@>;
11062 } while (p!=cur_spec);
11063 mp_print_nl(mp, " & cycle");
11064 mp_end_diagnostic(mp, true);
11067 @ @<Update |w| as indicated by |info(p)| and print an explanation@>=
11069 w=mp_pen_walk(mp, w, (info(p)-zero_off));
11070 mp_print(mp, " % ");
11071 if ( info(p)>zero_off ) mp_print(mp, "counter");
11072 mp_print(mp, "clockwise to offset ");
11073 mp_print_two(mp, x_coord(w),y_coord(w));
11076 @ @<Print the cubic between |p| and |q|@>=
11078 mp_print_nl(mp, " ..controls ");
11079 mp_print_two(mp, right_x(p),right_y(p));
11080 mp_print(mp, " and ");
11081 mp_print_two(mp, left_x(q),left_y(q));
11082 mp_print_nl(mp, " ..");
11083 mp_print_two(mp, x_coord(q),y_coord(q));
11086 @ Once we have an envelope spec, the remaining task to construct the actual
11087 envelope by offsetting each cubic as determined by the |info| fields in
11088 the knots. First we use |offset_prep| to convert the |c| into an envelope
11089 spec. Then we add the offsets so that |c| becomes a cyclic path that represents
11092 The |ljoin| and |miterlim| parameters control the treatment of points where the
11093 pen offset changes, and |lcap| controls the endpoints of a \&{doublepath}.
11094 The endpoints are easily located because |c| is given in undoubled form
11095 and then doubled in this procedure. We use |spec_p1| and |spec_p2| to keep
11096 track of the endpoints and treat them like very sharp corners.
11097 Butt end caps are treated like beveled joins; round end caps are treated like
11098 round joins; and square end caps are achieved by setting |join_type:=3|.
11100 None of these parameters apply to inside joins where the convolution tracing
11101 has retrograde lines. In such cases we use a simple connect-the-endpoints
11102 approach that is achieved by setting |join_type:=2|.
11105 static pointer mp_make_envelope (MP mp,pointer c, pointer h, quarterword ljoin,
11106 quarterword lcap, scaled miterlim) {
11107 pointer p,q,r,q0; /* for manipulating the path */
11108 int join_type=0; /* codes |0..3| for mitered, round, beveled, or square */
11109 pointer w,w0; /* the pen knot for the current offset */
11110 scaled qx,qy; /* unshifted coordinates of |q| */
11111 halfword k,k0; /* controls pen edge insertion */
11112 @<Other local variables for |make_envelope|@>;
11113 dxin=0; dyin=0; dxout=0; dyout=0;
11114 mp->spec_p1=null; mp->spec_p2=null;
11115 @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>;
11116 @<Use |offset_prep| to compute the envelope spec then walk |h| around to
11117 the initial offset@>;
11121 q=mp_link(p); q0=q;
11122 qx=x_coord(q); qy=y_coord(q);
11125 if ( k!=zero_off ) {
11126 @<Set |join_type| to indicate how to handle offset changes at~|q|@>;
11128 @<Add offset |w| to the cubic from |p| to |q|@>;
11129 while ( k!=zero_off ) {
11130 @<Step |w| and move |k| one step closer to |zero_off|@>;
11131 if ( (join_type==1)||(k==zero_off) )
11132 q=mp_insert_knot(mp, q,qx+x_coord(w),qy+y_coord(w));
11134 if ( q!=mp_link(p) ) {
11135 @<Set |p=mp_link(p)| and add knots between |p| and |q| as
11136 required by |join_type|@>;
11143 @ @<Use |offset_prep| to compute the envelope spec then walk |h| around to...@>=
11144 c=mp_offset_prep(mp, c,h);
11145 if ( mp->internal[mp_tracing_specs]>0 )
11146 mp_print_spec(mp, c,h,"");
11147 h=mp_pen_walk(mp, h,mp->spec_offset)
11149 @ Mitered and squared-off joins depend on path directions that are difficult to
11150 compute for degenerate cubics. The envelope spec computed by |offset_prep| can
11151 have degenerate cubics only if the entire cycle collapses to a single
11152 degenerate cubic. Setting |join_type:=2| in this case makes the computed
11153 envelope degenerate as well.
11155 @<Set |join_type| to indicate how to handle offset changes at~|q|@>=
11156 if ( k<zero_off ) {
11159 if ( (q!=mp->spec_p1)&&(q!=mp->spec_p2) ) join_type=ljoin;
11160 else if ( lcap==2 ) join_type=3;
11161 else join_type=2-lcap;
11162 if ( (join_type==0)||(join_type==3) ) {
11163 @<Set the incoming and outgoing directions at |q|; in case of
11164 degeneracy set |join_type:=2|@>;
11165 if ( join_type==0 ) {
11166 @<If |miterlim| is less than the secant of half the angle at |q|
11167 then set |join_type:=2|@>;
11172 @ @<If |miterlim| is less than the secant of half the angle at |q|...@>=
11174 tmp=mp_take_fraction(mp, miterlim,fraction_half+
11175 half(mp_take_fraction(mp, dxin,dxout)+mp_take_fraction(mp, dyin,dyout)));
11177 if ( mp_take_scaled(mp, miterlim,tmp)<unity ) join_type=2;
11180 @ @<Other local variables for |make_envelope|@>=
11181 fraction dxin,dyin,dxout,dyout; /* directions at |q| when square or mitered */
11182 scaled tmp; /* a temporary value */
11184 @ The coordinates of |p| have already been shifted unless |p| is the first
11185 knot in which case they get shifted at the very end.
11187 @<Add offset |w| to the cubic from |p| to |q|@>=
11188 right_x(p)=right_x(p)+x_coord(w);
11189 right_y(p)=right_y(p)+y_coord(w);
11190 left_x(q)=left_x(q)+x_coord(w);
11191 left_y(q)=left_y(q)+y_coord(w);
11192 x_coord(q)=x_coord(q)+x_coord(w);
11193 y_coord(q)=y_coord(q)+y_coord(w);
11194 left_type(q)=mp_explicit;
11195 right_type(q)=mp_explicit
11197 @ @<Step |w| and move |k| one step closer to |zero_off|@>=
11198 if ( k>zero_off ){ w=mp_link(w); decr(k); }
11199 else { w=knil(w); incr(k); }
11201 @ The cubic from |q| to the new knot at |(x,y)| becomes a line segment and
11202 the |right_x| and |right_y| fields of |r| are set from |q|. This is done in
11203 case the cubic containing these control points is ``yet to be examined.''
11206 static pointer mp_insert_knot (MP mp,pointer q, scaled x, scaled y);
11209 pointer mp_insert_knot (MP mp,pointer q, scaled x, scaled y) {
11210 /* returns the inserted knot */
11211 pointer r; /* the new knot */
11212 r=mp_get_node(mp, knot_node_size);
11213 mp_link(r)=mp_link(q); mp_link(q)=r;
11214 right_x(r)=right_x(q);
11215 right_y(r)=right_y(q);
11218 right_x(q)=x_coord(q);
11219 right_y(q)=y_coord(q);
11220 left_x(r)=x_coord(r);
11221 left_y(r)=y_coord(r);
11222 left_type(r)=mp_explicit;
11223 right_type(r)=mp_explicit;
11224 originator(r)=mp_program_code;
11228 @ After setting |p:=mp_link(p)|, either |join_type=1| or |q=mp_link(p)|.
11230 @<Set |p=mp_link(p)| and add knots between |p| and |q| as...@>=
11233 if ( (join_type==0)||(join_type==3) ) {
11234 if ( join_type==0 ) {
11235 @<Insert a new knot |r| between |p| and |q| as required for a mitered join@>
11237 @<Make |r| the last of two knots inserted between |p| and |q| to form a
11241 right_x(r)=x_coord(r);
11242 right_y(r)=y_coord(r);
11247 @ For very small angles, adding a knot is unnecessary and would cause numerical
11248 problems, so we just set |r:=null| in that case.
11250 @<Insert a new knot |r| between |p| and |q| as required for a mitered join@>=
11252 det=mp_take_fraction(mp, dyout,dxin)-mp_take_fraction(mp, dxout,dyin);
11253 if ( abs(det)<26844 ) {
11254 r=null; /* sine $<10^{-4}$ */
11256 tmp=mp_take_fraction(mp, x_coord(q)-x_coord(p),dyout)-
11257 mp_take_fraction(mp, y_coord(q)-y_coord(p),dxout);
11258 tmp=mp_make_fraction(mp, tmp,det);
11259 r=mp_insert_knot(mp, p,x_coord(p)+mp_take_fraction(mp, tmp,dxin),
11260 y_coord(p)+mp_take_fraction(mp, tmp,dyin));
11264 @ @<Other local variables for |make_envelope|@>=
11265 fraction det; /* a determinant used for mitered join calculations */
11267 @ @<Make |r| the last of two knots inserted between |p| and |q| to form a...@>=
11269 ht_x=y_coord(w)-y_coord(w0);
11270 ht_y=x_coord(w0)-x_coord(w);
11271 while ( (abs(ht_x)<fraction_half)&&(abs(ht_y)<fraction_half) ) {
11272 ht_x+=ht_x; ht_y+=ht_y;
11274 @<Scan the pen polygon between |w0| and |w| and make |max_ht| the range dot
11275 product with |(ht_x,ht_y)|@>;
11276 tmp=mp_make_fraction(mp, max_ht,mp_take_fraction(mp, dxin,ht_x)+
11277 mp_take_fraction(mp, dyin,ht_y));
11278 r=mp_insert_knot(mp, p,x_coord(p)+mp_take_fraction(mp, tmp,dxin),
11279 y_coord(p)+mp_take_fraction(mp, tmp,dyin));
11280 tmp=mp_make_fraction(mp, max_ht,mp_take_fraction(mp, dxout,ht_x)+
11281 mp_take_fraction(mp, dyout,ht_y));
11282 r=mp_insert_knot(mp, r,x_coord(q)+mp_take_fraction(mp, tmp,dxout),
11283 y_coord(q)+mp_take_fraction(mp, tmp,dyout));
11286 @ @<Other local variables for |make_envelope|@>=
11287 fraction ht_x,ht_y; /* perpendicular to the segment from |p| to |q| */
11288 scaled max_ht; /* maximum height of the pen polygon above the |w0|-|w| line */
11289 halfword kk; /* keeps track of the pen vertices being scanned */
11290 pointer ww; /* the pen vertex being tested */
11292 @ The dot product of the vector from |w0| to |ww| with |(ht_x,ht_y)| ranges
11293 from zero to |max_ht|.
11295 @<Scan the pen polygon between |w0| and |w| and make |max_ht| the range...@>=
11300 @<Step |ww| and move |kk| one step closer to |k0|@>;
11301 if ( kk==k0 ) break;
11302 tmp=mp_take_fraction(mp, (x_coord(ww)-x_coord(w0)),ht_x)+
11303 mp_take_fraction(mp, (y_coord(ww)-y_coord(w0)),ht_y);
11304 if ( tmp>max_ht ) max_ht=tmp;
11308 @ @<Step |ww| and move |kk| one step closer to |k0|@>=
11309 if ( kk>k0 ) { ww=mp_link(ww); decr(kk); }
11310 else { ww=knil(ww); incr(kk); }
11312 @ @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>=
11313 if ( left_type(c)==mp_endpoint ) {
11314 mp->spec_p1=mp_htap_ypoc(mp, c);
11315 mp->spec_p2=mp->path_tail;
11316 originator(mp->spec_p1)=mp_program_code;
11317 mp_link(mp->spec_p2)=mp_link(mp->spec_p1);
11318 mp_link(mp->spec_p1)=c;
11319 mp_remove_cubic(mp, mp->spec_p1);
11321 if ( c!=mp_link(c) ) {
11322 originator(mp->spec_p2)=mp_program_code;
11323 mp_remove_cubic(mp, mp->spec_p2);
11325 @<Make |c| look like a cycle of length one@>;
11329 @ @<Make |c| look like a cycle of length one@>=
11331 left_type(c)=mp_explicit; right_type(c)=mp_explicit;
11332 left_x(c)=x_coord(c); left_y(c)=y_coord(c);
11333 right_x(c)=x_coord(c); right_y(c)=y_coord(c);
11336 @ In degenerate situations we might have to look at the knot preceding~|q|.
11337 That knot is |p| but if |p<>c|, its coordinates have already been offset by |w|.
11339 @<Set the incoming and outgoing directions at |q|; in case of...@>=
11340 dxin=x_coord(q)-left_x(q);
11341 dyin=y_coord(q)-left_y(q);
11342 if ( (dxin==0)&&(dyin==0) ) {
11343 dxin=x_coord(q)-right_x(p);
11344 dyin=y_coord(q)-right_y(p);
11345 if ( (dxin==0)&&(dyin==0) ) {
11346 dxin=x_coord(q)-x_coord(p);
11347 dyin=y_coord(q)-y_coord(p);
11348 if ( p!=c ) { /* the coordinates of |p| have been offset by |w| */
11349 dxin=dxin+x_coord(w);
11350 dyin=dyin+y_coord(w);
11354 tmp=mp_pyth_add(mp, dxin,dyin);
11358 dxin=mp_make_fraction(mp, dxin,tmp);
11359 dyin=mp_make_fraction(mp, dyin,tmp);
11360 @<Set the outgoing direction at |q|@>;
11363 @ If |q=c| then the coordinates of |r| and the control points between |q|
11364 and~|r| have already been offset by |h|.
11366 @<Set the outgoing direction at |q|@>=
11367 dxout=right_x(q)-x_coord(q);
11368 dyout=right_y(q)-y_coord(q);
11369 if ( (dxout==0)&&(dyout==0) ) {
11371 dxout=left_x(r)-x_coord(q);
11372 dyout=left_y(r)-y_coord(q);
11373 if ( (dxout==0)&&(dyout==0) ) {
11374 dxout=x_coord(r)-x_coord(q);
11375 dyout=y_coord(r)-y_coord(q);
11379 dxout=dxout-x_coord(h);
11380 dyout=dyout-y_coord(h);
11382 tmp=mp_pyth_add(mp, dxout,dyout);
11383 if ( tmp==0 ) mp_confusion(mp, "degenerate spec");
11384 @:this can't happen degerate spec}{\quad degenerate spec@>
11385 dxout=mp_make_fraction(mp, dxout,tmp);
11386 dyout=mp_make_fraction(mp, dyout,tmp)
11388 @* \[23] Direction and intersection times.
11389 A path of length $n$ is defined parametrically by functions $x(t)$ and
11390 $y(t)$, for |0<=t<=n|; we can regard $t$ as the ``time'' at which the path
11391 reaches the point $\bigl(x(t),y(t)\bigr)$. In this section of the program
11392 we shall consider operations that determine special times associated with
11393 given paths: the first time that a path travels in a given direction, and
11394 a pair of times at which two paths cross each other.
11396 @ Let's start with the easier task. The function |find_direction_time| is
11397 given a direction |(x,y)| and a path starting at~|h|. If the path never
11398 travels in direction |(x,y)|, the direction time will be~|-1|; otherwise
11399 it will be nonnegative.
11401 Certain anomalous cases can arise: If |(x,y)=(0,0)|, so that the given
11402 direction is undefined, the direction time will be~0. If $\bigl(x'(t),
11403 y'(t)\bigr)=(0,0)$, so that the path direction is undefined, it will be
11404 assumed to match any given direction at time~|t|.
11406 The routine solves this problem in nondegenerate cases by rotating the path
11407 and the given direction so that |(x,y)=(1,0)|; i.e., the main task will be
11408 to find when a given path first travels ``due east.''
11411 static scaled mp_find_direction_time (MP mp,scaled x, scaled y, pointer h) {
11412 scaled max; /* $\max\bigl(\vert x\vert,\vert y\vert\bigr)$ */
11413 pointer p,q; /* for list traversal */
11414 scaled n; /* the direction time at knot |p| */
11415 scaled tt; /* the direction time within a cubic */
11416 @<Other local variables for |find_direction_time|@>;
11417 @<Normalize the given direction for better accuracy;
11418 but |return| with zero result if it's zero@>;
11421 if ( right_type(p)==mp_endpoint ) break;
11423 @<Rotate the cubic between |p| and |q|; then
11424 |goto found| if the rotated cubic travels due east at some time |tt|;
11425 but |break| if an entire cyclic path has been traversed@>;
11433 @ @<Normalize the given direction for better accuracy...@>=
11434 if ( abs(x)<abs(y) ) {
11435 x=mp_make_fraction(mp, x,abs(y));
11436 if ( y>0 ) y=fraction_one; else y=-fraction_one;
11437 } else if ( x==0 ) {
11440 y=mp_make_fraction(mp, y,abs(x));
11441 if ( x>0 ) x=fraction_one; else x=-fraction_one;
11444 @ Since we're interested in the tangent directions, we work with the
11445 derivative $${1\over3}B'(x_0,x_1,x_2,x_3;t)=
11446 B(x_1-x_0,x_2-x_1,x_3-x_2;t)$$ instead of
11447 $B(x_0,x_1,x_2,x_3;t)$ itself. The derived coefficients are also scaled up
11448 in order to achieve better accuracy.
11450 The given path may turn abruptly at a knot, and it might pass the critical
11451 tangent direction at such a time. Therefore we remember the direction |phi|
11452 in which the previous rotated cubic was traveling. (The value of |phi| will be
11453 undefined on the first cubic, i.e., when |n=0|.)
11455 @<Rotate the cubic between |p| and |q|; then...@>=
11457 @<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples of the control
11458 points of the rotated derivatives@>;
11459 if ( y1==0 ) if ( x1>=0 ) goto FOUND;
11461 @<Exit to |found| if an eastward direction occurs at knot |p|@>;
11464 if ( (x3!=0)||(y3!=0) ) phi=mp_n_arg(mp, x3,y3);
11465 @<Exit to |found| if the curve whose derivatives are specified by
11466 |x1,x2,x3,y1,y2,y3| travels eastward at some time~|tt|@>
11468 @ @<Other local variables for |find_direction_time|@>=
11469 scaled x1,x2,x3,y1,y2,y3; /* multiples of rotated derivatives */
11470 angle theta,phi; /* angles of exit and entry at a knot */
11471 fraction t; /* temp storage */
11473 @ @<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples...@>=
11474 x1=right_x(p)-x_coord(p); x2=left_x(q)-right_x(p);
11475 x3=x_coord(q)-left_x(q);
11476 y1=right_y(p)-y_coord(p); y2=left_y(q)-right_y(p);
11477 y3=y_coord(q)-left_y(q);
11479 if ( abs(x2)>max ) max=abs(x2);
11480 if ( abs(x3)>max ) max=abs(x3);
11481 if ( abs(y1)>max ) max=abs(y1);
11482 if ( abs(y2)>max ) max=abs(y2);
11483 if ( abs(y3)>max ) max=abs(y3);
11484 if ( max==0 ) goto FOUND;
11485 while ( max<fraction_half ){
11486 max+=max; x1+=x1; x2+=x2; x3+=x3;
11487 y1+=y1; y2+=y2; y3+=y3;
11489 t=x1; x1=mp_take_fraction(mp, x1,x)+mp_take_fraction(mp, y1,y);
11490 y1=mp_take_fraction(mp, y1,x)-mp_take_fraction(mp, t,y);
11491 t=x2; x2=mp_take_fraction(mp, x2,x)+mp_take_fraction(mp, y2,y);
11492 y2=mp_take_fraction(mp, y2,x)-mp_take_fraction(mp, t,y);
11493 t=x3; x3=mp_take_fraction(mp, x3,x)+mp_take_fraction(mp, y3,y);
11494 y3=mp_take_fraction(mp, y3,x)-mp_take_fraction(mp, t,y)
11496 @ @<Exit to |found| if an eastward direction occurs at knot |p|@>=
11497 theta=mp_n_arg(mp, x1,y1);
11498 if ( theta>=0 ) if ( phi<=0 ) if ( phi>=theta-one_eighty_deg ) goto FOUND;
11499 if ( theta<=0 ) if ( phi>=0 ) if ( phi<=theta+one_eighty_deg ) goto FOUND
11501 @ In this step we want to use the |crossing_point| routine to find the
11502 roots of the quadratic equation $B(y_1,y_2,y_3;t)=0$.
11503 Several complications arise: If the quadratic equation has a double root,
11504 the curve never crosses zero, and |crossing_point| will find nothing;
11505 this case occurs iff $y_1y_3=y_2^2$ and $y_1y_2<0$. If the quadratic
11506 equation has simple roots, or only one root, we may have to negate it
11507 so that $B(y_1,y_2,y_3;t)$ crosses from positive to negative at its first root.
11508 And finally, we need to do special things if $B(y_1,y_2,y_3;t)$ is
11511 @ @<Exit to |found| if the curve whose derivatives are specified by...@>=
11512 if ( x1<0 ) if ( x2<0 ) if ( x3<0 ) goto DONE;
11513 if ( mp_ab_vs_cd(mp, y1,y3,y2,y2)==0 ) {
11514 @<Handle the test for eastward directions when $y_1y_3=y_2^2$;
11515 either |goto found| or |goto done|@>;
11518 if ( y1<0 ) { y1=-y1; y2=-y2; y3=-y3; }
11519 else if ( y2>0 ){ y2=-y2; y3=-y3; };
11521 @<Check the places where $B(y_1,y_2,y_3;t)=0$ to see if
11522 $B(x_1,x_2,x_3;t)\ge0$@>;
11525 @ The quadratic polynomial $B(y_1,y_2,y_3;t)$ begins |>=0| and has at most
11526 two roots, because we know that it isn't identically zero.
11528 It must be admitted that the |crossing_point| routine is not perfectly accurate;
11529 rounding errors might cause it to find a root when $y_1y_3>y_2^2$, or to
11530 miss the roots when $y_1y_3<y_2^2$. The rotation process is itself
11531 subject to rounding errors. Yet this code optimistically tries to
11532 do the right thing.
11534 @d we_found_it { tt=(t+04000) / 010000; goto FOUND; }
11536 @<Check the places where $B(y_1,y_2,y_3;t)=0$...@>=
11537 t=mp_crossing_point(mp, y1,y2,y3);
11538 if ( t>fraction_one ) goto DONE;
11539 y2=t_of_the_way(y2,y3);
11540 x1=t_of_the_way(x1,x2);
11541 x2=t_of_the_way(x2,x3);
11542 x1=t_of_the_way(x1,x2);
11543 if ( x1>=0 ) we_found_it;
11545 tt=t; t=mp_crossing_point(mp, 0,-y2,-y3);
11546 if ( t>fraction_one ) goto DONE;
11547 x1=t_of_the_way(x1,x2);
11548 x2=t_of_the_way(x2,x3);
11549 if ( t_of_the_way(x1,x2)>=0 ) {
11550 t=t_of_the_way(tt,fraction_one); we_found_it;
11553 @ @<Handle the test for eastward directions when $y_1y_3=y_2^2$;
11554 either |goto found| or |goto done|@>=
11556 if ( mp_ab_vs_cd(mp, y1,y2,0,0)<0 ) {
11557 t=mp_make_fraction(mp, y1,y1-y2);
11558 x1=t_of_the_way(x1,x2);
11559 x2=t_of_the_way(x2,x3);
11560 if ( t_of_the_way(x1,x2)>=0 ) we_found_it;
11561 } else if ( y3==0 ) {
11563 @<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|@>;
11564 } else if ( x3>=0 ) {
11565 tt=unity; goto FOUND;
11571 @ At this point we know that the derivative of |y(t)| is identically zero,
11572 and that |x1<0|; but either |x2>=0| or |x3>=0|, so there's some hope of
11575 @<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|...@>=
11577 t=mp_crossing_point(mp, -x1,-x2,-x3);
11578 if ( t<=fraction_one ) we_found_it;
11579 if ( mp_ab_vs_cd(mp, x1,x3,x2,x2)<=0 ) {
11580 t=mp_make_fraction(mp, x1,x1-x2); we_found_it;
11584 @ The intersection of two cubics can be found by an interesting variant
11585 of the general bisection scheme described in the introduction to
11587 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)$,
11588 we wish to find a pair of times $(t_1,t_2)$ such that $w(t_1)=z(t_2)$,
11589 if an intersection exists. First we find the smallest rectangle that
11590 encloses the points $\{w_0,w_1,w_2,w_3\}$ and check that it overlaps
11591 the smallest rectangle that encloses
11592 $\{z_0,z_1,z_2,z_3\}$; if not, the cubics certainly don't intersect.
11593 But if the rectangles do overlap, we bisect the intervals, getting
11594 new cubics $w'$ and~$w''$, $z'$~and~$z''$; the intersection routine first
11595 tries for an intersection between $w'$ and~$z'$, then (if unsuccessful)
11596 between $w'$ and~$z''$, then (if still unsuccessful) between $w''$ and~$z'$,
11597 finally (if thrice unsuccessful) between $w''$ and~$z''$. After $l$~successful
11598 levels of bisection we will have determined the intersection times $t_1$
11599 and~$t_2$ to $l$~bits of accuracy.
11601 \def\submin{_{\rm min}} \def\submax{_{\rm max}}
11602 As before, it is better to work with the numbers $W_k=2^l(w_k-w_{k-1})$
11603 and $Z_k=2^l(z_k-z_{k-1})$ rather than the coefficients $w_k$ and $z_k$
11604 themselves. We also need one other quantity, $\Delta=2^l(w_0-z_0)$,
11605 to determine when the enclosing rectangles overlap. Here's why:
11606 The $x$~coordinates of~$w(t)$ are between $u\submin$ and $u\submax$,
11607 and the $x$~coordinates of~$z(t)$ are between $x\submin$ and $x\submax$,
11608 if we write $w_k=(u_k,v_k)$ and $z_k=(x_k,y_k)$ and $u\submin=
11609 \min(u_0,u_1,u_2,u_3)$, etc. These intervals of $x$~coordinates
11610 overlap if and only if $u\submin\L x\submax$ and
11611 $x\submin\L u\submax$. Letting
11612 $$U\submin=\min(0,U_1,U_1+U_2,U_1+U_2+U_3),\;
11613 U\submax=\max(0,U_1,U_1+U_2,U_1+U_2+U_3),$$
11614 we have $2^lu\submin=2^lu_0+U\submin$, etc.; the condition for overlap
11616 $$X\submin-U\submax\L 2^l(u_0-x_0)\L X\submax-U\submin.$$
11617 Thus we want to maintain the quantity $2^l(u_0-x_0)$; similarly,
11618 the quantity $2^l(v_0-y_0)$ accounts for the $y$~coordinates. The
11619 coordinates of $\Delta=2^l(w_0-z_0)$ must stay bounded as $l$ increases,
11620 because of the overlap condition; i.e., we know that $X\submin$,
11621 $X\submax$, and their relatives are bounded, hence $X\submax-
11622 U\submin$ and $X\submin-U\submax$ are bounded.
11624 @ Incidentally, if the given cubics intersect more than once, the process
11625 just sketched will not necessarily find the lexicographically smallest pair
11626 $(t_1,t_2)$. The solution actually obtained will be smallest in ``shuffled
11627 order''; i.e., if $t_1=(.a_1a_2\ldots a_{16})_2$ and
11628 $t_2=(.b_1b_2\ldots b_{16})_2$, then we will minimize
11629 $a_1b_1a_2b_2\ldots a_{16}b_{16}$, not
11630 $a_1a_2\ldots a_{16}b_1b_2\ldots b_{16}$.
11631 Shuffled order agrees with lexicographic order if all pairs of solutions
11632 $(t_1,t_2)$ and $(t_1',t_2')$ have the property that $t_1<t_1'$ iff
11633 $t_2<t_2'$; but in general, lexicographic order can be quite different,
11634 and the bisection algorithm would be substantially less efficient if it were
11635 constrained by lexicographic order.
11637 For example, suppose that an overlap has been found for $l=3$ and
11638 $(t_1,t_2)= (.101,.011)$ in binary, but that no overlap is produced by
11639 either of the alternatives $(.1010,.0110)$, $(.1010,.0111)$ at level~4.
11640 Then there is probably an intersection in one of the subintervals
11641 $(.1011,.011x)$; but lexicographic order would require us to explore
11642 $(.1010,.1xxx)$ and $(.1011,.00xx)$ and $(.1011,.010x)$ first. We wouldn't
11643 want to store all of the subdivision data for the second path, so the
11644 subdivisions would have to be regenerated many times. Such inefficiencies
11645 would be associated with every `1' in the binary representation of~$t_1$.
11647 @ The subdivision process introduces rounding errors, hence we need to
11648 make a more liberal test for overlap. It is not hard to show that the
11649 computed values of $U_i$ differ from the truth by at most~$l$, on
11650 level~$l$, hence $U\submin$ and $U\submax$ will be at most $3l$ in error.
11651 If $\beta$ is an upper bound on the absolute error in the computed
11652 components of $\Delta=(|delx|,|dely|)$ on level~$l$, we will replace
11653 the test `$X\submin-U\submax\L|delx|$' by the more liberal test
11654 `$X\submin-U\submax\L|delx|+|tol|$', where $|tol|=6l+\beta$.
11656 More accuracy is obtained if we try the algorithm first with |tol=0|;
11657 the more liberal tolerance is used only if an exact approach fails.
11658 It is convenient to do this double-take by letting `3' in the preceding
11659 paragraph be a parameter, which is first 0, then 3.
11662 unsigned int tol_step; /* either 0 or 3, usually */
11664 @ We shall use an explicit stack to implement the recursive bisection
11665 method described above. The |bisect_stack| array will contain numerous 5-word
11666 packets like $(U_1,U_2,U_3,U\submin,U\submax)$, as well as 20-word packets
11667 comprising the 5-word packets for $U$, $V$, $X$, and~$Y$.
11669 The following macros define the allocation of stack positions to
11670 the quantities needed for bisection-intersection.
11672 @d stack_1(A) mp->bisect_stack[(A)] /* $U_1$, $V_1$, $X_1$, or $Y_1$ */
11673 @d stack_2(A) mp->bisect_stack[(A)+1] /* $U_2$, $V_2$, $X_2$, or $Y_2$ */
11674 @d stack_3(A) mp->bisect_stack[(A)+2] /* $U_3$, $V_3$, $X_3$, or $Y_3$ */
11675 @d stack_min(A) mp->bisect_stack[(A)+3]
11676 /* $U\submin$, $V\submin$, $X\submin$, or $Y\submin$ */
11677 @d stack_max(A) mp->bisect_stack[(A)+4]
11678 /* $U\submax$, $V\submax$, $X\submax$, or $Y\submax$ */
11679 @d int_packets 20 /* number of words to represent $U_k$, $V_k$, $X_k$, and $Y_k$ */
11681 @d u_packet(A) ((A)-5)
11682 @d v_packet(A) ((A)-10)
11683 @d x_packet(A) ((A)-15)
11684 @d y_packet(A) ((A)-20)
11685 @d l_packets (mp->bisect_ptr-int_packets)
11686 @d r_packets mp->bisect_ptr
11687 @d ul_packet u_packet(l_packets) /* base of $U'_k$ variables */
11688 @d vl_packet v_packet(l_packets) /* base of $V'_k$ variables */
11689 @d xl_packet x_packet(l_packets) /* base of $X'_k$ variables */
11690 @d yl_packet y_packet(l_packets) /* base of $Y'_k$ variables */
11691 @d ur_packet u_packet(r_packets) /* base of $U''_k$ variables */
11692 @d vr_packet v_packet(r_packets) /* base of $V''_k$ variables */
11693 @d xr_packet x_packet(r_packets) /* base of $X''_k$ variables */
11694 @d yr_packet y_packet(r_packets) /* base of $Y''_k$ variables */
11696 @d u1l stack_1(ul_packet) /* $U'_1$ */
11697 @d u2l stack_2(ul_packet) /* $U'_2$ */
11698 @d u3l stack_3(ul_packet) /* $U'_3$ */
11699 @d v1l stack_1(vl_packet) /* $V'_1$ */
11700 @d v2l stack_2(vl_packet) /* $V'_2$ */
11701 @d v3l stack_3(vl_packet) /* $V'_3$ */
11702 @d x1l stack_1(xl_packet) /* $X'_1$ */
11703 @d x2l stack_2(xl_packet) /* $X'_2$ */
11704 @d x3l stack_3(xl_packet) /* $X'_3$ */
11705 @d y1l stack_1(yl_packet) /* $Y'_1$ */
11706 @d y2l stack_2(yl_packet) /* $Y'_2$ */
11707 @d y3l stack_3(yl_packet) /* $Y'_3$ */
11708 @d u1r stack_1(ur_packet) /* $U''_1$ */
11709 @d u2r stack_2(ur_packet) /* $U''_2$ */
11710 @d u3r stack_3(ur_packet) /* $U''_3$ */
11711 @d v1r stack_1(vr_packet) /* $V''_1$ */
11712 @d v2r stack_2(vr_packet) /* $V''_2$ */
11713 @d v3r stack_3(vr_packet) /* $V''_3$ */
11714 @d x1r stack_1(xr_packet) /* $X''_1$ */
11715 @d x2r stack_2(xr_packet) /* $X''_2$ */
11716 @d x3r stack_3(xr_packet) /* $X''_3$ */
11717 @d y1r stack_1(yr_packet) /* $Y''_1$ */
11718 @d y2r stack_2(yr_packet) /* $Y''_2$ */
11719 @d y3r stack_3(yr_packet) /* $Y''_3$ */
11721 @d stack_dx mp->bisect_stack[mp->bisect_ptr] /* stacked value of |delx| */
11722 @d stack_dy mp->bisect_stack[mp->bisect_ptr+1] /* stacked value of |dely| */
11723 @d stack_tol mp->bisect_stack[mp->bisect_ptr+2] /* stacked value of |tol| */
11724 @d stack_uv mp->bisect_stack[mp->bisect_ptr+3] /* stacked value of |uv| */
11725 @d stack_xy mp->bisect_stack[mp->bisect_ptr+4] /* stacked value of |xy| */
11726 @d int_increment (int_packets+int_packets+5) /* number of stack words per level */
11729 integer *bisect_stack;
11730 integer bisect_ptr;
11732 @ @<Allocate or initialize ...@>=
11733 mp->bisect_stack = xmalloc((bistack_size+1),sizeof(integer));
11735 @ @<Dealloc variables@>=
11736 xfree(mp->bisect_stack);
11738 @ @<Check the ``constant''...@>=
11739 if ( int_packets+17*int_increment>bistack_size ) mp->bad=19;
11741 @ Computation of the min and max is a tedious but fairly fast sequence of
11742 instructions; exactly four comparisons are made in each branch.
11745 if ( stack_1((A))<0 ) {
11746 if ( stack_3((A))>=0 ) {
11747 if ( stack_2((A))<0 ) stack_min((A))=stack_1((A))+stack_2((A));
11748 else stack_min((A))=stack_1((A));
11749 stack_max((A))=stack_1((A))+stack_2((A))+stack_3((A));
11750 if ( stack_max((A))<0 ) stack_max((A))=0;
11752 stack_min((A))=stack_1((A))+stack_2((A))+stack_3((A));
11753 if ( stack_min((A))>stack_1((A)) ) stack_min((A))=stack_1((A));
11754 stack_max((A))=stack_1((A))+stack_2((A));
11755 if ( stack_max((A))<0 ) stack_max((A))=0;
11757 } else if ( stack_3((A))<=0 ) {
11758 if ( stack_2((A))>0 ) stack_max((A))=stack_1((A))+stack_2((A));
11759 else stack_max((A))=stack_1((A));
11760 stack_min((A))=stack_1((A))+stack_2((A))+stack_3((A));
11761 if ( stack_min((A))>0 ) stack_min((A))=0;
11763 stack_max((A))=stack_1((A))+stack_2((A))+stack_3((A));
11764 if ( stack_max((A))<stack_1((A)) ) stack_max((A))=stack_1((A));
11765 stack_min((A))=stack_1((A))+stack_2((A));
11766 if ( stack_min((A))>0 ) stack_min((A))=0;
11769 @ It's convenient to keep the current values of $l$, $t_1$, and $t_2$ in
11770 the integer form $2^l+2^lt_1$ and $2^l+2^lt_2$. The |cubic_intersection|
11771 routine uses global variables |cur_t| and |cur_tt| for this purpose;
11772 after successful completion, |cur_t| and |cur_tt| will contain |unity|
11773 plus the |scaled| values of $t_1$ and~$t_2$.
11775 The values of |cur_t| and |cur_tt| will be set to zero if |cubic_intersection|
11776 finds no intersection. The routine gives up and gives an approximate answer
11777 if it has backtracked
11778 more than 5000 times (otherwise there are cases where several minutes
11779 of fruitless computation would be possible).
11781 @d max_patience 5000
11784 integer cur_t;integer cur_tt; /* controls and results of |cubic_intersection| */
11785 integer time_to_go; /* this many backtracks before giving up */
11786 integer max_t; /* maximum of $2^{l+1}$ so far achieved */
11788 @ The given cubics $B(w_0,w_1,w_2,w_3;t)$ and
11789 $B(z_0,z_1,z_2,z_3;t)$ are specified in adjacent knot nodes |(p,mp_link(p))|
11790 and |(pp,mp_link(pp))|, respectively.
11793 static void mp_cubic_intersection (MP mp,pointer p, pointer pp) {
11794 pointer q,qq; /* |mp_link(p)|, |mp_link(pp)| */
11795 mp->time_to_go=max_patience; mp->max_t=2;
11796 @<Initialize for intersections at level zero@>;
11799 if ( mp->delx-mp->tol<=stack_max(x_packet(mp->xy))-stack_min(u_packet(mp->uv)))
11800 if ( mp->delx+mp->tol>=stack_min(x_packet(mp->xy))-stack_max(u_packet(mp->uv)))
11801 if ( mp->dely-mp->tol<=stack_max(y_packet(mp->xy))-stack_min(v_packet(mp->uv)))
11802 if ( mp->dely+mp->tol>=stack_min(y_packet(mp->xy))-stack_max(v_packet(mp->uv)))
11804 if ( mp->cur_t>=mp->max_t ){
11805 if ( mp->max_t==two ) { /* we've done 17 bisections */
11806 mp->cur_t=halfp(mp->cur_t+1);
11807 mp->cur_tt=halfp(mp->cur_tt+1);
11810 mp->max_t+=mp->max_t; mp->appr_t=mp->cur_t; mp->appr_tt=mp->cur_tt;
11812 @<Subdivide for a new level of intersection@>;
11815 if ( mp->time_to_go>0 ) {
11816 decr(mp->time_to_go);
11818 while ( mp->appr_t<unity ) {
11819 mp->appr_t+=mp->appr_t; mp->appr_tt+=mp->appr_tt;
11821 mp->cur_t=mp->appr_t; mp->cur_tt=mp->appr_tt; return;
11823 @<Advance to the next pair |(cur_t,cur_tt)|@>;
11827 @ The following variables are global, although they are used only by
11828 |cubic_intersection|, because it is necessary on some machines to
11829 split |cubic_intersection| up into two procedures.
11832 integer delx;integer dely; /* the components of $\Delta=2^l(w_0-z_0)$ */
11833 integer tol; /* bound on the uncertainty in the overlap test */
11835 integer xy; /* pointers to the current packets of interest */
11836 integer three_l; /* |tol_step| times the bisection level */
11837 integer appr_t;integer appr_tt; /* best approximations known to the answers */
11839 @ We shall assume that the coordinates are sufficiently non-extreme that
11840 integer overflow will not occur.
11841 @^overflow in arithmetic@>
11843 @<Initialize for intersections at level zero@>=
11844 q=mp_link(p); qq=mp_link(pp); mp->bisect_ptr=int_packets;
11845 u1r=right_x(p)-x_coord(p); u2r=left_x(q)-right_x(p);
11846 u3r=x_coord(q)-left_x(q); set_min_max(ur_packet);
11847 v1r=right_y(p)-y_coord(p); v2r=left_y(q)-right_y(p);
11848 v3r=y_coord(q)-left_y(q); set_min_max(vr_packet);
11849 x1r=right_x(pp)-x_coord(pp); x2r=left_x(qq)-right_x(pp);
11850 x3r=x_coord(qq)-left_x(qq); set_min_max(xr_packet);
11851 y1r=right_y(pp)-y_coord(pp); y2r=left_y(qq)-right_y(pp);
11852 y3r=y_coord(qq)-left_y(qq); set_min_max(yr_packet);
11853 mp->delx=x_coord(p)-x_coord(pp); mp->dely=y_coord(p)-y_coord(pp);
11854 mp->tol=0; mp->uv=r_packets; mp->xy=r_packets;
11855 mp->three_l=0; mp->cur_t=1; mp->cur_tt=1
11857 @ @<Subdivide for a new level of intersection@>=
11858 stack_dx=mp->delx; stack_dy=mp->dely; stack_tol=mp->tol;
11859 stack_uv=mp->uv; stack_xy=mp->xy;
11860 mp->bisect_ptr=mp->bisect_ptr+int_increment;
11861 mp->cur_t+=mp->cur_t; mp->cur_tt+=mp->cur_tt;
11862 u1l=stack_1(u_packet(mp->uv)); u3r=stack_3(u_packet(mp->uv));
11863 u2l=half(u1l+stack_2(u_packet(mp->uv)));
11864 u2r=half(u3r+stack_2(u_packet(mp->uv)));
11865 u3l=half(u2l+u2r); u1r=u3l;
11866 set_min_max(ul_packet); set_min_max(ur_packet);
11867 v1l=stack_1(v_packet(mp->uv)); v3r=stack_3(v_packet(mp->uv));
11868 v2l=half(v1l+stack_2(v_packet(mp->uv)));
11869 v2r=half(v3r+stack_2(v_packet(mp->uv)));
11870 v3l=half(v2l+v2r); v1r=v3l;
11871 set_min_max(vl_packet); set_min_max(vr_packet);
11872 x1l=stack_1(x_packet(mp->xy)); x3r=stack_3(x_packet(mp->xy));
11873 x2l=half(x1l+stack_2(x_packet(mp->xy)));
11874 x2r=half(x3r+stack_2(x_packet(mp->xy)));
11875 x3l=half(x2l+x2r); x1r=x3l;
11876 set_min_max(xl_packet); set_min_max(xr_packet);
11877 y1l=stack_1(y_packet(mp->xy)); y3r=stack_3(y_packet(mp->xy));
11878 y2l=half(y1l+stack_2(y_packet(mp->xy)));
11879 y2r=half(y3r+stack_2(y_packet(mp->xy)));
11880 y3l=half(y2l+y2r); y1r=y3l;
11881 set_min_max(yl_packet); set_min_max(yr_packet);
11882 mp->uv=l_packets; mp->xy=l_packets;
11883 mp->delx+=mp->delx; mp->dely+=mp->dely;
11884 mp->tol=mp->tol-mp->three_l+mp->tol_step;
11885 mp->tol+=mp->tol; mp->three_l=mp->three_l+mp->tol_step
11887 @ @<Advance to the next pair |(cur_t,cur_tt)|@>=
11889 if ( odd(mp->cur_tt) ) {
11890 if ( odd(mp->cur_t) ) {
11891 @<Descend to the previous level and |goto not_found|@>;
11894 mp->delx=mp->delx+stack_1(u_packet(mp->uv))+stack_2(u_packet(mp->uv))
11895 +stack_3(u_packet(mp->uv));
11896 mp->dely=mp->dely+stack_1(v_packet(mp->uv))+stack_2(v_packet(mp->uv))
11897 +stack_3(v_packet(mp->uv));
11898 mp->uv=mp->uv+int_packets; /* switch from |l_packets| to |r_packets| */
11899 decr(mp->cur_tt); mp->xy=mp->xy-int_packets;
11900 /* switch from |r_packets| to |l_packets| */
11901 mp->delx=mp->delx+stack_1(x_packet(mp->xy))+stack_2(x_packet(mp->xy))
11902 +stack_3(x_packet(mp->xy));
11903 mp->dely=mp->dely+stack_1(y_packet(mp->xy))+stack_2(y_packet(mp->xy))
11904 +stack_3(y_packet(mp->xy));
11907 incr(mp->cur_tt); mp->tol=mp->tol+mp->three_l;
11908 mp->delx=mp->delx-stack_1(x_packet(mp->xy))-stack_2(x_packet(mp->xy))
11909 -stack_3(x_packet(mp->xy));
11910 mp->dely=mp->dely-stack_1(y_packet(mp->xy))-stack_2(y_packet(mp->xy))
11911 -stack_3(y_packet(mp->xy));
11912 mp->xy=mp->xy+int_packets; /* switch from |l_packets| to |r_packets| */
11915 @ @<Descend to the previous level...@>=
11917 mp->cur_t=halfp(mp->cur_t); mp->cur_tt=halfp(mp->cur_tt);
11918 if ( mp->cur_t==0 ) return;
11919 mp->bisect_ptr=mp->bisect_ptr-int_increment;
11920 mp->three_l=mp->three_l-mp->tol_step;
11921 mp->delx=stack_dx; mp->dely=stack_dy; mp->tol=stack_tol;
11922 mp->uv=stack_uv; mp->xy=stack_xy;
11926 @ The |path_intersection| procedure is much simpler.
11927 It invokes |cubic_intersection| in lexicographic order until finding a
11928 pair of cubics that intersect. The final intersection times are placed in
11929 |cur_t| and~|cur_tt|.
11932 static void mp_path_intersection (MP mp,pointer h, pointer hh) {
11933 pointer p,pp; /* link registers that traverse the given paths */
11934 integer n,nn; /* integer parts of intersection times, minus |unity| */
11935 @<Change one-point paths into dead cycles@>;
11940 if ( right_type(p)!=mp_endpoint ) {
11943 if ( right_type(pp)!=mp_endpoint ) {
11944 mp_cubic_intersection(mp, p,pp);
11945 if ( mp->cur_t>0 ) {
11946 mp->cur_t=mp->cur_t+n; mp->cur_tt=mp->cur_tt+nn;
11950 nn=nn+unity; pp=mp_link(pp);
11953 n=n+unity; p=mp_link(p);
11955 mp->tol_step=mp->tol_step+3;
11956 } while (mp->tol_step<=3);
11957 mp->cur_t=-unity; mp->cur_tt=-unity;
11960 @ @<Change one-point paths...@>=
11961 if ( right_type(h)==mp_endpoint ) {
11962 right_x(h)=x_coord(h); left_x(h)=x_coord(h);
11963 right_y(h)=y_coord(h); left_y(h)=y_coord(h); right_type(h)=mp_explicit;
11965 if ( right_type(hh)==mp_endpoint ) {
11966 right_x(hh)=x_coord(hh); left_x(hh)=x_coord(hh);
11967 right_y(hh)=y_coord(hh); left_y(hh)=y_coord(hh); right_type(hh)=mp_explicit;
11970 @* \[24] Dynamic linear equations.
11971 \MP\ users define variables implicitly by stating equations that should be
11972 satisfied; the computer is supposed to be smart enough to solve those equations.
11973 And indeed, the computer tries valiantly to do so, by distinguishing five
11974 different types of numeric values:
11977 |type(p)=mp_known| is the nice case, when |value(p)| is the |scaled| value
11978 of the variable whose address is~|p|.
11981 |type(p)=mp_dependent| means that |value(p)| is not present, but |dep_list(p)|
11982 points to a {\sl dependency list\/} that expresses the value of variable~|p|
11983 as a |scaled| number plus a sum of independent variables with |fraction|
11987 |type(p)=mp_independent| means that |value(p)=64s+m|, where |s>0| is a ``serial
11988 number'' reflecting the time this variable was first used in an equation;
11989 also |0<=m<64|, and each dependent variable
11990 that refers to this one is actually referring to the future value of
11991 this variable times~$2^m$. (Usually |m=0|, but higher degrees of
11992 scaling are sometimes needed to keep the coefficients in dependency lists
11993 from getting too large. The value of~|m| will always be even.)
11996 |type(p)=mp_numeric_type| means that variable |p| hasn't appeared in an
11997 equation before, but it has been explicitly declared to be numeric.
12000 |type(p)=undefined| means that variable |p| hasn't appeared before.
12002 \smallskip\noindent
12003 We have actually discussed these five types in the reverse order of their
12004 history during a computation: Once |known|, a variable never again
12005 becomes |dependent|; once |dependent|, it almost never again becomes
12006 |mp_independent|; once |mp_independent|, it never again becomes |mp_numeric_type|;
12007 and once |mp_numeric_type|, it never again becomes |undefined| (except
12008 of course when the user specifically decides to scrap the old value
12009 and start again). A backward step may, however, take place: Sometimes
12010 a |dependent| variable becomes |mp_independent| again, when one of the
12011 independent variables it depends on is reverting to |undefined|.
12014 The next patch detects overflow of independent-variable serial
12015 numbers. Diagnosed and patched by Thorsten Dahlheimer.
12017 @d s_scale 64 /* the serial numbers are multiplied by this factor */
12018 @d new_indep(A) /* create a new independent variable */
12019 { if ( mp->serial_no>el_gordo-s_scale )
12020 mp_fatal_error(mp, "variable instance identifiers exhausted");
12021 type((A))=mp_independent; mp->serial_no=mp->serial_no+s_scale;
12022 value((A))=mp->serial_no;
12026 integer serial_no; /* the most recent serial number, times |s_scale| */
12028 @ @<Make variable |q+s| newly independent@>=new_indep(q+s)
12030 @ But how are dependency lists represented? It's simple: The linear combination
12031 $\alpha_1v_1+\cdots+\alpha_kv_k+\beta$ appears in |k+1| value nodes. If
12032 |q=dep_list(p)| points to this list, and if |k>0|, then |value(q)=
12033 @t$\alpha_1$@>| (which is a |fraction|); |info(q)| points to the location
12034 of $\alpha_1$; and |mp_link(p)| points to the dependency list
12035 $\alpha_2v_2+\cdots+\alpha_kv_k+\beta$. On the other hand if |k=0|,
12036 then |value(q)=@t$\beta$@>| (which is |scaled|) and |info(q)=null|.
12037 The independent variables $v_1$, \dots,~$v_k$ have been sorted so that
12038 they appear in decreasing order of their |value| fields (i.e., of
12039 their serial numbers). \ (It is convenient to use decreasing order,
12040 since |value(null)=0|. If the independent variables were not sorted by
12041 serial number but by some other criterion, such as their location in |mem|,
12042 the equation-solving mechanism would be too system-dependent, because
12043 the ordering can affect the computed results.)
12045 The |link| field in the node that contains the constant term $\beta$ is
12046 called the {\sl final link\/} of the dependency list. \MP\ maintains
12047 a doubly-linked master list of all dependency lists, in terms of a permanently
12049 in |mem| called |dep_head|. If there are no dependencies, we have
12050 |mp_link(dep_head)=dep_head| and |prev_dep(dep_head)=dep_head|;
12051 otherwise |mp_link(dep_head)| points to the first dependent variable, say~|p|,
12052 and |prev_dep(p)=dep_head|. We have |type(p)=mp_dependent|, and |dep_list(p)|
12053 points to its dependency list. If the final link of that dependency list
12054 occurs in location~|q|, then |mp_link(q)| points to the next dependent
12055 variable (say~|r|); and we have |prev_dep(r)=q|, etc.
12057 @d dep_list(A) mp_link(value_loc((A)))
12058 /* half of the |value| field in a |dependent| variable */
12059 @d prev_dep(A) info(value_loc((A)))
12060 /* the other half; makes a doubly linked list */
12061 @d dep_node_size 2 /* the number of words per dependency node */
12063 @<Initialize table entries...@>= mp->serial_no=0;
12064 mp_link(dep_head)=dep_head; prev_dep(dep_head)=dep_head;
12065 info(dep_head)=null; dep_list(dep_head)=null;
12067 @ Actually the description above contains a little white lie. There's
12068 another kind of variable called |mp_proto_dependent|, which is
12069 just like a |dependent| one except that the $\alpha$ coefficients
12070 in its dependency list are |scaled| instead of being fractions.
12071 Proto-dependency lists are mixed with dependency lists in the
12072 nodes reachable from |dep_head|.
12074 @ Here is a procedure that prints a dependency list in symbolic form.
12075 The second parameter should be either |dependent| or |mp_proto_dependent|,
12076 to indicate the scaling of the coefficients.
12079 static void mp_print_dependency (MP mp,pointer p, quarterword t);
12082 void mp_print_dependency (MP mp,pointer p, quarterword t) {
12083 integer v; /* a coefficient */
12084 pointer pp,q; /* for list manipulation */
12087 v=abs(value(p)); q=info(p);
12088 if ( q==null ) { /* the constant term */
12089 if ( (v!=0)||(p==pp) ) {
12090 if ( value(p)>0 ) if ( p!=pp ) mp_print_char(mp, xord('+'));
12091 mp_print_scaled(mp, value(p));
12095 @<Print the coefficient, unless it's $\pm1.0$@>;
12096 if ( type(q)!=mp_independent ) mp_confusion(mp, "dep");
12097 @:this can't happen dep}{\quad dep@>
12098 mp_print_variable_name(mp, q); v=value(q) % s_scale;
12099 while ( v>0 ) { mp_print(mp, "*4"); v=v-2; }
12104 @ @<Print the coefficient, unless it's $\pm1.0$@>=
12105 if ( value(p)<0 ) mp_print_char(mp, xord('-'));
12106 else if ( p!=pp ) mp_print_char(mp, xord('+'));
12107 if ( t==mp_dependent ) v=mp_round_fraction(mp, v);
12108 if ( v!=unity ) mp_print_scaled(mp, v)
12110 @ The maximum absolute value of a coefficient in a given dependency list
12111 is returned by the following simple function.
12114 static fraction mp_max_coef (MP mp,pointer p) {
12115 fraction x; /* the maximum so far */
12117 while ( info(p)!=null ) {
12118 if ( abs(value(p))>x ) x=abs(value(p));
12124 @ One of the main operations needed on dependency lists is to add a multiple
12125 of one list to the other; we call this |p_plus_fq|, where |p| and~|q| point
12126 to dependency lists and |f| is a fraction.
12128 If the coefficient of any independent variable becomes |coef_bound| or
12129 more, in absolute value, this procedure changes the type of that variable
12130 to `|independent_needing_fix|', and sets the global variable |fix_needed|
12131 to~|true|. The value of $|coef_bound|=\mu$ is chosen so that
12132 $\mu^2+\mu<8$; this means that the numbers we deal with won't
12133 get too large. (Instead of the ``optimum'' $\mu=(\sqrt{33}-1)/2\approx
12134 2.3723$, the safer value 7/3 is taken as the threshold.)
12136 The changes mentioned in the preceding paragraph are actually done only if
12137 the global variable |watch_coefs| is |true|. But it usually is; in fact,
12138 it is |false| only when \MP\ is making a dependency list that will soon
12139 be equated to zero.
12141 Several procedures that act on dependency lists, including |p_plus_fq|,
12142 set the global variable |dep_final| to the final (constant term) node of
12143 the dependency list that they produce.
12145 @d coef_bound 04525252525 /* |fraction| approximation to 7/3 */
12146 @d independent_needing_fix 0
12149 boolean fix_needed; /* does at least one |independent| variable need scaling? */
12150 boolean watch_coefs; /* should we scale coefficients that exceed |coef_bound|? */
12151 pointer dep_final; /* location of the constant term and final link */
12154 mp->fix_needed=false; mp->watch_coefs=true;
12156 @ The |p_plus_fq| procedure has a fourth parameter, |t|, that should be
12157 set to |mp_proto_dependent| if |p| is a proto-dependency list. In this
12158 case |f| will be |scaled|, not a |fraction|. Similarly, the fifth parameter~|tt|
12159 should be |mp_proto_dependent| if |q| is a proto-dependency list.
12161 List |q| is unchanged by the operation; but list |p| is totally destroyed.
12163 The final link of the dependency list or proto-dependency list returned
12164 by |p_plus_fq| is the same as the original final link of~|p|. Indeed, the
12165 constant term of the result will be located in the same |mem| location
12166 as the original constant term of~|p|.
12168 Coefficients of the result are assumed to be zero if they are less than
12169 a certain threshold. This compensates for inevitable rounding errors,
12170 and tends to make more variables `|known|'. The threshold is approximately
12171 $10^{-5}$ in the case of normal dependency lists, $10^{-4}$ for
12172 proto-dependencies.
12174 @d fraction_threshold 2685 /* a |fraction| coefficient less than this is zeroed */
12175 @d half_fraction_threshold 1342 /* half of |fraction_threshold| */
12176 @d scaled_threshold 8 /* a |scaled| coefficient less than this is zeroed */
12177 @d half_scaled_threshold 4 /* half of |scaled_threshold| */
12180 static pointer mp_p_plus_fq ( MP mp, pointer p, integer f,
12181 pointer q, quarterword t, quarterword tt) ;
12184 pointer mp_p_plus_fq ( MP mp, pointer p, integer f,
12185 pointer q, quarterword t, quarterword tt) {
12186 pointer pp,qq; /* |info(p)| and |info(q)|, respectively */
12187 pointer r,s; /* for list manipulation */
12188 integer threshold; /* defines a neighborhood of zero */
12189 integer v; /* temporary register */
12190 if ( t==mp_dependent ) threshold=fraction_threshold;
12191 else threshold=scaled_threshold;
12192 r=temp_head; pp=info(p); qq=info(q);
12198 @<Contribute a term from |p|, plus |f| times the
12199 corresponding term from |q|@>
12201 } else if ( value(pp)<value(qq) ) {
12202 @<Contribute a term from |q|, multiplied by~|f|@>
12204 mp_link(r)=p; r=p; p=mp_link(p); pp=info(p);
12207 if ( t==mp_dependent )
12208 value(p)=mp_slow_add(mp, value(p),mp_take_fraction(mp, value(q),f));
12210 value(p)=mp_slow_add(mp, value(p),mp_take_scaled(mp, value(q),f));
12211 mp_link(r)=p; mp->dep_final=p;
12212 return mp_link(temp_head);
12215 @ @<Contribute a term from |p|, plus |f|...@>=
12217 if ( tt==mp_dependent ) v=value(p)+mp_take_fraction(mp, f,value(q));
12218 else v=value(p)+mp_take_scaled(mp, f,value(q));
12219 value(p)=v; s=p; p=mp_link(p);
12220 if ( abs(v)<threshold ) {
12221 mp_free_node(mp, s,dep_node_size);
12223 if ( (abs(v)>=coef_bound) && mp->watch_coefs ) {
12224 type(qq)=independent_needing_fix; mp->fix_needed=true;
12228 pp=info(p); q=mp_link(q); qq=info(q);
12231 @ @<Contribute a term from |q|, multiplied by~|f|@>=
12233 if ( tt==mp_dependent ) v=mp_take_fraction(mp, f,value(q));
12234 else v=mp_take_scaled(mp, f,value(q));
12235 if ( abs(v)>halfp(threshold) ) {
12236 s=mp_get_node(mp, dep_node_size); info(s)=qq; value(s)=v;
12237 if ( (abs(v)>=coef_bound) && mp->watch_coefs ) {
12238 type(qq)=independent_needing_fix; mp->fix_needed=true;
12242 q=mp_link(q); qq=info(q);
12245 @ It is convenient to have another subroutine for the special case
12246 of |p_plus_fq| when |f=1.0|. In this routine lists |p| and |q| are
12247 both of the same type~|t| (either |dependent| or |mp_proto_dependent|).
12250 static pointer mp_p_plus_q (MP mp,pointer p, pointer q, quarterword t) {
12251 pointer pp,qq; /* |info(p)| and |info(q)|, respectively */
12252 pointer r,s; /* for list manipulation */
12253 integer threshold; /* defines a neighborhood of zero */
12254 integer v; /* temporary register */
12255 if ( t==mp_dependent ) threshold=fraction_threshold;
12256 else threshold=scaled_threshold;
12257 r=temp_head; pp=info(p); qq=info(q);
12263 @<Contribute a term from |p|, plus the
12264 corresponding term from |q|@>
12267 if ( value(pp)<value(qq) ) {
12268 s=mp_get_node(mp, dep_node_size); info(s)=qq; value(s)=value(q);
12269 q=mp_link(q); qq=info(q); mp_link(r)=s; r=s;
12271 mp_link(r)=p; r=p; p=mp_link(p); pp=info(p);
12275 value(p)=mp_slow_add(mp, value(p),value(q));
12276 mp_link(r)=p; mp->dep_final=p;
12277 return mp_link(temp_head);
12280 @ @<Contribute a term from |p|, plus the...@>=
12282 v=value(p)+value(q);
12283 value(p)=v; s=p; p=mp_link(p); pp=info(p);
12284 if ( abs(v)<threshold ) {
12285 mp_free_node(mp, s,dep_node_size);
12287 if ( (abs(v)>=coef_bound ) && mp->watch_coefs ) {
12288 type(qq)=independent_needing_fix; mp->fix_needed=true;
12292 q=mp_link(q); qq=info(q);
12295 @ A somewhat simpler routine will multiply a dependency list
12296 by a given constant~|v|. The constant is either a |fraction| less than
12297 |fraction_one|, or it is |scaled|. In the latter case we might be forced to
12298 convert a dependency list to a proto-dependency list.
12299 Parameters |t0| and |t1| are the list types before and after;
12300 they should agree unless |t0=mp_dependent| and |t1=mp_proto_dependent|
12301 and |v_is_scaled=true|.
12304 static pointer mp_p_times_v (MP mp,pointer p, integer v, quarterword t0,
12305 quarterword t1, boolean v_is_scaled) {
12306 pointer r,s; /* for list manipulation */
12307 integer w; /* tentative coefficient */
12309 boolean scaling_down;
12310 if ( t0!=t1 ) scaling_down=true; else scaling_down=(!v_is_scaled);
12311 if ( t1==mp_dependent ) threshold=half_fraction_threshold;
12312 else threshold=half_scaled_threshold;
12314 while ( info(p)!=null ) {
12315 if ( scaling_down ) w=mp_take_fraction(mp, v,value(p));
12316 else w=mp_take_scaled(mp, v,value(p));
12317 if ( abs(w)<=threshold ) {
12318 s=mp_link(p); mp_free_node(mp, p,dep_node_size); p=s;
12320 if ( abs(w)>=coef_bound ) {
12321 mp->fix_needed=true; type(info(p))=independent_needing_fix;
12323 mp_link(r)=p; r=p; value(p)=w; p=mp_link(p);
12327 if ( v_is_scaled ) value(p)=mp_take_scaled(mp, value(p),v);
12328 else value(p)=mp_take_fraction(mp, value(p),v);
12329 return mp_link(temp_head);
12332 @ Similarly, we sometimes need to divide a dependency list
12333 by a given |scaled| constant.
12336 static pointer mp_p_over_v (MP mp,pointer p, scaled v, quarterword
12337 t0, quarterword t1) ;
12340 pointer mp_p_over_v (MP mp,pointer p, scaled v, quarterword
12341 t0, quarterword t1) {
12342 pointer r,s; /* for list manipulation */
12343 integer w; /* tentative coefficient */
12345 boolean scaling_down;
12346 if ( t0!=t1 ) scaling_down=true; else scaling_down=false;
12347 if ( t1==mp_dependent ) threshold=half_fraction_threshold;
12348 else threshold=half_scaled_threshold;
12350 while ( info( p)!=null ) {
12351 if ( scaling_down ) {
12352 if ( abs(v)<02000000 ) w=mp_make_scaled(mp, value(p),v*010000);
12353 else w=mp_make_scaled(mp, mp_round_fraction(mp, value(p)),v);
12355 w=mp_make_scaled(mp, value(p),v);
12357 if ( abs(w)<=threshold ) {
12358 s=mp_link(p); mp_free_node(mp, p,dep_node_size); p=s;
12360 if ( abs(w)>=coef_bound ) {
12361 mp->fix_needed=true; type(info(p))=independent_needing_fix;
12363 mp_link(r)=p; r=p; value(p)=w; p=mp_link(p);
12366 mp_link(r)=p; value(p)=mp_make_scaled(mp, value(p),v);
12367 return mp_link(temp_head);
12370 @ Here's another utility routine for dependency lists. When an independent
12371 variable becomes dependent, we want to remove it from all existing
12372 dependencies. The |p_with_x_becoming_q| function computes the
12373 dependency list of~|p| after variable~|x| has been replaced by~|q|.
12375 This procedure has basically the same calling conventions as |p_plus_fq|:
12376 List~|q| is unchanged; list~|p| is destroyed; the constant node and the
12377 final link are inherited from~|p|; and the fourth parameter tells whether
12378 or not |p| is |mp_proto_dependent|. However, the global variable |dep_final|
12379 is not altered if |x| does not occur in list~|p|.
12382 static pointer mp_p_with_x_becoming_q (MP mp,pointer p,
12383 pointer x, pointer q, quarterword t) {
12384 pointer r,s; /* for list manipulation */
12385 integer v; /* coefficient of |x| */
12386 integer sx; /* serial number of |x| */
12387 s=p; r=temp_head; sx=value(x);
12388 while ( value(info(s))>sx ) { r=s; s=mp_link(s); };
12389 if ( info(s)!=x ) {
12392 mp_link(temp_head)=p; mp_link(r)=mp_link(s); v=value(s);
12393 mp_free_node(mp, s,dep_node_size);
12394 return mp_p_plus_fq(mp, mp_link(temp_head),v,q,t,mp_dependent);
12398 @ Here's a simple procedure that reports an error when a variable
12399 has just received a known value that's out of the required range.
12402 static void mp_val_too_big (MP mp,scaled x) ;
12404 @ @c void mp_val_too_big (MP mp,scaled x) {
12405 if ( mp->internal[mp_warning_check]>0 ) {
12406 print_err("Value is too large ("); mp_print_scaled(mp, x); mp_print_char(mp, xord(')'));
12407 @.Value is too large@>
12408 help4("The equation I just processed has given some variable",
12409 "a value of 4096 or more. Continue and I'll try to cope",
12410 "with that big value; but it might be dangerous.",
12411 "(Set warningcheck:=0 to suppress this message.)");
12416 @ When a dependent variable becomes known, the following routine
12417 removes its dependency list. Here |p| points to the variable, and
12418 |q| points to the dependency list (which is one node long).
12421 static void mp_make_known (MP mp,pointer p, pointer q) ;
12423 @ @c void mp_make_known (MP mp,pointer p, pointer q) {
12424 int t; /* the previous type */
12425 prev_dep(mp_link(q))=prev_dep(p);
12426 mp_link(prev_dep(p))=mp_link(q); t=type(p);
12427 type(p)=mp_known; value(p)=value(q); mp_free_node(mp, q,dep_node_size);
12428 if ( abs(value(p))>=fraction_one ) mp_val_too_big(mp, value(p));
12429 if (( mp->internal[mp_tracing_equations]>0) && mp_interesting(mp, p) ) {
12430 mp_begin_diagnostic(mp); mp_print_nl(mp, "#### ");
12431 @:]]]\#\#\#\#_}{\.{\#\#\#\#}@>
12432 mp_print_variable_name(mp, p);
12433 mp_print_char(mp, xord('=')); mp_print_scaled(mp, value(p));
12434 mp_end_diagnostic(mp, false);
12436 if (( mp->cur_exp==p ) && mp->cur_type==t ) {
12437 mp->cur_type=mp_known; mp->cur_exp=value(p);
12438 mp_free_node(mp, p,value_node_size);
12442 @ The |fix_dependencies| routine is called into action when |fix_needed|
12443 has been triggered. The program keeps a list~|s| of independent variables
12444 whose coefficients must be divided by~4.
12446 In unusual cases, this fixup process might reduce one or more coefficients
12447 to zero, so that a variable will become known more or less by default.
12450 static void mp_fix_dependencies (MP mp);
12453 static void mp_fix_dependencies (MP mp) {
12454 pointer p,q,r,s,t; /* list manipulation registers */
12455 pointer x; /* an independent variable */
12456 r=mp_link(dep_head); s=null;
12457 while ( r!=dep_head ){
12459 @<Run through the dependency list for variable |t|, fixing
12460 all nodes, and ending with final link~|q|@>;
12462 if ( q==dep_list(t) ) mp_make_known(mp, t,q);
12464 while ( s!=null ) {
12465 p=mp_link(s); x=info(s); free_avail(s); s=p;
12466 type(x)=mp_independent; value(x)=value(x)+2;
12468 mp->fix_needed=false;
12471 @ @d independent_being_fixed 1 /* this variable already appears in |s| */
12473 @<Run through the dependency list for variable |t|...@>=
12474 r=value_loc(t); /* |mp_link(r)=dep_list(t)| */
12476 q=mp_link(r); x=info(q);
12477 if ( x==null ) break;
12478 if ( type(x)<=independent_being_fixed ) {
12479 if ( type(x)<independent_being_fixed ) {
12480 p=mp_get_avail(mp); mp_link(p)=s; s=p;
12481 info(s)=x; type(x)=independent_being_fixed;
12483 value(q)=value(q) / 4;
12484 if ( value(q)==0 ) {
12485 mp_link(r)=mp_link(q); mp_free_node(mp, q,dep_node_size); q=r;
12492 @ The |new_dep| routine installs a dependency list~|p| into the value node~|q|,
12493 linking it into the list of all known dependencies. We assume that
12494 |dep_final| points to the final node of list~|p|.
12497 static void mp_new_dep (MP mp,pointer q, pointer p) {
12498 pointer r; /* what used to be the first dependency */
12499 dep_list(q)=p; prev_dep(q)=dep_head;
12500 r=mp_link(dep_head); mp_link(mp->dep_final)=r; prev_dep(r)=mp->dep_final;
12501 mp_link(dep_head)=q;
12504 @ Here is one of the ways a dependency list gets started.
12505 The |const_dependency| routine produces a list that has nothing but
12508 @c static pointer mp_const_dependency (MP mp, scaled v) {
12509 mp->dep_final=mp_get_node(mp, dep_node_size);
12510 value(mp->dep_final)=v; info(mp->dep_final)=null;
12511 return mp->dep_final;
12514 @ And here's a more interesting way to start a dependency list from scratch:
12515 The parameter to |single_dependency| is the location of an
12516 independent variable~|x|, and the result is the simple dependency list
12519 In the unlikely event that the given independent variable has been doubled so
12520 often that we can't refer to it with a nonzero coefficient,
12521 |single_dependency| returns the simple list `0'. This case can be
12522 recognized by testing that the returned list pointer is equal to
12526 static pointer mp_single_dependency (MP mp,pointer p) {
12527 pointer q; /* the new dependency list */
12528 integer m; /* the number of doublings */
12529 m=value(p) % s_scale;
12531 return mp_const_dependency(mp, 0);
12533 q=mp_get_node(mp, dep_node_size);
12534 value(q)=(integer)two_to_the(28-m); info(q)=p;
12535 mp_link(q)=mp_const_dependency(mp, 0);
12540 @ We sometimes need to make an exact copy of a dependency list.
12543 static pointer mp_copy_dep_list (MP mp,pointer p) {
12544 pointer q; /* the new dependency list */
12545 q=mp_get_node(mp, dep_node_size); mp->dep_final=q;
12547 info(mp->dep_final)=info(p); value(mp->dep_final)=value(p);
12548 if ( info(mp->dep_final)==null ) break;
12549 mp_link(mp->dep_final)=mp_get_node(mp, dep_node_size);
12550 mp->dep_final=mp_link(mp->dep_final); p=mp_link(p);
12555 @ But how do variables normally become known? Ah, now we get to the heart of the
12556 equation-solving mechanism. The |linear_eq| procedure is given a |dependent|
12557 or |mp_proto_dependent| list,~|p|, in which at least one independent variable
12558 appears. It equates this list to zero, by choosing an independent variable
12559 with the largest coefficient and making it dependent on the others. The
12560 newly dependent variable is eliminated from all current dependencies,
12561 thereby possibly making other dependent variables known.
12563 The given list |p| is, of course, totally destroyed by all this processing.
12566 static void mp_linear_eq (MP mp, pointer p, quarterword t) {
12567 pointer q,r,s; /* for link manipulation */
12568 pointer x; /* the variable that loses its independence */
12569 integer n; /* the number of times |x| had been halved */
12570 integer v; /* the coefficient of |x| in list |p| */
12571 pointer prev_r; /* lags one step behind |r| */
12572 pointer final_node; /* the constant term of the new dependency list */
12573 integer w; /* a tentative coefficient */
12574 @<Find a node |q| in list |p| whose coefficient |v| is largest@>;
12575 x=info(q); n=value(x) % s_scale;
12576 @<Divide list |p| by |-v|, removing node |q|@>;
12577 if ( mp->internal[mp_tracing_equations]>0 ) {
12578 @<Display the new dependency@>;
12580 @<Simplify all existing dependencies by substituting for |x|@>;
12581 @<Change variable |x| from |independent| to |dependent| or |known|@>;
12582 if ( mp->fix_needed ) mp_fix_dependencies(mp);
12585 @ @<Find a node |q| in list |p| whose coefficient |v| is largest@>=
12586 q=p; r=mp_link(p); v=value(q);
12587 while ( info(r)!=null ) {
12588 if ( abs(value(r))>abs(v) ) { q=r; v=value(r); };
12592 @ Here we want to change the coefficients from |scaled| to |fraction|,
12593 except in the constant term. In the common case of a trivial equation
12594 like `\.{x=3.14}', we will have |v=-fraction_one|, |q=p|, and |t=mp_dependent|.
12596 @<Divide list |p| by |-v|, removing node |q|@>=
12597 s=temp_head; mp_link(s)=p; r=p;
12600 mp_link(s)=mp_link(r); mp_free_node(mp, r,dep_node_size);
12602 w=mp_make_fraction(mp, value(r),v);
12603 if ( abs(w)<=half_fraction_threshold ) {
12604 mp_link(s)=mp_link(r); mp_free_node(mp, r,dep_node_size);
12610 } while (info(r)!=null);
12611 if ( t==mp_proto_dependent ) {
12612 value(r)=-mp_make_scaled(mp, value(r),v);
12613 } else if ( v!=-fraction_one ) {
12614 value(r)=-mp_make_fraction(mp, value(r),v);
12616 final_node=r; p=mp_link(temp_head)
12618 @ @<Display the new dependency@>=
12619 if ( mp_interesting(mp, x) ) {
12620 mp_begin_diagnostic(mp); mp_print_nl(mp, "## ");
12621 mp_print_variable_name(mp, x);
12622 @:]]]\#\#_}{\.{\#\#}@>
12624 while ( w>0 ) { mp_print(mp, "*4"); w=w-2; };
12625 mp_print_char(mp, xord('=')); mp_print_dependency(mp, p,mp_dependent);
12626 mp_end_diagnostic(mp, false);
12629 @ @<Simplify all existing dependencies by substituting for |x|@>=
12630 prev_r=dep_head; r=mp_link(dep_head);
12631 while ( r!=dep_head ) {
12632 s=dep_list(r); q=mp_p_with_x_becoming_q(mp, s,x,p,type(r));
12633 if ( info(q)==null ) {
12634 mp_make_known(mp, r,q);
12637 do { q=mp_link(q); } while (info(q)!=null);
12643 @ @<Change variable |x| from |independent| to |dependent| or |known|@>=
12644 if ( n>0 ) @<Divide list |p| by $2^n$@>;
12645 if ( info(p)==null ) {
12648 if ( abs(value(x))>=fraction_one ) mp_val_too_big(mp, value(x));
12649 mp_free_node(mp, p,dep_node_size);
12650 if ( mp->cur_exp==x ) if ( mp->cur_type==mp_independent ) {
12651 mp->cur_exp=value(x); mp->cur_type=mp_known;
12652 mp_free_node(mp, x,value_node_size);
12655 type(x)=mp_dependent; mp->dep_final=final_node; mp_new_dep(mp, x,p);
12656 if ( mp->cur_exp==x ) if ( mp->cur_type==mp_independent ) mp->cur_type=mp_dependent;
12659 @ @<Divide list |p| by $2^n$@>=
12661 s=temp_head; mp_link(temp_head)=p; r=p;
12664 else w=value(r) / two_to_the(n);
12665 if ( (abs(w)<=half_fraction_threshold)&&(info(r)!=null) ) {
12666 mp_link(s)=mp_link(r);
12667 mp_free_node(mp, r,dep_node_size);
12672 } while (info(s)!=null);
12673 p=mp_link(temp_head);
12676 @ The |check_mem| procedure, which is used only when \MP\ is being
12677 debugged, makes sure that the current dependency lists are well formed.
12679 @<Check the list of linear dependencies@>=
12680 q=dep_head; p=mp_link(q);
12681 while ( p!=dep_head ) {
12682 if ( prev_dep(p)!=q ) {
12683 mp_print_nl(mp, "Bad PREVDEP at "); mp_print_int(mp, p);
12688 r=info(p); q=p; p=mp_link(q);
12689 if ( r==null ) break;
12690 if ( value(info(p))>=value(r) ) {
12691 mp_print_nl(mp, "Out of order at "); mp_print_int(mp, p);
12692 @.Out of order...@>
12697 @* \[25] Dynamic nonlinear equations.
12698 Variables of numeric type are maintained by the general scheme of
12699 independent, dependent, and known values that we have just studied;
12700 and the components of pair and transform variables are handled in the
12701 same way. But \MP\ also has five other types of values: \&{boolean},
12702 \&{string}, \&{pen}, \&{path}, and \&{picture}; what about them?
12704 Equations are allowed between nonlinear quantities, but only in a
12705 simple form. Two variables that haven't yet been assigned values are
12706 either equal to each other, or they're not.
12708 Before a boolean variable has received a value, its type is |mp_unknown_boolean|;
12709 similarly, there are variables whose type is |mp_unknown_string|, |mp_unknown_pen|,
12710 |mp_unknown_path|, and |mp_unknown_picture|. In such cases the value is either
12711 |null| (which means that no other variables are equivalent to this one), or
12712 it points to another variable of the same undefined type. The pointers in the
12713 latter case form a cycle of nodes, which we shall call a ``ring.''
12714 Rings of undefined variables may include capsules, which arise as
12715 intermediate results within expressions or as \&{expr} parameters to macros.
12717 When one member of a ring receives a value, the same value is given to
12718 all the other members. In the case of paths and pictures, this implies
12719 making separate copies of a potentially large data structure; users should
12720 restrain their enthusiasm for such generality, unless they have lots and
12721 lots of memory space.
12723 @ The following procedure is called when a capsule node is being
12724 added to a ring (e.g., when an unknown variable is mentioned in an expression).
12727 static pointer mp_new_ring_entry (MP mp,pointer p) {
12728 pointer q; /* the new capsule node */
12729 q=mp_get_node(mp, value_node_size); name_type(q)=mp_capsule;
12731 if ( value(p)==null ) value(q)=p; else value(q)=value(p);
12736 @ Conversely, we might delete a capsule or a variable before it becomes known.
12737 The following procedure simply detaches a quantity from its ring,
12738 without recycling the storage.
12741 static void mp_ring_delete (MP mp,pointer p);
12744 void mp_ring_delete (MP mp,pointer p) {
12747 if ( q!=null ) if ( q!=p ){
12748 while ( value(q)!=p ) q=value(q);
12753 @ Eventually there might be an equation that assigns values to all of the
12754 variables in a ring. The |nonlinear_eq| subroutine does the necessary
12755 propagation of values.
12757 If the parameter |flush_p| is |true|, node |p| itself needn't receive a
12758 value, it will soon be recycled.
12761 static void mp_nonlinear_eq (MP mp,integer v, pointer p, boolean flush_p) {
12762 quarterword t; /* the type of ring |p| */
12763 pointer q,r; /* link manipulation registers */
12764 t=type(p)-unknown_tag; q=value(p);
12765 if ( flush_p ) type(p)=mp_vacuous; else p=q;
12767 r=value(q); type(q)=t;
12769 case mp_boolean_type: value(q)=v; break;
12770 case mp_string_type: value(q)=v; add_str_ref(v); break;
12771 case mp_pen_type: value(q)=copy_pen(v); break;
12772 case mp_path_type: value(q)=mp_copy_path(mp, v); break;
12773 case mp_picture_type: value(q)=v; add_edge_ref(v); break;
12774 } /* there ain't no more cases */
12779 @ If two members of rings are equated, and if they have the same type,
12780 the |ring_merge| procedure is called on to make them equivalent.
12783 static void mp_ring_merge (MP mp,pointer p, pointer q) {
12784 pointer r; /* traverses one list */
12788 @<Exclaim about a redundant equation@>;
12793 r=value(p); value(p)=value(q); value(q)=r;
12796 @ @<Exclaim about a redundant equation@>=
12798 print_err("Redundant equation");
12799 @.Redundant equation@>
12800 help2("I already knew that this equation was true.",
12801 "But perhaps no harm has been done; let's continue.");
12802 mp_put_get_error(mp);
12805 @* \[26] Introduction to the syntactic routines.
12806 Let's pause a moment now and try to look at the Big Picture.
12807 The \MP\ program consists of three main parts: syntactic routines,
12808 semantic routines, and output routines. The chief purpose of the
12809 syntactic routines is to deliver the user's input to the semantic routines,
12810 while parsing expressions and locating operators and operands. The
12811 semantic routines act as an interpreter responding to these operators,
12812 which may be regarded as commands. And the output routines are
12813 periodically called on to produce compact font descriptions that can be
12814 used for typesetting or for making interim proof drawings. We have
12815 discussed the basic data structures and many of the details of semantic
12816 operations, so we are good and ready to plunge into the part of \MP\ that
12817 actually controls the activities.
12819 Our current goal is to come to grips with the |get_next| procedure,
12820 which is the keystone of \MP's input mechanism. Each call of |get_next|
12821 sets the value of three variables |cur_cmd|, |cur_mod|, and |cur_sym|,
12822 representing the next input token.
12823 $$\vbox{\halign{#\hfil\cr
12824 \hbox{|cur_cmd| denotes a command code from the long list of codes
12826 \hbox{|cur_mod| denotes a modifier of the command code;}\cr
12827 \hbox{|cur_sym| is the hash address of the symbolic token that was
12829 \hbox{\qquad or zero in the case of a numeric or string
12830 or capsule token.}\cr}}$$
12831 Underlying this external behavior of |get_next| is all the machinery
12832 necessary to convert from character files to tokens. At a given time we
12833 may be only partially finished with the reading of several files (for
12834 which \&{input} was specified), and partially finished with the expansion
12835 of some user-defined macros and/or some macro parameters, and partially
12836 finished reading some text that the user has inserted online,
12837 and so on. When reading a character file, the characters must be
12838 converted to tokens; comments and blank spaces must
12839 be removed, numeric and string tokens must be evaluated.
12841 To handle these situations, which might all be present simultaneously,
12842 \MP\ uses various stacks that hold information about the incomplete
12843 activities, and there is a finite state control for each level of the
12844 input mechanism. These stacks record the current state of an implicitly
12845 recursive process, but the |get_next| procedure is not recursive.
12848 integer cur_cmd; /* current command set by |get_next| */
12849 integer cur_mod; /* operand of current command */
12850 halfword cur_sym; /* hash address of current symbol */
12852 @ The |print_cmd_mod| routine prints a symbolic interpretation of a
12853 command code and its modifier.
12854 It consists of a rather tedious sequence of print
12855 commands, and most of it is essentially an inverse to the |primitive|
12856 routine that enters a \MP\ primitive into |hash| and |eqtb|. Therefore almost
12857 all of this procedure appears elsewhere in the program, together with the
12858 corresponding |primitive| calls.
12861 static void mp_print_cmd_mod (MP mp,integer c, integer m) ;
12864 void mp_print_cmd_mod (MP mp,integer c, integer m) {
12866 @<Cases of |print_cmd_mod| for symbolic printing of primitives@>
12867 default: mp_print(mp, "[unknown command code!]"); break;
12871 @ Here is a procedure that displays a given command in braces, in the
12872 user's transcript file.
12874 @d show_cur_cmd_mod mp_show_cmd_mod(mp, mp->cur_cmd,mp->cur_mod)
12877 static void mp_show_cmd_mod (MP mp,integer c, integer m) {
12878 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
12879 mp_print_cmd_mod(mp, c,m); mp_print_char(mp, xord('}'));
12880 mp_end_diagnostic(mp, false);
12883 @* \[27] Input stacks and states.
12884 The state of \MP's input mechanism appears in the input stack, whose
12885 entries are records with five fields, called |index|, |start|, |loc|,
12886 |limit|, and |name|. The top element of this stack is maintained in a
12887 global variable for which no subscripting needs to be done; the other
12888 elements of the stack appear in an array. Hence the stack is declared thus:
12892 quarterword index_field;
12893 halfword start_field, loc_field, limit_field, name_field;
12897 in_state_record *input_stack;
12898 integer input_ptr; /* first unused location of |input_stack| */
12899 integer max_in_stack; /* largest value of |input_ptr| when pushing */
12900 in_state_record cur_input; /* the ``top'' input state */
12901 int stack_size; /* maximum number of simultaneous input sources */
12903 @ @<Allocate or initialize ...@>=
12904 mp->stack_size = 300;
12905 mp->input_stack = xmalloc((mp->stack_size+1),sizeof(in_state_record));
12907 @ @<Dealloc variables@>=
12908 xfree(mp->input_stack);
12910 @ We've already defined the special variable |loc==cur_input.loc_field|
12911 in our discussion of basic input-output routines. The other components of
12912 |cur_input| are defined in the same way:
12914 @d iindex mp->cur_input.index_field /* reference for buffer information */
12915 @d start mp->cur_input.start_field /* starting position in |buffer| */
12916 @d limit mp->cur_input.limit_field /* end of current line in |buffer| */
12917 @d name mp->cur_input.name_field /* name of the current file */
12919 @ Let's look more closely now at the five control variables
12920 (|index|,~|start|,~|loc|,~|limit|,~|name|),
12921 assuming that \MP\ is reading a line of characters that have been input
12922 from some file or from the user's terminal. There is an array called
12923 |buffer| that acts as a stack of all lines of characters that are
12924 currently being read from files, including all lines on subsidiary
12925 levels of the input stack that are not yet completed. \MP\ will return to
12926 the other lines when it is finished with the present input file.
12928 (Incidentally, on a machine with byte-oriented addressing, it would be
12929 appropriate to combine |buffer| with the |str_pool| array,
12930 letting the buffer entries grow downward from the top of the string pool
12931 and checking that these two tables don't bump into each other.)
12933 The line we are currently working on begins in position |start| of the
12934 buffer; the next character we are about to read is |buffer[loc]|; and
12935 |limit| is the location of the last character present. We always have
12936 |loc<=limit|. For convenience, |buffer[limit]| has been set to |"%"|, so
12937 that the end of a line is easily sensed.
12939 The |name| variable is a string number that designates the name of
12940 the current file, if we are reading an ordinary text file. Special codes
12941 |is_term..max_spec_src| indicate other sources of input text.
12943 @d is_term 0 /* |name| value when reading from the terminal for normal input */
12944 @d is_read 1 /* |name| value when executing a \&{readstring} or \&{readfrom} */
12945 @d is_scantok 2 /* |name| value when reading text generated by \&{scantokens} */
12946 @d max_spec_src is_scantok
12948 @ Additional information about the current line is available via the
12949 |index| variable, which counts how many lines of characters are present
12950 in the buffer below the current level. We have |index=0| when reading
12951 from the terminal and prompting the user for each line; then if the user types,
12952 e.g., `\.{input figs}', we will have |index=1| while reading
12953 the file \.{figs.mp}. However, it does not follow that |index| is the
12954 same as the input stack pointer, since many of the levels on the input
12955 stack may come from token lists and some |index| values may correspond
12956 to \.{MPX} files that are not currently on the stack.
12958 The global variable |in_open| is equal to the highest |index| value counting
12959 \.{MPX} files but excluding token-list input levels. Thus, the number of
12960 partially read lines in the buffer is |in_open+1| and we have |in_open>=index|
12961 when we are not reading a token list.
12963 If we are not currently reading from the terminal,
12964 we are reading from the file variable |input_file[index]|. We use
12965 the notation |terminal_input| as a convenient abbreviation for |name=is_term|,
12966 and |cur_file| as an abbreviation for |input_file[index]|.
12968 When \MP\ is not reading from the terminal, the global variable |line| contains
12969 the line number in the current file, for use in error messages. More precisely,
12970 |line| is a macro for |line_stack[index]| and the |line_stack| array gives
12971 the line number for each file in the |input_file| array.
12973 When an \.{MPX} file is opened the file name is stored in the |mpx_name|
12974 array so that the name doesn't get lost when the file is temporarily removed
12975 from the input stack.
12976 Thus when |input_file[k]| is an \.{MPX} file, its name is |mpx_name[k]|
12977 and it contains translated \TeX\ pictures for |input_file[k-1]|.
12978 Since this is not an \.{MPX} file, we have
12979 $$ \hbox{|mpx_name[k-1]<=absent|}. $$
12980 This |name| field is set to |finished| when |input_file[k]| is completely
12983 If more information about the input state is needed, it can be
12984 included in small arrays like those shown here. For example,
12985 the current page or segment number in the input file might be put
12986 into a variable |page|, that is really a macro for the current entry
12987 in `\ignorespaces|page_stack:array[0..max_in_open] of integer|\unskip'
12988 by analogy with |line_stack|.
12989 @^system dependencies@>
12991 @d terminal_input (name==is_term) /* are we reading from the terminal? */
12992 @d cur_file mp->input_file[iindex] /* the current |void *| variable */
12993 @d line mp->line_stack[iindex] /* current line number in the current source file */
12994 @d in_name mp->iname_stack[iindex] /* a string used to construct \.{MPX} file names */
12995 @d in_area mp->iarea_stack[iindex] /* another string for naming \.{MPX} files */
12996 @d absent 1 /* |name_field| value for unused |mpx_in_stack| entries */
12997 @d mpx_reading (mp->mpx_name[iindex]>absent)
12998 /* when reading a file, is it an \.{MPX} file? */
13000 /* |name_field| value when the corresponding \.{MPX} file is finished */
13003 integer in_open; /* the number of lines in the buffer, less one */
13004 unsigned int open_parens; /* the number of open text files */
13005 void * *input_file ;
13006 integer *line_stack ; /* the line number for each file */
13007 char * *iname_stack; /* used for naming \.{MPX} files */
13008 char * *iarea_stack; /* used for naming \.{MPX} files */
13009 halfword*mpx_name ;
13011 @ @<Allocate or ...@>=
13012 mp->input_file = xmalloc((mp->max_in_open+1),sizeof(void *));
13013 mp->line_stack = xmalloc((mp->max_in_open+1),sizeof(integer));
13014 mp->iname_stack = xmalloc((mp->max_in_open+1),sizeof(char *));
13015 mp->iarea_stack = xmalloc((mp->max_in_open+1),sizeof(char *));
13016 mp->mpx_name = xmalloc((mp->max_in_open+1),sizeof(halfword));
13019 for (k=0;k<=mp->max_in_open;k++) {
13020 mp->iname_stack[k] =NULL;
13021 mp->iarea_stack[k] =NULL;
13025 @ @<Dealloc variables@>=
13028 for (l=0;l<=mp->max_in_open;l++) {
13029 xfree(mp->iname_stack[l]);
13030 xfree(mp->iarea_stack[l]);
13033 xfree(mp->input_file);
13034 xfree(mp->line_stack);
13035 xfree(mp->iname_stack);
13036 xfree(mp->iarea_stack);
13037 xfree(mp->mpx_name);
13040 @ However, all this discussion about input state really applies only to the
13041 case that we are inputting from a file. There is another important case,
13042 namely when we are currently getting input from a token list. In this case
13043 |iindex>max_in_open|, and the conventions about the other state variables
13046 \yskip\hang|loc| is a pointer to the current node in the token list, i.e.,
13047 the node that will be read next. If |loc=null|, the token list has been
13050 \yskip\hang|start| points to the first node of the token list; this node
13051 may or may not contain a reference count, depending on the type of token
13054 \yskip\hang|token_type|, which takes the place of |iindex| in the
13055 discussion above, is a code number that explains what kind of token list
13058 \yskip\hang|name| points to the |eqtb| address of the control sequence
13059 being expanded, if the current token list is a macro not defined by
13060 \&{vardef}. Macros defined by \&{vardef} have |name=null|; their name
13061 can be deduced by looking at their first two parameters.
13063 \yskip\hang|param_start|, which takes the place of |limit|, tells where
13064 the parameters of the current macro or loop text begin in the |param_stack|.
13066 \yskip\noindent The |token_type| can take several values, depending on
13067 where the current token list came from:
13070 \indent|forever_text|, if the token list being scanned is the body of
13071 a \&{forever} loop;
13073 \indent|loop_text|, if the token list being scanned is the body of
13074 a \&{for} or \&{forsuffixes} loop;
13076 \indent|parameter|, if a \&{text} or \&{suffix} parameter is being scanned;
13078 \indent|backed_up|, if the token list being scanned has been inserted as
13079 `to be read again'.
13081 \indent|inserted|, if the token list being scanned has been inserted as
13082 part of error recovery;
13084 \indent|macro|, if the expansion of a user-defined symbolic token is being
13088 The token list begins with a reference count if and only if |token_type=
13090 @^reference counts@>
13092 @d token_type iindex /* type of current token list */
13093 @d token_state (iindex>(int)mp->max_in_open) /* are we scanning a token list? */
13094 @d file_state (iindex<=(int)mp->max_in_open) /* are we scanning a file line? */
13095 @d param_start limit /* base of macro parameters in |param_stack| */
13096 @d forever_text (mp->max_in_open+1) /* |token_type| code for loop texts */
13097 @d loop_text (mp->max_in_open+2) /* |token_type| code for loop texts */
13098 @d parameter (mp->max_in_open+3) /* |token_type| code for parameter texts */
13099 @d backed_up (mp->max_in_open+4) /* |token_type| code for texts to be reread */
13100 @d inserted (mp->max_in_open+5) /* |token_type| code for inserted texts */
13101 @d macro (mp->max_in_open+6) /* |token_type| code for macro replacement texts */
13103 @ The |param_stack| is an auxiliary array used to hold pointers to the token
13104 lists for parameters at the current level and subsidiary levels of input.
13105 This stack grows at a different rate from the others.
13108 pointer *param_stack; /* token list pointers for parameters */
13109 integer param_ptr; /* first unused entry in |param_stack| */
13110 integer max_param_stack; /* largest value of |param_ptr| */
13112 @ @<Allocate or initialize ...@>=
13113 mp->param_stack = xmalloc((mp->param_size+1),sizeof(pointer));
13115 @ @<Dealloc variables@>=
13116 xfree(mp->param_stack);
13118 @ Notice that the |line| isn't valid when |token_state| is true because it
13119 depends on |iindex|. If we really need to know the line number for the
13120 topmost file in the iindex stack we use the following function. If a page
13121 number or other information is needed, this routine should be modified to
13122 compute it as well.
13123 @^system dependencies@>
13126 static integer mp_true_line (MP mp) ;
13129 integer mp_true_line (MP mp) {
13130 int k; /* an index into the input stack */
13131 if ( file_state && (name>max_spec_src) ) {
13136 ((mp->input_stack[(k-1)].index_field>mp->max_in_open)||
13137 (mp->input_stack[(k-1)].name_field<=max_spec_src))) {
13140 return (k>0 ? mp->line_stack[(k-1)] : 0 );
13144 @ Thus, the ``current input state'' can be very complicated indeed; there
13145 can be many levels and each level can arise in a variety of ways. The
13146 |show_context| procedure, which is used by \MP's error-reporting routine to
13147 print out the current input state on all levels down to the most recent
13148 line of characters from an input file, illustrates most of these conventions.
13149 The global variable |file_ptr| contains the lowest level that was
13150 displayed by this procedure.
13153 integer file_ptr; /* shallowest level shown by |show_context| */
13155 @ The status at each level is indicated by printing two lines, where the first
13156 line indicates what was read so far and the second line shows what remains
13157 to be read. The context is cropped, if necessary, so that the first line
13158 contains at most |half_error_line| characters, and the second contains
13159 at most |error_line|. Non-current input levels whose |token_type| is
13160 `|backed_up|' are shown only if they have not been fully read.
13162 @c void mp_show_context (MP mp) { /* prints where the scanner is */
13163 unsigned old_setting; /* saved |selector| setting */
13164 @<Local variables for formatting calculations@>
13165 mp->file_ptr=mp->input_ptr; mp->input_stack[mp->file_ptr]=mp->cur_input;
13166 /* store current state */
13168 mp->cur_input=mp->input_stack[mp->file_ptr]; /* enter into the context */
13169 @<Display the current context@>;
13171 if ( (name>max_spec_src) || (mp->file_ptr==0) ) break;
13172 decr(mp->file_ptr);
13174 mp->cur_input=mp->input_stack[mp->input_ptr]; /* restore original state */
13177 @ @<Display the current context@>=
13178 if ( (mp->file_ptr==mp->input_ptr) || file_state ||
13179 (token_type!=backed_up) || (loc!=null) ) {
13180 /* we omit backed-up token lists that have already been read */
13181 mp->tally=0; /* get ready to count characters */
13182 old_setting=mp->selector;
13183 if ( file_state ) {
13184 @<Print location of current line@>;
13185 @<Pseudoprint the line@>;
13187 @<Print type of token list@>;
13188 @<Pseudoprint the token list@>;
13190 mp->selector=old_setting; /* stop pseudoprinting */
13191 @<Print two lines using the tricky pseudoprinted information@>;
13194 @ This routine should be changed, if necessary, to give the best possible
13195 indication of where the current line resides in the input file.
13196 For example, on some systems it is best to print both a page and line number.
13197 @^system dependencies@>
13199 @<Print location of current line@>=
13200 if ( name>max_spec_src ) {
13201 mp_print_nl(mp, "l."); mp_print_int(mp, mp_true_line(mp));
13202 } else if ( terminal_input ) {
13203 if ( mp->file_ptr==0 ) mp_print_nl(mp, "<*>");
13204 else mp_print_nl(mp, "<insert>");
13205 } else if ( name==is_scantok ) {
13206 mp_print_nl(mp, "<scantokens>");
13208 mp_print_nl(mp, "<read>");
13210 mp_print_char(mp, xord(' '))
13212 @ Can't use case statement here because the |token_type| is not
13213 a constant expression.
13215 @<Print type of token list@>=
13217 if(token_type==forever_text) {
13218 mp_print_nl(mp, "<forever> ");
13219 } else if (token_type==loop_text) {
13220 @<Print the current loop value@>;
13221 } else if (token_type==parameter) {
13222 mp_print_nl(mp, "<argument> ");
13223 } else if (token_type==backed_up) {
13224 if ( loc==null ) mp_print_nl(mp, "<recently read> ");
13225 else mp_print_nl(mp, "<to be read again> ");
13226 } else if (token_type==inserted) {
13227 mp_print_nl(mp, "<inserted text> ");
13228 } else if (token_type==macro) {
13230 if ( name!=null ) mp_print_text(name);
13231 else @<Print the name of a \&{vardef}'d macro@>;
13232 mp_print(mp, "->");
13234 mp_print_nl(mp, "?");/* this should never happen */
13239 @ The parameter that corresponds to a loop text is either a token list
13240 (in the case of \&{forsuffixes}) or a ``capsule'' (in the case of \&{for}).
13241 We'll discuss capsules later; for now, all we need to know is that
13242 the |link| field in a capsule parameter is |void| and that
13243 |print_exp(p,0)| displays the value of capsule~|p| in abbreviated form.
13245 @<Print the current loop value@>=
13246 { mp_print_nl(mp, "<for("); p=mp->param_stack[param_start];
13248 if ( mp_link(p)==mp_void ) mp_print_exp(mp, p,0); /* we're in a \&{for} loop */
13249 else mp_show_token_list(mp, p,null,20,mp->tally);
13251 mp_print(mp, ")> ");
13254 @ The first two parameters of a macro defined by \&{vardef} will be token
13255 lists representing the macro's prefix and ``at point.'' By putting these
13256 together, we get the macro's full name.
13258 @<Print the name of a \&{vardef}'d macro@>=
13259 { p=mp->param_stack[param_start];
13261 mp_show_token_list(mp, mp->param_stack[param_start+1],null,20,mp->tally);
13264 while ( mp_link(q)!=null ) q=mp_link(q);
13265 mp_link(q)=mp->param_stack[param_start+1];
13266 mp_show_token_list(mp, p,null,20,mp->tally);
13271 @ Now it is necessary to explain a little trick. We don't want to store a long
13272 string that corresponds to a token list, because that string might take up
13273 lots of memory; and we are printing during a time when an error message is
13274 being given, so we dare not do anything that might overflow one of \MP's
13275 tables. So `pseudoprinting' is the answer: We enter a mode of printing
13276 that stores characters into a buffer of length |error_line|, where character
13277 $k+1$ is placed into \hbox{|trick_buf[k mod error_line]|} if
13278 |k<trick_count|, otherwise character |k| is dropped. Initially we set
13279 |tally:=0| and |trick_count:=1000000|; then when we reach the
13280 point where transition from line 1 to line 2 should occur, we
13281 set |first_count:=tally| and |trick_count:=@tmax@>(error_line,
13282 tally+1+error_line-half_error_line)|. At the end of the
13283 pseudoprinting, the values of |first_count|, |tally|, and
13284 |trick_count| give us all the information we need to print the two lines,
13285 and all of the necessary text is in |trick_buf|.
13287 Namely, let |l| be the length of the descriptive information that appears
13288 on the first line. The length of the context information gathered for that
13289 line is |k=first_count|, and the length of the context information
13290 gathered for line~2 is $m=\min(|tally|, |trick_count|)-k$. If |l+k<=h|,
13291 where |h=half_error_line|, we print |trick_buf[0..k-1]| after the
13292 descriptive information on line~1, and set |n:=l+k|; here |n| is the
13293 length of line~1. If $l+k>h$, some cropping is necessary, so we set |n:=h|
13294 and print `\.{...}' followed by
13295 $$\hbox{|trick_buf[(l+k-h+3)..k-1]|,}$$
13296 where subscripts of |trick_buf| are circular modulo |error_line|. The
13297 second line consists of |n|~spaces followed by |trick_buf[k..(k+m-1)]|,
13298 unless |n+m>error_line|; in the latter case, further cropping is done.
13299 This is easier to program than to explain.
13301 @<Local variables for formatting...@>=
13302 int i; /* index into |buffer| */
13303 integer l; /* length of descriptive information on line 1 */
13304 integer m; /* context information gathered for line 2 */
13305 int n; /* length of line 1 */
13306 integer p; /* starting or ending place in |trick_buf| */
13307 integer q; /* temporary index */
13309 @ The following code tells the print routines to gather
13310 the desired information.
13312 @d begin_pseudoprint {
13313 l=mp->tally; mp->tally=0; mp->selector=pseudo;
13314 mp->trick_count=1000000;
13316 @d set_trick_count {
13317 mp->first_count=mp->tally;
13318 mp->trick_count=mp->tally+1+mp->error_line-mp->half_error_line;
13319 if ( mp->trick_count<mp->error_line ) mp->trick_count=mp->error_line;
13322 @ And the following code uses the information after it has been gathered.
13324 @<Print two lines using the tricky pseudoprinted information@>=
13325 if ( mp->trick_count==1000000 ) set_trick_count;
13326 /* |set_trick_count| must be performed */
13327 if ( mp->tally<mp->trick_count ) m=mp->tally-mp->first_count;
13328 else m=mp->trick_count-mp->first_count; /* context on line 2 */
13329 if ( l+mp->first_count<=mp->half_error_line ) {
13330 p=0; n=l+mp->first_count;
13332 mp_print(mp, "..."); p=l+mp->first_count-mp->half_error_line+3;
13333 n=mp->half_error_line;
13335 for (q=p;q<=mp->first_count-1;q++) {
13336 mp_print_char(mp, mp->trick_buf[q % mp->error_line]);
13339 for (q=1;q<=n;q++) {
13340 mp_print_char(mp, xord(' ')); /* print |n| spaces to begin line~2 */
13342 if ( m+n<=mp->error_line ) p=mp->first_count+m;
13343 else p=mp->first_count+(mp->error_line-n-3);
13344 for (q=mp->first_count;q<=p-1;q++) {
13345 mp_print_char(mp, mp->trick_buf[q % mp->error_line]);
13347 if ( m+n>mp->error_line ) mp_print(mp, "...")
13349 @ But the trick is distracting us from our current goal, which is to
13350 understand the input state. So let's concentrate on the data structures that
13351 are being pseudoprinted as we finish up the |show_context| procedure.
13353 @<Pseudoprint the line@>=
13356 for (i=start;i<=limit-1;i++) {
13357 if ( i==loc ) set_trick_count;
13358 mp_print_str(mp, mp->buffer[i]);
13362 @ @<Pseudoprint the token list@>=
13364 if ( token_type!=macro ) mp_show_token_list(mp, start,loc,100000,0);
13365 else mp_show_macro(mp, start,loc,100000)
13367 @ Here is the missing piece of |show_token_list| that is activated when the
13368 token beginning line~2 is about to be shown:
13370 @<Do magic computation@>=set_trick_count
13372 @* \[28] Maintaining the input stacks.
13373 The following subroutines change the input status in commonly needed ways.
13375 First comes |push_input|, which stores the current state and creates a
13376 new level (having, initially, the same properties as the old).
13378 @d push_input { /* enter a new input level, save the old */
13379 if ( mp->input_ptr>mp->max_in_stack ) {
13380 mp->max_in_stack=mp->input_ptr;
13381 if ( mp->input_ptr==mp->stack_size ) {
13382 int l = (mp->stack_size+(mp->stack_size/4));
13383 XREALLOC(mp->input_stack, l, in_state_record);
13384 mp->stack_size = l;
13387 mp->input_stack[mp->input_ptr]=mp->cur_input; /* stack the record */
13388 incr(mp->input_ptr);
13391 @ And of course what goes up must come down.
13393 @d pop_input { /* leave an input level, re-enter the old */
13394 decr(mp->input_ptr); mp->cur_input=mp->input_stack[mp->input_ptr];
13397 @ Here is a procedure that starts a new level of token-list input, given
13398 a token list |p| and its type |t|. If |t=macro|, the calling routine should
13399 set |name|, reset~|loc|, and increase the macro's reference count.
13401 @d back_list(A) mp_begin_token_list(mp, (A),backed_up) /* backs up a simple token list */
13404 static void mp_begin_token_list (MP mp,pointer p, quarterword t) {
13405 push_input; start=p; token_type=t;
13406 param_start=mp->param_ptr; loc=p;
13409 @ When a token list has been fully scanned, the following computations
13410 should be done as we leave that level of input.
13414 static void mp_end_token_list (MP mp) { /* leave a token-list input level */
13415 pointer p; /* temporary register */
13416 if ( token_type>=backed_up ) { /* token list to be deleted */
13417 if ( token_type<=inserted ) {
13418 mp_flush_token_list(mp, start); goto DONE;
13420 mp_delete_mac_ref(mp, start); /* update reference count */
13423 while ( mp->param_ptr>param_start ) { /* parameters must be flushed */
13424 decr(mp->param_ptr);
13425 p=mp->param_stack[mp->param_ptr];
13427 if ( mp_link(p)==mp_void ) { /* it's an \&{expr} parameter */
13428 mp_recycle_value(mp, p); mp_free_node(mp, p,value_node_size);
13430 mp_flush_token_list(mp, p); /* it's a \&{suffix} or \&{text} parameter */
13435 pop_input; check_interrupt;
13438 @ The contents of |cur_cmd,cur_mod,cur_sym| are placed into an equivalent
13439 token by the |cur_tok| routine.
13442 @c @<Declare the procedure called |make_exp_copy|@>
13443 static pointer mp_cur_tok (MP mp) {
13444 pointer p; /* a new token node */
13445 quarterword save_type; /* |cur_type| to be restored */
13446 integer save_exp; /* |cur_exp| to be restored */
13447 if ( mp->cur_sym==0 ) {
13448 if ( mp->cur_cmd==capsule_token ) {
13449 save_type=mp->cur_type; save_exp=mp->cur_exp;
13450 mp_make_exp_copy(mp, mp->cur_mod); p=mp_stash_cur_exp(mp); mp_link(p)=null;
13451 mp->cur_type=save_type; mp->cur_exp=save_exp;
13453 p=mp_get_node(mp, token_node_size);
13454 value(p)=mp->cur_mod; name_type(p)=mp_token;
13455 if ( mp->cur_cmd==numeric_token ) type(p)=mp_known;
13456 else type(p)=mp_string_type;
13459 fast_get_avail(p); info(p)=mp->cur_sym;
13464 @ Sometimes \MP\ has read too far and wants to ``unscan'' what it has
13465 seen. The |back_input| procedure takes care of this by putting the token
13466 just scanned back into the input stream, ready to be read again.
13467 If |cur_sym<>0|, the values of |cur_cmd| and |cur_mod| are irrelevant.
13470 static void mp_back_input (MP mp);
13472 @ @c void mp_back_input (MP mp) {/* undoes one token of input */
13473 pointer p; /* a token list of length one */
13475 while ( token_state &&(loc==null) )
13476 mp_end_token_list(mp); /* conserve stack space */
13480 @ The |back_error| routine is used when we want to restore or replace an
13481 offending token just before issuing an error message. We disable interrupts
13482 during the call of |back_input| so that the help message won't be lost.
13484 @ @c static void mp_back_error (MP mp) { /* back up one token and call |error| */
13485 mp->OK_to_interrupt=false;
13487 mp->OK_to_interrupt=true; mp_error(mp);
13489 static void mp_ins_error (MP mp) { /* back up one inserted token and call |error| */
13490 mp->OK_to_interrupt=false;
13491 mp_back_input(mp); token_type=inserted;
13492 mp->OK_to_interrupt=true; mp_error(mp);
13495 @ The |begin_file_reading| procedure starts a new level of input for lines
13496 of characters to be read from a file, or as an insertion from the
13497 terminal. It does not take care of opening the file, nor does it set |loc|
13498 or |limit| or |line|.
13499 @^system dependencies@>
13501 @c void mp_begin_file_reading (MP mp) {
13502 if ( mp->in_open==mp->max_in_open )
13503 mp_overflow(mp, "text input levels",mp->max_in_open);
13504 @:MetaPost capacity exceeded text input levels}{\quad text input levels@>
13505 if ( mp->first==mp->buf_size )
13506 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size/4)));
13507 incr(mp->in_open); push_input; iindex=mp->in_open;
13508 mp->mpx_name[iindex]=absent;
13509 start=(halfword)mp->first;
13510 name=is_term; /* |terminal_input| is now |true| */
13513 @ Conversely, the variables must be downdated when such a level of input
13514 is finished. Any associated \.{MPX} file must also be closed and popped
13515 off the file stack.
13517 @c static void mp_end_file_reading (MP mp) {
13518 if ( mp->in_open>iindex ) {
13519 if ( (mp->mpx_name[mp->in_open]==absent)||(name<=max_spec_src) ) {
13520 mp_confusion(mp, "endinput");
13521 @:this can't happen endinput}{\quad endinput@>
13523 (mp->close_file)(mp,mp->input_file[mp->in_open]); /* close an \.{MPX} file */
13524 delete_str_ref(mp->mpx_name[mp->in_open]);
13528 mp->first=(size_t)start;
13529 if ( iindex!=mp->in_open ) mp_confusion(mp, "endinput");
13530 if ( name>max_spec_src ) {
13531 (mp->close_file)(mp,cur_file);
13532 delete_str_ref(name);
13536 pop_input; decr(mp->in_open);
13539 @ Here is a function that tries to resume input from an \.{MPX} file already
13540 associated with the current input file. It returns |false| if this doesn't
13543 @c static boolean mp_begin_mpx_reading (MP mp) {
13544 if ( mp->in_open!=iindex+1 ) {
13547 if ( mp->mpx_name[mp->in_open]<=absent ) mp_confusion(mp, "mpx");
13548 @:this can't happen mpx}{\quad mpx@>
13549 if ( mp->first==mp->buf_size )
13550 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size/4)));
13551 push_input; iindex=mp->in_open;
13552 start=(halfword)mp->first;
13553 name=mp->mpx_name[mp->in_open]; add_str_ref(name);
13554 @<Put an empty line in the input buffer@>;
13559 @ This procedure temporarily stops reading an \.{MPX} file.
13561 @c static void mp_end_mpx_reading (MP mp) {
13562 if ( mp->in_open!=iindex ) mp_confusion(mp, "mpx");
13563 @:this can't happen mpx}{\quad mpx@>
13565 @<Complain that we are not at the end of a line in the \.{MPX} file@>;
13567 mp->first=(size_t)start;
13571 @ Here we enforce a restriction that simplifies the input stacks considerably.
13572 This should not inconvenience the user because \.{MPX} files are generated
13573 by an auxiliary program called \.{DVItoMP}.
13575 @ @<Complain that we are not at the end of a line in the \.{MPX} file@>=
13577 print_err("`mpxbreak' must be at the end of a line");
13578 help4("This file contains picture expressions for btex...etex",
13579 "blocks. Such files are normally generated automatically",
13580 "but this one seems to be messed up. I'm going to ignore",
13581 "the rest of this line.");
13585 @ In order to keep the stack from overflowing during a long sequence of
13586 inserted `\.{show}' commands, the following routine removes completed
13587 error-inserted lines from memory.
13589 @c void mp_clear_for_error_prompt (MP mp) {
13590 while ( file_state && terminal_input &&
13591 (mp->input_ptr>0)&&(loc==limit) ) mp_end_file_reading(mp);
13592 mp_print_ln(mp); clear_terminal;
13595 @ To get \MP's whole input mechanism going, we perform the following
13598 @<Initialize the input routines@>=
13599 { mp->input_ptr=0; mp->max_in_stack=0;
13600 mp->in_open=0; mp->open_parens=0; mp->max_buf_stack=0;
13601 mp->param_ptr=0; mp->max_param_stack=0;
13603 start=1; iindex=0; line=0; name=is_term;
13604 mp->mpx_name[0]=absent;
13605 mp->force_eof=false;
13606 if ( ! mp_init_terminal(mp) ) mp_jump_out(mp);
13607 limit=(halfword)mp->last; mp->first=mp->last+1;
13608 /* |init_terminal| has set |loc| and |last| */
13611 @* \[29] Getting the next token.
13612 The heart of \MP's input mechanism is the |get_next| procedure, which
13613 we shall develop in the next few sections of the program. Perhaps we
13614 shouldn't actually call it the ``heart,'' however; it really acts as \MP's
13615 eyes and mouth, reading the source files and gobbling them up. And it also
13616 helps \MP\ to regurgitate stored token lists that are to be processed again.
13618 The main duty of |get_next| is to input one token and to set |cur_cmd|
13619 and |cur_mod| to that token's command code and modifier. Furthermore, if
13620 the input token is a symbolic token, that token's |hash| address
13621 is stored in |cur_sym|; otherwise |cur_sym| is set to zero.
13623 Underlying this simple description is a certain amount of complexity
13624 because of all the cases that need to be handled.
13625 However, the inner loop of |get_next| is reasonably short and fast.
13627 @ Before getting into |get_next|, we need to consider a mechanism by which
13628 \MP\ helps keep errors from propagating too far. Whenever the program goes
13629 into a mode where it keeps calling |get_next| repeatedly until a certain
13630 condition is met, it sets |scanner_status| to some value other than |normal|.
13631 Then if an input file ends, or if an `\&{outer}' symbol appears,
13632 an appropriate error recovery will be possible.
13634 The global variable |warning_info| helps in this error recovery by providing
13635 additional information. For example, |warning_info| might indicate the
13636 name of a macro whose replacement text is being scanned.
13638 @d normal 0 /* |scanner_status| at ``quiet times'' */
13639 @d skipping 1 /* |scanner_status| when false conditional text is being skipped */
13640 @d flushing 2 /* |scanner_status| when junk after a statement is being ignored */
13641 @d absorbing 3 /* |scanner_status| when a \&{text} parameter is being scanned */
13642 @d var_defining 4 /* |scanner_status| when a \&{vardef} is being scanned */
13643 @d op_defining 5 /* |scanner_status| when a macro \&{def} is being scanned */
13644 @d loop_defining 6 /* |scanner_status| when a \&{for} loop is being scanned */
13645 @d tex_flushing 7 /* |scanner_status| when skipping \TeX\ material */
13648 integer scanner_status; /* are we scanning at high speed? */
13649 integer warning_info; /* if so, what else do we need to know,
13650 in case an error occurs? */
13652 @ @<Initialize the input routines@>=
13653 mp->scanner_status=normal;
13655 @ The following subroutine
13656 is called when an `\&{outer}' symbolic token has been scanned or
13657 when the end of a file has been reached. These two cases are distinguished
13658 by |cur_sym|, which is zero at the end of a file.
13661 static boolean mp_check_outer_validity (MP mp) {
13662 pointer p; /* points to inserted token list */
13663 if ( mp->scanner_status==normal ) {
13665 } else if ( mp->scanner_status==tex_flushing ) {
13666 @<Check if the file has ended while flushing \TeX\ material and set the
13667 result value for |check_outer_validity|@>;
13669 mp->deletions_allowed=false;
13670 @<Back up an outer symbolic token so that it can be reread@>;
13671 if ( mp->scanner_status>skipping ) {
13672 @<Tell the user what has run away and try to recover@>;
13674 print_err("Incomplete if; all text was ignored after line ");
13675 @.Incomplete if...@>
13676 mp_print_int(mp, mp->warning_info);
13677 help3("A forbidden `outer' token occurred in skipped text.",
13678 "This kind of error happens when you say `if...' and forget",
13679 "the matching `fi'. I've inserted a `fi'; this might work.");
13680 if ( mp->cur_sym==0 )
13681 mp->help_line[2]="The file ended while I was skipping conditional text.";
13682 mp->cur_sym=frozen_fi; mp_ins_error(mp);
13684 mp->deletions_allowed=true;
13689 @ @<Check if the file has ended while flushing \TeX\ material and set...@>=
13690 if ( mp->cur_sym!=0 ) {
13693 mp->deletions_allowed=false;
13694 print_err("TeX mode didn't end; all text was ignored after line ");
13695 mp_print_int(mp, mp->warning_info);
13696 help2("The file ended while I was looking for the `etex' to",
13697 "finish this TeX material. I've inserted `etex' now.");
13698 mp->cur_sym = frozen_etex;
13700 mp->deletions_allowed=true;
13704 @ @<Back up an outer symbolic token so that it can be reread@>=
13705 if ( mp->cur_sym!=0 ) {
13706 p=mp_get_avail(mp); info(p)=mp->cur_sym;
13707 back_list(p); /* prepare to read the symbolic token again */
13710 @ @<Tell the user what has run away...@>=
13712 mp_runaway(mp); /* print the definition-so-far */
13713 if ( mp->cur_sym==0 ) {
13714 print_err("File ended");
13715 @.File ended while scanning...@>
13717 print_err("Forbidden token found");
13718 @.Forbidden token found...@>
13720 mp_print(mp, " while scanning ");
13721 help4("I suspect you have forgotten an `enddef',",
13722 "causing me to read past where you wanted me to stop.",
13723 "I'll try to recover; but if the error is serious,",
13724 "you'd better type `E' or `X' now and fix your file.");
13725 switch (mp->scanner_status) {
13726 @<Complete the error message,
13727 and set |cur_sym| to a token that might help recover from the error@>
13728 } /* there are no other cases */
13732 @ As we consider various kinds of errors, it is also appropriate to
13733 change the first line of the help message just given; |help_line[3]|
13734 points to the string that might be changed.
13736 @<Complete the error message,...@>=
13738 mp_print(mp, "to the end of the statement");
13739 mp->help_line[3]="A previous error seems to have propagated,";
13740 mp->cur_sym=frozen_semicolon;
13743 mp_print(mp, "a text argument");
13744 mp->help_line[3]="It seems that a right delimiter was left out,";
13745 if ( mp->warning_info==0 ) {
13746 mp->cur_sym=frozen_end_group;
13748 mp->cur_sym=frozen_right_delimiter;
13749 equiv(frozen_right_delimiter)=mp->warning_info;
13754 mp_print(mp, "the definition of ");
13755 if ( mp->scanner_status==op_defining )
13756 mp_print_text(mp->warning_info);
13758 mp_print_variable_name(mp, mp->warning_info);
13759 mp->cur_sym=frozen_end_def;
13761 case loop_defining:
13762 mp_print(mp, "the text of a ");
13763 mp_print_text(mp->warning_info);
13764 mp_print(mp, " loop");
13765 mp->help_line[3]="I suspect you have forgotten an `endfor',";
13766 mp->cur_sym=frozen_end_for;
13769 @ The |runaway| procedure displays the first part of the text that occurred
13770 when \MP\ began its special |scanner_status|, if that text has been saved.
13773 static void mp_runaway (MP mp) ;
13776 void mp_runaway (MP mp) {
13777 if ( mp->scanner_status>flushing ) {
13778 mp_print_nl(mp, "Runaway ");
13779 switch (mp->scanner_status) {
13780 case absorbing: mp_print(mp, "text?"); break;
13782 case op_defining: mp_print(mp,"definition?"); break;
13783 case loop_defining: mp_print(mp, "loop?"); break;
13784 } /* there are no other cases */
13786 mp_show_token_list(mp, mp_link(hold_head),null,mp->error_line-10,0);
13790 @ We need to mention a procedure that may be called by |get_next|.
13793 static void mp_firm_up_the_line (MP mp);
13795 @ And now we're ready to take the plunge into |get_next| itself.
13796 Note that the behavior depends on the |scanner_status| because percent signs
13797 and double quotes need to be passed over when skipping TeX material.
13800 void mp_get_next (MP mp) {
13801 /* sets |cur_cmd|, |cur_mod|, |cur_sym| to next token */
13803 /*restart*/ /* go here to get the next input token */
13804 /*exit*/ /* go here when the next input token has been got */
13805 /*|common_ending|*/ /* go here to finish getting a symbolic token */
13806 /*found*/ /* go here when the end of a symbolic token has been found */
13807 /*switch*/ /* go here to branch on the class of an input character */
13808 /*|start_numeric_token|,|start_decimal_token|,|fin_numeric_token|,|done|*/
13809 /* go here at crucial stages when scanning a number */
13810 int k; /* an index into |buffer| */
13811 ASCII_code c; /* the current character in the buffer */
13812 int class; /* its class number */
13813 integer n,f; /* registers for decimal-to-binary conversion */
13816 if ( file_state ) {
13817 @<Input from external file; |goto restart| if no input found,
13818 or |return| if a non-symbolic token is found@>;
13820 @<Input from token list; |goto restart| if end of list or
13821 if a parameter needs to be expanded,
13822 or |return| if a non-symbolic token is found@>;
13825 @<Finish getting the symbolic token in |cur_sym|;
13826 |goto restart| if it is illegal@>;
13829 @ When a symbolic token is declared to be `\&{outer}', its command code
13830 is increased by |outer_tag|.
13833 @<Finish getting the symbolic token in |cur_sym|...@>=
13834 mp->cur_cmd=eq_type(mp->cur_sym); mp->cur_mod=equiv(mp->cur_sym);
13835 if ( mp->cur_cmd>=outer_tag ) {
13836 if ( mp_check_outer_validity(mp) )
13837 mp->cur_cmd=mp->cur_cmd-outer_tag;
13842 @ A percent sign appears in |buffer[limit]|; this makes it unnecessary
13843 to have a special test for end-of-line.
13846 @<Input from external file;...@>=
13849 c=mp->buffer[loc]; incr(loc); class=mp->char_class[c];
13851 case digit_class: goto START_NUMERIC_TOKEN; break;
13853 class=mp->char_class[mp->buffer[loc]];
13854 if ( class>period_class ) {
13856 } else if ( class<period_class ) { /* |class=digit_class| */
13857 n=0; goto START_DECIMAL_TOKEN;
13861 case space_class: goto SWITCH; break;
13862 case percent_class:
13863 if ( mp->scanner_status==tex_flushing ) {
13864 if ( loc<limit ) goto SWITCH;
13866 @<Move to next line of file, or |goto restart| if there is no next line@>;
13871 if ( mp->scanner_status==tex_flushing ) goto SWITCH;
13872 else @<Get a string token and |return|@>;
13874 case isolated_classes:
13875 k=loc-1; goto FOUND; break;
13876 case invalid_class:
13877 if ( mp->scanner_status==tex_flushing ) goto SWITCH;
13878 else @<Decry the invalid character and |goto restart|@>;
13880 default: break; /* letters, etc. */
13883 while ( mp->char_class[mp->buffer[loc]]==class ) incr(loc);
13885 START_NUMERIC_TOKEN:
13886 @<Get the integer part |n| of a numeric token;
13887 set |f:=0| and |goto fin_numeric_token| if there is no decimal point@>;
13888 START_DECIMAL_TOKEN:
13889 @<Get the fraction part |f| of a numeric token@>;
13891 @<Pack the numeric and fraction parts of a numeric token
13894 mp->cur_sym=mp_id_lookup(mp, k,loc-k);
13897 @ We go to |restart| instead of to |SWITCH|, because we might enter
13898 |token_state| after the error has been dealt with
13899 (cf.\ |clear_for_error_prompt|).
13901 @<Decry the invalid...@>=
13903 print_err("Text line contains an invalid character");
13904 @.Text line contains...@>
13905 help2("A funny symbol that I can\'t read has just been input.",
13906 "Continue, and I'll forget that it ever happened.");
13907 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
13911 @ @<Get a string token and |return|@>=
13913 if ( mp->buffer[loc]=='"' ) {
13914 mp->cur_mod=null_str;
13916 k=loc; mp->buffer[limit+1]=xord('"');
13919 } while (mp->buffer[loc]!='"');
13921 @<Decry the missing string delimiter and |goto restart|@>;
13924 mp->cur_mod=mp->buffer[k];
13928 append_char(mp->buffer[k]); incr(k);
13930 mp->cur_mod=mp_make_string(mp);
13933 incr(loc); mp->cur_cmd=string_token;
13937 @ We go to |restart| after this error message, not to |SWITCH|,
13938 because the |clear_for_error_prompt| routine might have reinstated
13939 |token_state| after |error| has finished.
13941 @<Decry the missing string delimiter and |goto restart|@>=
13943 loc=limit; /* the next character to be read on this line will be |"%"| */
13944 print_err("Incomplete string token has been flushed");
13945 @.Incomplete string token...@>
13946 help3("Strings should finish on the same line as they began.",
13947 "I've deleted the partial string; you might want to",
13948 "insert another by typing, e.g., `I\"new string\"'.");
13949 mp->deletions_allowed=false; mp_error(mp);
13950 mp->deletions_allowed=true;
13954 @ @<Get the integer part |n| of a numeric token...@>=
13956 while ( mp->char_class[mp->buffer[loc]]==digit_class ) {
13957 if ( n<32768 ) n=10*n+mp->buffer[loc]-'0';
13960 if ( mp->buffer[loc]=='.' )
13961 if ( mp->char_class[mp->buffer[loc+1]]==digit_class )
13964 goto FIN_NUMERIC_TOKEN;
13967 @ @<Get the fraction part |f| of a numeric token@>=
13970 if ( k<17 ) { /* digits for |k>=17| cannot affect the result */
13971 mp->dig[k]=mp->buffer[loc]-'0'; incr(k);
13974 } while (mp->char_class[mp->buffer[loc]]==digit_class);
13975 f=mp_round_decimals(mp, k);
13980 @ @<Pack the numeric and fraction parts of a numeric token and |return|@>=
13982 @<Set |cur_mod:=n*unity+f| and check if it is uncomfortably large@>;
13983 } else if ( mp->scanner_status!=tex_flushing ) {
13984 print_err("Enormous number has been reduced");
13985 @.Enormous number...@>
13986 help2("I can\'t handle numbers bigger than 32767.99998;",
13987 "so I've changed your constant to that maximum amount.");
13988 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
13989 mp->cur_mod=el_gordo;
13991 mp->cur_cmd=numeric_token; return
13993 @ @<Set |cur_mod:=n*unity+f| and check if it is uncomfortably large@>=
13995 mp->cur_mod=n*unity+f;
13996 if ( mp->cur_mod>=fraction_one ) {
13997 if ( (mp->internal[mp_warning_check]>0) &&
13998 (mp->scanner_status!=tex_flushing) ) {
13999 print_err("Number is too large (");
14000 mp_print_scaled(mp, mp->cur_mod);
14001 mp_print_char(mp, xord(')'));
14002 help3("It is at least 4096. Continue and I'll try to cope",
14003 "with that big value; but it might be dangerous.",
14004 "(Set warningcheck:=0 to suppress this message.)");
14010 @ Let's consider now what happens when |get_next| is looking at a token list.
14013 @<Input from token list;...@>=
14014 if ( loc>=mp->hi_mem_min ) { /* one-word token */
14015 mp->cur_sym=info(loc); loc=mp_link(loc); /* move to next */
14016 if ( mp->cur_sym>=expr_base ) {
14017 if ( mp->cur_sym>=suffix_base ) {
14018 @<Insert a suffix or text parameter and |goto restart|@>;
14020 mp->cur_cmd=capsule_token;
14021 mp->cur_mod=mp->param_stack[param_start+mp->cur_sym-(expr_base)];
14022 mp->cur_sym=0; return;
14025 } else if ( loc>null ) {
14026 @<Get a stored numeric or string or capsule token and |return|@>
14027 } else { /* we are done with this token list */
14028 mp_end_token_list(mp); goto RESTART; /* resume previous level */
14031 @ @<Insert a suffix or text parameter...@>=
14033 if ( mp->cur_sym>=text_base ) mp->cur_sym=mp->cur_sym-mp->param_size;
14034 /* |param_size=text_base-suffix_base| */
14035 mp_begin_token_list(mp,
14036 mp->param_stack[param_start+mp->cur_sym-(suffix_base)],
14041 @ @<Get a stored numeric or string or capsule token...@>=
14043 if ( name_type(loc)==mp_token ) {
14044 mp->cur_mod=value(loc);
14045 if ( type(loc)==mp_known ) {
14046 mp->cur_cmd=numeric_token;
14048 mp->cur_cmd=string_token; add_str_ref(mp->cur_mod);
14051 mp->cur_mod=loc; mp->cur_cmd=capsule_token;
14053 loc=mp_link(loc); return;
14056 @ All of the easy branches of |get_next| have now been taken care of.
14057 There is one more branch.
14059 @<Move to next line of file, or |goto restart|...@>=
14060 if ( name>max_spec_src) {
14061 @<Read next line of file into |buffer|, or
14062 |goto restart| if the file has ended@>;
14064 if ( mp->input_ptr>0 ) {
14065 /* text was inserted during error recovery or by \&{scantokens} */
14066 mp_end_file_reading(mp); goto RESTART; /* resume previous level */
14068 if (mp->job_name == NULL && ( mp->selector<log_only || mp->selector>=write_file))
14069 mp_open_log_file(mp);
14070 if ( mp->interaction>mp_nonstop_mode ) {
14071 if ( limit==start ) /* previous line was empty */
14072 mp_print_nl(mp, "(Please type a command or say `end')");
14074 mp_print_ln(mp); mp->first=(size_t)start;
14075 prompt_input("*"); /* input on-line into |buffer| */
14077 limit=(halfword)mp->last; mp->buffer[limit]=xord('%');
14078 mp->first=(size_t)(limit+1); loc=start;
14080 mp_fatal_error(mp, "*** (job aborted, no legal end found)");
14082 /* nonstop mode, which is intended for overnight batch processing,
14083 never waits for on-line input */
14087 @ The global variable |force_eof| is normally |false|; it is set |true|
14088 by an \&{endinput} command.
14091 boolean force_eof; /* should the next \&{input} be aborted early? */
14093 @ We must decrement |loc| in order to leave the buffer in a valid state
14094 when an error condition causes us to |goto restart| without calling
14095 |end_file_reading|.
14097 @<Read next line of file into |buffer|, or
14098 |goto restart| if the file has ended@>=
14100 incr(line); mp->first=(size_t)start;
14101 if ( ! mp->force_eof ) {
14102 if ( mp_input_ln(mp, cur_file ) ) /* not end of file */
14103 mp_firm_up_the_line(mp); /* this sets |limit| */
14105 mp->force_eof=true;
14107 if ( mp->force_eof ) {
14108 mp->force_eof=false;
14110 if ( mpx_reading ) {
14111 @<Complain that the \.{MPX} file ended unexpectly; then set
14112 |cur_sym:=frozen_mpx_break| and |goto comon_ending|@>;
14114 mp_print_char(mp, xord(')')); decr(mp->open_parens);
14115 update_terminal; /* show user that file has been read */
14116 mp_end_file_reading(mp); /* resume previous level */
14117 if ( mp_check_outer_validity(mp) ) goto RESTART;
14121 mp->buffer[limit]=xord('%'); mp->first=(size_t)(limit+1); loc=start; /* ready to read */
14124 @ We should never actually come to the end of an \.{MPX} file because such
14125 files should have an \&{mpxbreak} after the translation of the last
14126 \&{btex}$\,\ldots\,$\&{etex} block.
14128 @<Complain that the \.{MPX} file ended unexpectly; then set...@>=
14130 mp->mpx_name[iindex]=mpx_finished;
14131 print_err("mpx file ended unexpectedly");
14132 help4("The file had too few picture expressions for btex...etex",
14133 "blocks. Such files are normally generated automatically",
14134 "but this one got messed up. You might want to insert a",
14135 "picture expression now.");
14136 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
14137 mp->cur_sym=frozen_mpx_break; goto COMMON_ENDING;
14140 @ Sometimes we want to make it look as though we have just read a blank line
14141 without really doing so.
14143 @<Put an empty line in the input buffer@>=
14144 mp->last=mp->first; limit=(halfword)mp->last;
14145 /* simulate |input_ln| and |firm_up_the_line| */
14146 mp->buffer[limit]=xord('%'); mp->first=(size_t)(limit+1); loc=start
14148 @ If the user has set the |mp_pausing| parameter to some positive value,
14149 and if nonstop mode has not been selected, each line of input is displayed
14150 on the terminal and the transcript file, followed by `\.{=>}'.
14151 \MP\ waits for a response. If the response is null (i.e., if nothing is
14152 typed except perhaps a few blank spaces), the original
14153 line is accepted as it stands; otherwise the line typed is
14154 used instead of the line in the file.
14156 @c void mp_firm_up_the_line (MP mp) {
14157 size_t k; /* an index into |buffer| */
14158 limit=(halfword)mp->last;
14159 if ((!mp->noninteractive)
14160 && (mp->internal[mp_pausing]>0 )
14161 && (mp->interaction>mp_nonstop_mode )) {
14162 wake_up_terminal; mp_print_ln(mp);
14163 if ( start<limit ) {
14164 for (k=(size_t)start;k<=(size_t)(limit-1);k++) {
14165 mp_print_str(mp, mp->buffer[k]);
14168 mp->first=(size_t)limit; prompt_input("=>"); /* wait for user response */
14170 if ( mp->last>mp->first ) {
14171 for (k=mp->first;k<=mp->last-1;k++) { /* move line down in buffer */
14172 mp->buffer[k+start-mp->first]=mp->buffer[k];
14174 limit=(halfword)(start+mp->last-mp->first);
14179 @* \[30] Dealing with \TeX\ material.
14180 The \&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}$\,\ldots\,$\&{etex}
14181 features need to be implemented at a low level in the scanning process
14182 so that \MP\ can stay in synch with the a preprocessor that treats
14183 blocks of \TeX\ material as they occur in the input file without trying
14184 to expand \MP\ macros. Thus we need a special version of |get_next|
14185 that does not expand macros and such but does handle \&{btex},
14186 \&{verbatimtex}, etc.
14188 The special version of |get_next| is called |get_t_next|. It works by flushing
14189 \&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}\allowbreak
14190 $\,\ldots\,$\&{etex} blocks, switching to the \.{MPX} file when it sees
14191 \&{btex}, and switching back when it sees \&{mpxbreak}.
14197 mp_primitive(mp, "btex",start_tex,btex_code);
14198 @:btex_}{\&{btex} primitive@>
14199 mp_primitive(mp, "verbatimtex",start_tex,verbatim_code);
14200 @:verbatimtex_}{\&{verbatimtex} primitive@>
14201 mp_primitive(mp, "etex",etex_marker,0); mp->eqtb[frozen_etex]=mp->eqtb[mp->cur_sym];
14202 @:etex_}{\&{etex} primitive@>
14203 mp_primitive(mp, "mpxbreak",mpx_break,0); mp->eqtb[frozen_mpx_break]=mp->eqtb[mp->cur_sym];
14204 @:mpx_break_}{\&{mpxbreak} primitive@>
14206 @ @<Cases of |print_cmd...@>=
14207 case start_tex: if ( m==btex_code ) mp_print(mp, "btex");
14208 else mp_print(mp, "verbatimtex"); break;
14209 case etex_marker: mp_print(mp, "etex"); break;
14210 case mpx_break: mp_print(mp, "mpxbreak"); break;
14212 @ Actually, |get_t_next| is a macro that avoids procedure overhead except
14213 in the unusual case where \&{btex}, \&{verbatimtex}, \&{etex}, or \&{mpxbreak}
14216 @d get_t_next {mp_get_next(mp); if ( mp->cur_cmd<=max_pre_command ) mp_t_next(mp); }
14219 static void mp_start_mpx_input (MP mp);
14222 static void mp_t_next (MP mp) {
14223 int old_status; /* saves the |scanner_status| */
14224 integer old_info; /* saves the |warning_info| */
14225 while ( mp->cur_cmd<=max_pre_command ) {
14226 if ( mp->cur_cmd==mpx_break ) {
14227 if ( ! file_state || (mp->mpx_name[iindex]==absent) ) {
14228 @<Complain about a misplaced \&{mpxbreak}@>;
14230 mp_end_mpx_reading(mp);
14233 } else if ( mp->cur_cmd==start_tex ) {
14234 if ( token_state || (name<=max_spec_src) ) {
14235 @<Complain that we are not reading a file@>;
14236 } else if ( mpx_reading ) {
14237 @<Complain that \.{MPX} files cannot contain \TeX\ material@>;
14238 } else if ( (mp->cur_mod!=verbatim_code)&&
14239 (mp->mpx_name[iindex]!=mpx_finished) ) {
14240 if ( ! mp_begin_mpx_reading(mp) ) mp_start_mpx_input(mp);
14245 @<Complain about a misplaced \&{etex}@>;
14247 goto COMMON_ENDING;
14249 @<Flush the \TeX\ material@>;
14255 @ We could be in the middle of an operation such as skipping false conditional
14256 text when \TeX\ material is encountered, so we must be careful to save the
14259 @<Flush the \TeX\ material@>=
14260 old_status=mp->scanner_status;
14261 old_info=mp->warning_info;
14262 mp->scanner_status=tex_flushing;
14263 mp->warning_info=line;
14264 do { mp_get_next(mp); } while (mp->cur_cmd!=etex_marker);
14265 mp->scanner_status=old_status;
14266 mp->warning_info=old_info
14268 @ @<Complain that \.{MPX} files cannot contain \TeX\ material@>=
14269 { print_err("An mpx file cannot contain btex or verbatimtex blocks");
14270 help4("This file contains picture expressions for btex...etex",
14271 "blocks. Such files are normally generated automatically",
14272 "but this one seems to be messed up. I'll just keep going",
14273 "and hope for the best.");
14277 @ @<Complain that we are not reading a file@>=
14278 { print_err("You can only use `btex' or `verbatimtex' in a file");
14279 help3("I'll have to ignore this preprocessor command because it",
14280 "only works when there is a file to preprocess. You might",
14281 "want to delete everything up to the next `etex`.");
14285 @ @<Complain about a misplaced \&{mpxbreak}@>=
14286 { print_err("Misplaced mpxbreak");
14287 help2("I'll ignore this preprocessor command because it",
14288 "doesn't belong here");
14292 @ @<Complain about a misplaced \&{etex}@>=
14293 { print_err("Extra etex will be ignored");
14294 help1("There is no btex or verbatimtex for this to match");
14298 @* \[31] Scanning macro definitions.
14299 \MP\ has a variety of ways to tuck tokens away into token lists for later
14300 use: Macros can be defined with \&{def}, \&{vardef}, \&{primarydef}, etc.;
14301 repeatable code can be defined with \&{for}, \&{forever}, \&{forsuffixes}.
14302 All such operations are handled by the routines in this part of the program.
14304 The modifier part of each command code is zero for the ``ending delimiters''
14305 like \&{enddef} and \&{endfor}.
14307 @d start_def 1 /* command modifier for \&{def} */
14308 @d var_def 2 /* command modifier for \&{vardef} */
14309 @d end_def 0 /* command modifier for \&{enddef} */
14310 @d start_forever 1 /* command modifier for \&{forever} */
14311 @d end_for 0 /* command modifier for \&{endfor} */
14314 mp_primitive(mp, "def",macro_def,start_def);
14315 @:def_}{\&{def} primitive@>
14316 mp_primitive(mp, "vardef",macro_def,var_def);
14317 @:var_def_}{\&{vardef} primitive@>
14318 mp_primitive(mp, "primarydef",macro_def,secondary_primary_macro);
14319 @:primary_def_}{\&{primarydef} primitive@>
14320 mp_primitive(mp, "secondarydef",macro_def,tertiary_secondary_macro);
14321 @:secondary_def_}{\&{secondarydef} primitive@>
14322 mp_primitive(mp, "tertiarydef",macro_def,expression_tertiary_macro);
14323 @:tertiary_def_}{\&{tertiarydef} primitive@>
14324 mp_primitive(mp, "enddef",macro_def,end_def); mp->eqtb[frozen_end_def]=mp->eqtb[mp->cur_sym];
14325 @:end_def_}{\&{enddef} primitive@>
14327 mp_primitive(mp, "for",iteration,expr_base);
14328 @:for_}{\&{for} primitive@>
14329 mp_primitive(mp, "forsuffixes",iteration,suffix_base);
14330 @:for_suffixes_}{\&{forsuffixes} primitive@>
14331 mp_primitive(mp, "forever",iteration,start_forever);
14332 @:forever_}{\&{forever} primitive@>
14333 mp_primitive(mp, "endfor",iteration,end_for); mp->eqtb[frozen_end_for]=mp->eqtb[mp->cur_sym];
14334 @:end_for_}{\&{endfor} primitive@>
14336 @ @<Cases of |print_cmd...@>=
14338 if ( m<=var_def ) {
14339 if ( m==start_def ) mp_print(mp, "def");
14340 else if ( m<start_def ) mp_print(mp, "enddef");
14341 else mp_print(mp, "vardef");
14342 } else if ( m==secondary_primary_macro ) {
14343 mp_print(mp, "primarydef");
14344 } else if ( m==tertiary_secondary_macro ) {
14345 mp_print(mp, "secondarydef");
14347 mp_print(mp, "tertiarydef");
14351 if ( m<=start_forever ) {
14352 if ( m==start_forever ) mp_print(mp, "forever");
14353 else mp_print(mp, "endfor");
14354 } else if ( m==expr_base ) {
14355 mp_print(mp, "for");
14357 mp_print(mp, "forsuffixes");
14361 @ Different macro-absorbing operations have different syntaxes, but they
14362 also have a lot in common. There is a list of special symbols that are to
14363 be replaced by parameter tokens; there is a special command code that
14364 ends the definition; the quotation conventions are identical. Therefore
14365 it makes sense to have most of the work done by a single subroutine. That
14366 subroutine is called |scan_toks|.
14368 The first parameter to |scan_toks| is the command code that will
14369 terminate scanning (either |macro_def| or |iteration|).
14371 The second parameter, |subst_list|, points to a (possibly empty) list
14372 of two-word nodes whose |info| and |value| fields specify symbol tokens
14373 before and after replacement. The list will be returned to free storage
14376 The third parameter is simply appended to the token list that is built.
14377 And the final parameter tells how many of the special operations
14378 \.{\#\AT!}, \.{\AT!}, and \.{\AT!\#} are to be replaced by suffix parameters.
14379 When such parameters are present, they are called \.{(SUFFIX0)},
14380 \.{(SUFFIX1)}, and \.{(SUFFIX2)}.
14382 @c static pointer mp_scan_toks (MP mp,command_code terminator, pointer
14383 subst_list, pointer tail_end, quarterword suffix_count) {
14384 pointer p; /* tail of the token list being built */
14385 pointer q; /* temporary for link management */
14386 integer balance; /* left delimiters minus right delimiters */
14387 p=hold_head; balance=1; mp_link(hold_head)=null;
14390 if ( mp->cur_sym>0 ) {
14391 @<Substitute for |cur_sym|, if it's on the |subst_list|@>;
14392 if ( mp->cur_cmd==terminator ) {
14393 @<Adjust the balance; |break| if it's zero@>;
14394 } else if ( mp->cur_cmd==macro_special ) {
14395 @<Handle quoted symbols, \.{\#\AT!}, \.{\AT!}, or \.{\AT!\#}@>;
14398 mp_link(p)=mp_cur_tok(mp); p=mp_link(p);
14400 mp_link(p)=tail_end; mp_flush_node_list(mp, subst_list);
14401 return mp_link(hold_head);
14404 @ @<Substitute for |cur_sym|...@>=
14407 while ( q!=null ) {
14408 if ( info(q)==mp->cur_sym ) {
14409 mp->cur_sym=value(q); mp->cur_cmd=relax; break;
14415 @ @<Adjust the balance; |break| if it's zero@>=
14416 if ( mp->cur_mod>0 ) {
14424 @ Four commands are intended to be used only within macro texts: \&{quote},
14425 \.{\#\AT!}, \.{\AT!}, and \.{\AT!\#}. They are variants of a single command
14426 code called |macro_special|.
14428 @d quote 0 /* |macro_special| modifier for \&{quote} */
14429 @d macro_prefix 1 /* |macro_special| modifier for \.{\#\AT!} */
14430 @d macro_at 2 /* |macro_special| modifier for \.{\AT!} */
14431 @d macro_suffix 3 /* |macro_special| modifier for \.{\AT!\#} */
14434 mp_primitive(mp, "quote",macro_special,quote);
14435 @:quote_}{\&{quote} primitive@>
14436 mp_primitive(mp, "#@@",macro_special,macro_prefix);
14437 @:]]]\#\AT!_}{\.{\#\AT!} primitive@>
14438 mp_primitive(mp, "@@",macro_special,macro_at);
14439 @:]]]\AT!_}{\.{\AT!} primitive@>
14440 mp_primitive(mp, "@@#",macro_special,macro_suffix);
14441 @:]]]\AT!\#_}{\.{\AT!\#} primitive@>
14443 @ @<Cases of |print_cmd...@>=
14444 case macro_special:
14446 case macro_prefix: mp_print(mp, "#@@"); break;
14447 case macro_at: mp_print_char(mp, xord('@@')); break;
14448 case macro_suffix: mp_print(mp, "@@#"); break;
14449 default: mp_print(mp, "quote"); break;
14453 @ @<Handle quoted...@>=
14455 if ( mp->cur_mod==quote ) { get_t_next; }
14456 else if ( mp->cur_mod<=suffix_count )
14457 mp->cur_sym=suffix_base-1+mp->cur_mod;
14460 @ Here is a routine that's used whenever a token will be redefined. If
14461 the user's token is unredefinable, the `|frozen_inaccessible|' token is
14462 substituted; the latter is redefinable but essentially impossible to use,
14463 hence \MP's tables won't get fouled up.
14465 @c static void mp_get_symbol (MP mp) { /* sets |cur_sym| to a safe symbol */
14468 if ( (mp->cur_sym==0)||(mp->cur_sym>(integer)frozen_inaccessible) ) {
14469 print_err("Missing symbolic token inserted");
14470 @.Missing symbolic token...@>
14471 help3("Sorry: You can\'t redefine a number, string, or expr.",
14472 "I've inserted an inaccessible symbol so that your",
14473 "definition will be completed without mixing me up too badly.");
14474 if ( mp->cur_sym>0 )
14475 mp->help_line[2]="Sorry: You can\'t redefine my error-recovery tokens.";
14476 else if ( mp->cur_cmd==string_token )
14477 delete_str_ref(mp->cur_mod);
14478 mp->cur_sym=frozen_inaccessible; mp_ins_error(mp); goto RESTART;
14482 @ Before we actually redefine a symbolic token, we need to clear away its
14483 former value, if it was a variable. The following stronger version of
14484 |get_symbol| does that.
14486 @c static void mp_get_clear_symbol (MP mp) {
14487 mp_get_symbol(mp); mp_clear_symbol(mp, mp->cur_sym,false);
14490 @ Here's another little subroutine; it checks that an equals sign
14491 or assignment sign comes along at the proper place in a macro definition.
14493 @c static void mp_check_equals (MP mp) {
14494 if ( mp->cur_cmd!=equals ) if ( mp->cur_cmd!=assignment ) {
14495 mp_missing_err(mp, "=");
14497 help5("The next thing in this `def' should have been `=',",
14498 "because I've already looked at the definition heading.",
14499 "But don't worry; I'll pretend that an equals sign",
14500 "was present. Everything from here to `enddef'",
14501 "will be the replacement text of this macro.");
14506 @ A \&{primarydef}, \&{secondarydef}, or \&{tertiarydef} is rather easily
14507 handled now that we have |scan_toks|. In this case there are
14508 two parameters, which will be \.{EXPR0} and \.{EXPR1} (i.e.,
14509 |expr_base| and |expr_base+1|).
14511 @c static void mp_make_op_def (MP mp) {
14512 command_code m; /* the type of definition */
14513 pointer p,q,r; /* for list manipulation */
14515 mp_get_symbol(mp); q=mp_get_node(mp, token_node_size);
14516 info(q)=mp->cur_sym; value(q)=expr_base;
14517 mp_get_clear_symbol(mp); mp->warning_info=mp->cur_sym;
14518 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
14519 info(p)=mp->cur_sym; value(p)=expr_base+1; mp_link(p)=q;
14520 get_t_next; mp_check_equals(mp);
14521 mp->scanner_status=op_defining; q=mp_get_avail(mp); ref_count(q)=null;
14522 r=mp_get_avail(mp); mp_link(q)=r; info(r)=general_macro;
14523 mp_link(r)=mp_scan_toks(mp, macro_def,p,null,0);
14524 mp->scanner_status=normal; eq_type(mp->warning_info)=m;
14525 equiv(mp->warning_info)=q; mp_get_x_next(mp);
14528 @ Parameters to macros are introduced by the keywords \&{expr},
14529 \&{suffix}, \&{text}, \&{primary}, \&{secondary}, and \&{tertiary}.
14532 mp_primitive(mp, "expr",param_type,expr_base);
14533 @:expr_}{\&{expr} primitive@>
14534 mp_primitive(mp, "suffix",param_type,suffix_base);
14535 @:suffix_}{\&{suffix} primitive@>
14536 mp_primitive(mp, "text",param_type,text_base);
14537 @:text_}{\&{text} primitive@>
14538 mp_primitive(mp, "primary",param_type,primary_macro);
14539 @:primary_}{\&{primary} primitive@>
14540 mp_primitive(mp, "secondary",param_type,secondary_macro);
14541 @:secondary_}{\&{secondary} primitive@>
14542 mp_primitive(mp, "tertiary",param_type,tertiary_macro);
14543 @:tertiary_}{\&{tertiary} primitive@>
14545 @ @<Cases of |print_cmd...@>=
14547 if ( m>=expr_base ) {
14548 if ( m==expr_base ) mp_print(mp, "expr");
14549 else if ( m==suffix_base ) mp_print(mp, "suffix");
14550 else mp_print(mp, "text");
14551 } else if ( m<secondary_macro ) {
14552 mp_print(mp, "primary");
14553 } else if ( m==secondary_macro ) {
14554 mp_print(mp, "secondary");
14556 mp_print(mp, "tertiary");
14560 @ Let's turn next to the more complex processing associated with \&{def}
14561 and \&{vardef}. When the following procedure is called, |cur_mod|
14562 should be either |start_def| or |var_def|.
14565 static void mp_scan_def (MP mp) {
14566 int m; /* the type of definition */
14567 int n; /* the number of special suffix parameters */
14568 int k; /* the total number of parameters */
14569 int c; /* the kind of macro we're defining */
14570 pointer r; /* parameter-substitution list */
14571 pointer q; /* tail of the macro token list */
14572 pointer p; /* temporary storage */
14573 halfword base; /* |expr_base|, |suffix_base|, or |text_base| */
14574 pointer l_delim,r_delim; /* matching delimiters */
14575 m=mp->cur_mod; c=general_macro; mp_link(hold_head)=null;
14576 q=mp_get_avail(mp); ref_count(q)=null; r=null;
14577 @<Scan the token or variable to be defined;
14578 set |n|, |scanner_status|, and |warning_info|@>;
14580 if ( mp->cur_cmd==left_delimiter ) {
14581 @<Absorb delimited parameters, putting them into lists |q| and |r|@>;
14583 if ( mp->cur_cmd==param_type ) {
14584 @<Absorb undelimited parameters, putting them into list |r|@>;
14586 mp_check_equals(mp);
14587 p=mp_get_avail(mp); info(p)=c; mp_link(q)=p;
14588 @<Attach the replacement text to the tail of node |p|@>;
14589 mp->scanner_status=normal; mp_get_x_next(mp);
14592 @ We don't put `|frozen_end_group|' into the replacement text of
14593 a \&{vardef}, because the user may want to redefine `\.{endgroup}'.
14595 @<Attach the replacement text to the tail of node |p|@>=
14596 if ( m==start_def ) {
14597 mp_link(p)=mp_scan_toks(mp, macro_def,r,null,n);
14599 q=mp_get_avail(mp); info(q)=mp->bg_loc; mp_link(p)=q;
14600 p=mp_get_avail(mp); info(p)=mp->eg_loc;
14601 mp_link(q)=mp_scan_toks(mp, macro_def,r,p,n);
14603 if ( mp->warning_info==bad_vardef )
14604 mp_flush_token_list(mp, value(bad_vardef))
14608 int eg_loc; /* hash addresses of `\.{begingroup}' and `\.{endgroup}' */
14610 @ @<Scan the token or variable to be defined;...@>=
14611 if ( m==start_def ) {
14612 mp_get_clear_symbol(mp); mp->warning_info=mp->cur_sym; get_t_next;
14613 mp->scanner_status=op_defining; n=0;
14614 eq_type(mp->warning_info)=defined_macro; equiv(mp->warning_info)=q;
14616 p=mp_scan_declared_variable(mp);
14617 mp_flush_variable(mp, equiv(info(p)),mp_link(p),true);
14618 mp->warning_info=mp_find_variable(mp, p); mp_flush_list(mp, p);
14619 if ( mp->warning_info==null ) @<Change to `\.{a bad variable}'@>;
14620 mp->scanner_status=var_defining; n=2;
14621 if ( mp->cur_cmd==macro_special ) if ( mp->cur_mod==macro_suffix ) {/* \.{\AT!\#} */
14624 type(mp->warning_info)=mp_unsuffixed_macro-2+n; value(mp->warning_info)=q;
14625 } /* |mp_suffixed_macro=mp_unsuffixed_macro+1| */
14627 @ @<Change to `\.{a bad variable}'@>=
14629 print_err("This variable already starts with a macro");
14630 @.This variable already...@>
14631 help2("After `vardef a' you can\'t say `vardef a.b'.",
14632 "So I'll have to discard this definition.");
14633 mp_error(mp); mp->warning_info=bad_vardef;
14636 @ @<Initialize table entries...@>=
14637 name_type(bad_vardef)=mp_root; mp_link(bad_vardef)=frozen_bad_vardef;
14638 equiv(frozen_bad_vardef)=bad_vardef; eq_type(frozen_bad_vardef)=tag_token;
14640 @ @<Absorb delimited parameters, putting them into lists |q| and |r|@>=
14642 l_delim=mp->cur_sym; r_delim=mp->cur_mod; get_t_next;
14643 if ( (mp->cur_cmd==param_type)&&(mp->cur_mod>=expr_base) ) {
14646 print_err("Missing parameter type; `expr' will be assumed");
14647 @.Missing parameter type@>
14648 help1("You should've had `expr' or `suffix' or `text' here.");
14649 mp_back_error(mp); base=expr_base;
14651 @<Absorb parameter tokens for type |base|@>;
14652 mp_check_delimiter(mp, l_delim,r_delim);
14654 } while (mp->cur_cmd==left_delimiter)
14656 @ @<Absorb parameter tokens for type |base|@>=
14658 mp_link(q)=mp_get_avail(mp); q=mp_link(q); info(q)=base+k;
14659 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
14660 value(p)=base+k; info(p)=mp->cur_sym;
14661 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14662 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
14663 incr(k); mp_link(p)=r; r=p; get_t_next;
14664 } while (mp->cur_cmd==comma)
14666 @ @<Absorb undelimited parameters, putting them into list |r|@>=
14668 p=mp_get_node(mp, token_node_size);
14669 if ( mp->cur_mod<expr_base ) {
14670 c=mp->cur_mod; value(p)=expr_base+k;
14672 value(p)=mp->cur_mod+k;
14673 if ( mp->cur_mod==expr_base ) c=expr_macro;
14674 else if ( mp->cur_mod==suffix_base ) c=suffix_macro;
14677 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14678 incr(k); mp_get_symbol(mp); info(p)=mp->cur_sym; mp_link(p)=r; r=p; get_t_next;
14679 if ( c==expr_macro ) if ( mp->cur_cmd==of_token ) {
14680 c=of_macro; p=mp_get_node(mp, token_node_size);
14681 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14682 value(p)=expr_base+k; mp_get_symbol(mp); info(p)=mp->cur_sym;
14683 mp_link(p)=r; r=p; get_t_next;
14687 @* \[32] Expanding the next token.
14688 Only a few command codes |<min_command| can possibly be returned by
14689 |get_t_next|; in increasing order, they are
14690 |if_test|, |fi_or_else|, |input|, |iteration|, |repeat_loop|,
14691 |exit_test|, |relax|, |scan_tokens|, |expand_after|, and |defined_macro|.
14693 \MP\ usually gets the next token of input by saying |get_x_next|. This is
14694 like |get_t_next| except that it keeps getting more tokens until
14695 finding |cur_cmd>=min_command|. In other words, |get_x_next| expands
14696 macros and removes conditionals or iterations or input instructions that
14699 It follows that |get_x_next| might invoke itself recursively. In fact,
14700 there is massive recursion, since macro expansion can involve the
14701 scanning of arbitrarily complex expressions, which in turn involve
14702 macro expansion and conditionals, etc.
14705 Therefore it's necessary to declare a whole bunch of |forward|
14706 procedures at this point, and to insert some other procedures
14707 that will be invoked by |get_x_next|.
14710 static void mp_scan_primary (MP mp);
14711 static void mp_scan_secondary (MP mp);
14712 static void mp_scan_tertiary (MP mp);
14713 static void mp_scan_expression (MP mp);
14714 static void mp_scan_suffix (MP mp);
14715 static void mp_get_boolean (MP mp);
14716 static void mp_pass_text (MP mp);
14717 static void mp_conditional (MP mp);
14718 static void mp_start_input (MP mp);
14719 static void mp_begin_iteration (MP mp);
14720 static void mp_resume_iteration (MP mp);
14721 static void mp_stop_iteration (MP mp);
14723 @ An auxiliary subroutine called |expand| is used by |get_x_next|
14724 when it has to do exotic expansion commands.
14727 static void mp_expand (MP mp) {
14728 pointer p; /* for list manipulation */
14729 size_t k; /* something that we hope is |<=buf_size| */
14730 pool_pointer j; /* index into |str_pool| */
14731 if ( mp->internal[mp_tracing_commands]>unity )
14732 if ( mp->cur_cmd!=defined_macro )
14734 switch (mp->cur_cmd) {
14736 mp_conditional(mp); /* this procedure is discussed in Part 36 below */
14739 @<Terminate the current conditional and skip to \&{fi}@>;
14742 @<Initiate or terminate input from a file@>;
14745 if ( mp->cur_mod==end_for ) {
14746 @<Scold the user for having an extra \&{endfor}@>;
14748 mp_begin_iteration(mp); /* this procedure is discussed in Part 37 below */
14755 @<Exit a loop if the proper time has come@>;
14760 @<Expand the token after the next token@>;
14763 @<Put a string into the input buffer@>;
14765 case defined_macro:
14766 mp_macro_call(mp, mp->cur_mod,null,mp->cur_sym);
14768 }; /* there are no other cases */
14771 @ @<Scold the user...@>=
14773 print_err("Extra `endfor'");
14775 help2("I'm not currently working on a for loop,",
14776 "so I had better not try to end anything.");
14780 @ The processing of \&{input} involves the |start_input| subroutine,
14781 which will be declared later; the processing of \&{endinput} is trivial.
14784 mp_primitive(mp, "input",input,0);
14785 @:input_}{\&{input} primitive@>
14786 mp_primitive(mp, "endinput",input,1);
14787 @:end_input_}{\&{endinput} primitive@>
14789 @ @<Cases of |print_cmd_mod|...@>=
14791 if ( m==0 ) mp_print(mp, "input");
14792 else mp_print(mp, "endinput");
14795 @ @<Initiate or terminate input...@>=
14796 if ( mp->cur_mod>0 ) mp->force_eof=true;
14797 else mp_start_input(mp)
14799 @ We'll discuss the complicated parts of loop operations later. For now
14800 it suffices to know that there's a global variable called |loop_ptr|
14801 that will be |null| if no loop is in progress.
14804 { while ( token_state &&(loc==null) )
14805 mp_end_token_list(mp); /* conserve stack space */
14806 if ( mp->loop_ptr==null ) {
14807 print_err("Lost loop");
14809 help2("I'm confused; after exiting from a loop, I still seem",
14810 "to want to repeat it. I'll try to forget the problem.");
14813 mp_resume_iteration(mp); /* this procedure is in Part 37 below */
14817 @ @<Exit a loop if the proper time has come@>=
14818 { mp_get_boolean(mp);
14819 if ( mp->internal[mp_tracing_commands]>unity )
14820 mp_show_cmd_mod(mp, nullary,mp->cur_exp);
14821 if ( mp->cur_exp==true_code ) {
14822 if ( mp->loop_ptr==null ) {
14823 print_err("No loop is in progress");
14824 @.No loop is in progress@>
14825 help1("Why say `exitif' when there's nothing to exit from?");
14826 if ( mp->cur_cmd==semicolon ) mp_error(mp); else mp_back_error(mp);
14828 @<Exit prematurely from an iteration@>;
14830 } else if ( mp->cur_cmd!=semicolon ) {
14831 mp_missing_err(mp, ";");
14833 help2("After `exitif <boolean exp>' I expect to see a semicolon.",
14834 "I shall pretend that one was there."); mp_back_error(mp);
14838 @ Here we use the fact that |forever_text| is the only |token_type| that
14839 is less than |loop_text|.
14841 @<Exit prematurely...@>=
14844 if ( file_state ) {
14845 mp_end_file_reading(mp);
14847 if ( token_type<=loop_text ) p=start;
14848 mp_end_token_list(mp);
14851 if ( p!=info(mp->loop_ptr) ) mp_fatal_error(mp, "*** (loop confusion)");
14853 mp_stop_iteration(mp); /* this procedure is in Part 34 below */
14856 @ @<Expand the token after the next token@>=
14858 p=mp_cur_tok(mp); get_t_next;
14859 if ( mp->cur_cmd<min_command ) mp_expand(mp);
14860 else mp_back_input(mp);
14864 @ @<Put a string into the input buffer@>=
14865 { mp_get_x_next(mp); mp_scan_primary(mp);
14866 if ( mp->cur_type!=mp_string_type ) {
14867 mp_disp_err(mp, null,"Not a string");
14869 help2("I'm going to flush this expression, since",
14870 "scantokens should be followed by a known string.");
14871 mp_put_get_flush_error(mp, 0);
14874 if ( length(mp->cur_exp)>0 )
14875 @<Pretend we're reading a new one-line file@>;
14879 @ @<Pretend we're reading a new one-line file@>=
14880 { mp_begin_file_reading(mp); name=is_scantok;
14881 k=mp->first+length(mp->cur_exp);
14882 if ( k>=mp->max_buf_stack ) {
14883 while ( k>=mp->buf_size ) {
14884 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size/4)));
14886 mp->max_buf_stack=k+1;
14888 j=mp->str_start[mp->cur_exp]; limit=(halfword)k;
14889 while ( mp->first<(size_t)limit ) {
14890 mp->buffer[mp->first]=mp->str_pool[j]; incr(j); incr(mp->first);
14892 mp->buffer[limit]=xord('%'); mp->first=(size_t)(limit+1); loc=start;
14893 mp_flush_cur_exp(mp, 0);
14896 @ Here finally is |get_x_next|.
14898 The expression scanning routines to be considered later
14899 communicate via the global quantities |cur_type| and |cur_exp|;
14900 we must be very careful to save and restore these quantities while
14901 macros are being expanded.
14905 static void mp_get_x_next (MP mp);
14907 @ @c void mp_get_x_next (MP mp) {
14908 pointer save_exp; /* a capsule to save |cur_type| and |cur_exp| */
14910 if ( mp->cur_cmd<min_command ) {
14911 save_exp=mp_stash_cur_exp(mp);
14913 if ( mp->cur_cmd==defined_macro )
14914 mp_macro_call(mp, mp->cur_mod,null,mp->cur_sym);
14918 } while (mp->cur_cmd<min_command);
14919 mp_unstash_cur_exp(mp, save_exp); /* that restores |cur_type| and |cur_exp| */
14923 @ Now let's consider the |macro_call| procedure, which is used to start up
14924 all user-defined macros. Since the arguments to a macro might be expressions,
14925 |macro_call| is recursive.
14928 The first parameter to |macro_call| points to the reference count of the
14929 token list that defines the macro. The second parameter contains any
14930 arguments that have already been parsed (see below). The third parameter
14931 points to the symbolic token that names the macro. If the third parameter
14932 is |null|, the macro was defined by \&{vardef}, so its name can be
14933 reconstructed from the prefix and ``at'' arguments found within the
14936 What is this second parameter? It's simply a linked list of one-word items,
14937 whose |info| fields point to the arguments. In other words, if |arg_list=null|,
14938 no arguments have been scanned yet; otherwise |info(arg_list)| points to
14939 the first scanned argument, and |mp_link(arg_list)| points to the list of
14940 further arguments (if any).
14942 Arguments of type \&{expr} are so-called capsules, which we will
14943 discuss later when we concentrate on expressions; they can be
14944 recognized easily because their |link| field is |void|. Arguments of type
14945 \&{suffix} and \&{text} are token lists without reference counts.
14947 @ After argument scanning is complete, the arguments are moved to the
14948 |param_stack|. (They can't be put on that stack any sooner, because
14949 the stack is growing and shrinking in unpredictable ways as more arguments
14950 are being acquired.) Then the macro body is fed to the scanner; i.e.,
14951 the replacement text of the macro is placed at the top of the \MP's
14952 input stack, so that |get_t_next| will proceed to read it next.
14955 static void mp_macro_call (MP mp,pointer def_ref, pointer arg_list,
14956 pointer macro_name) ;
14959 void mp_macro_call (MP mp,pointer def_ref, pointer arg_list,
14960 pointer macro_name) {
14961 /* invokes a user-defined control sequence */
14962 pointer r; /* current node in the macro's token list */
14963 pointer p,q; /* for list manipulation */
14964 integer n; /* the number of arguments */
14965 pointer tail = 0; /* tail of the argument list */
14966 pointer l_delim=0,r_delim=0; /* a delimiter pair */
14967 r=mp_link(def_ref); add_mac_ref(def_ref);
14968 if ( arg_list==null ) {
14971 @<Determine the number |n| of arguments already supplied,
14972 and set |tail| to the tail of |arg_list|@>;
14974 if ( mp->internal[mp_tracing_macros]>0 ) {
14975 @<Show the text of the macro being expanded, and the existing arguments@>;
14977 @<Scan the remaining arguments, if any; set |r| to the first token
14978 of the replacement text@>;
14979 @<Feed the arguments and replacement text to the scanner@>;
14982 @ @<Show the text of the macro...@>=
14983 mp_begin_diagnostic(mp); mp_print_ln(mp);
14984 mp_print_macro_name(mp, arg_list,macro_name);
14985 if ( n==3 ) mp_print(mp, "@@#"); /* indicate a suffixed macro */
14986 mp_show_macro(mp, def_ref,null,100000);
14987 if ( arg_list!=null ) {
14991 mp_print_arg(mp, q,n,0);
14992 incr(n); p=mp_link(p);
14995 mp_end_diagnostic(mp, false)
14998 @ @<Declarations@>=
14999 static void mp_print_macro_name (MP mp,pointer a, pointer n);
15002 void mp_print_macro_name (MP mp,pointer a, pointer n) {
15003 pointer p,q; /* they traverse the first part of |a| */
15009 mp_print_text(info(info(mp_link(a))));
15012 while ( mp_link(q)!=null ) q=mp_link(q);
15013 mp_link(q)=info(mp_link(a));
15014 mp_show_token_list(mp, p,null,1000,0);
15020 @ @<Declarations@>=
15021 static void mp_print_arg (MP mp,pointer q, integer n, pointer b) ;
15024 void mp_print_arg (MP mp,pointer q, integer n, pointer b) {
15025 if ( mp_link(q)==mp_void ) mp_print_nl(mp, "(EXPR");
15026 else if ( (b<text_base)&&(b!=text_macro) ) mp_print_nl(mp, "(SUFFIX");
15027 else mp_print_nl(mp, "(TEXT");
15028 mp_print_int(mp, n); mp_print(mp, ")<-");
15029 if ( mp_link(q)==mp_void ) mp_print_exp(mp, q,1);
15030 else mp_show_token_list(mp, q,null,1000,0);
15033 @ @<Determine the number |n| of arguments already supplied...@>=
15035 n=1; tail=arg_list;
15036 while ( mp_link(tail)!=null ) {
15037 incr(n); tail=mp_link(tail);
15041 @ @<Scan the remaining arguments, if any; set |r|...@>=
15042 mp->cur_cmd=comma+1; /* anything |<>comma| will do */
15043 while ( info(r)>=expr_base ) {
15044 @<Scan the delimited argument represented by |info(r)|@>;
15047 if ( mp->cur_cmd==comma ) {
15048 print_err("Too many arguments to ");
15049 @.Too many arguments...@>
15050 mp_print_macro_name(mp, arg_list,macro_name); mp_print_char(mp, xord(';'));
15051 mp_print_nl(mp, " Missing `"); mp_print_text(r_delim);
15053 mp_print(mp, "' has been inserted");
15054 help3("I'm going to assume that the comma I just read was a",
15055 "right delimiter, and then I'll begin expanding the macro.",
15056 "You might want to delete some tokens before continuing.");
15059 if ( info(r)!=general_macro ) {
15060 @<Scan undelimited argument(s)@>;
15064 @ At this point, the reader will find it advisable to review the explanation
15065 of token list format that was presented earlier, paying special attention to
15066 the conventions that apply only at the beginning of a macro's token list.
15068 On the other hand, the reader will have to take the expression-parsing
15069 aspects of the following program on faith; we will explain |cur_type|
15070 and |cur_exp| later. (Several things in this program depend on each other,
15071 and it's necessary to jump into the circle somewhere.)
15073 @<Scan the delimited argument represented by |info(r)|@>=
15074 if ( mp->cur_cmd!=comma ) {
15076 if ( mp->cur_cmd!=left_delimiter ) {
15077 print_err("Missing argument to ");
15078 @.Missing argument...@>
15079 mp_print_macro_name(mp, arg_list,macro_name);
15080 help3("That macro has more parameters than you thought.",
15081 "I'll continue by pretending that each missing argument",
15082 "is either zero or null.");
15083 if ( info(r)>=suffix_base ) {
15084 mp->cur_exp=null; mp->cur_type=mp_token_list;
15086 mp->cur_exp=0; mp->cur_type=mp_known;
15088 mp_back_error(mp); mp->cur_cmd=right_delimiter;
15091 l_delim=mp->cur_sym; r_delim=mp->cur_mod;
15093 @<Scan the argument represented by |info(r)|@>;
15094 if ( mp->cur_cmd!=comma )
15095 @<Check that the proper right delimiter was present@>;
15097 @<Append the current expression to |arg_list|@>
15099 @ @<Check that the proper right delim...@>=
15100 if ( (mp->cur_cmd!=right_delimiter)||(mp->cur_mod!=l_delim) ) {
15101 if ( info(mp_link(r))>=expr_base ) {
15102 mp_missing_err(mp, ",");
15104 help3("I've finished reading a macro argument and am about to",
15105 "read another; the arguments weren't delimited correctly.",
15106 "You might want to delete some tokens before continuing.");
15107 mp_back_error(mp); mp->cur_cmd=comma;
15109 mp_missing_err(mp, str(text(r_delim)));
15111 help2("I've gotten to the end of the macro parameter list.",
15112 "You might want to delete some tokens before continuing.");
15117 @ A \&{suffix} or \&{text} parameter will have been scanned as
15118 a token list pointed to by |cur_exp|, in which case we will have
15119 |cur_type=token_list|.
15121 @<Append the current expression to |arg_list|@>=
15123 p=mp_get_avail(mp);
15124 if ( mp->cur_type==mp_token_list ) info(p)=mp->cur_exp;
15125 else info(p)=mp_stash_cur_exp(mp);
15126 if ( mp->internal[mp_tracing_macros]>0 ) {
15127 mp_begin_diagnostic(mp); mp_print_arg(mp, info(p),n,info(r));
15128 mp_end_diagnostic(mp, false);
15130 if ( arg_list==null ) arg_list=p;
15131 else mp_link(tail)=p;
15135 @ @<Scan the argument represented by |info(r)|@>=
15136 if ( info(r)>=text_base ) {
15137 mp_scan_text_arg(mp, l_delim,r_delim);
15140 if ( info(r)>=suffix_base ) mp_scan_suffix(mp);
15141 else mp_scan_expression(mp);
15144 @ The parameters to |scan_text_arg| are either a pair of delimiters
15145 or zero; the latter case is for undelimited text arguments, which
15146 end with the first semicolon or \&{endgroup} or \&{end} that is not
15147 contained in a group.
15150 static void mp_scan_text_arg (MP mp,pointer l_delim, pointer r_delim) ;
15153 void mp_scan_text_arg (MP mp,pointer l_delim, pointer r_delim) {
15154 integer balance; /* excess of |l_delim| over |r_delim| */
15155 pointer p; /* list tail */
15156 mp->warning_info=l_delim; mp->scanner_status=absorbing;
15157 p=hold_head; balance=1; mp_link(hold_head)=null;
15160 if ( l_delim==0 ) {
15161 @<Adjust the balance for an undelimited argument; |break| if done@>;
15163 @<Adjust the balance for a delimited argument; |break| if done@>;
15165 mp_link(p)=mp_cur_tok(mp); p=mp_link(p);
15167 mp->cur_exp=mp_link(hold_head); mp->cur_type=mp_token_list;
15168 mp->scanner_status=normal;
15171 @ @<Adjust the balance for a delimited argument...@>=
15172 if ( mp->cur_cmd==right_delimiter ) {
15173 if ( mp->cur_mod==l_delim ) {
15175 if ( balance==0 ) break;
15177 } else if ( mp->cur_cmd==left_delimiter ) {
15178 if ( mp->cur_mod==r_delim ) incr(balance);
15181 @ @<Adjust the balance for an undelimited...@>=
15182 if ( end_of_statement ) { /* |cur_cmd=semicolon|, |end_group|, or |stop| */
15183 if ( balance==1 ) { break; }
15184 else { if ( mp->cur_cmd==end_group ) decr(balance); }
15185 } else if ( mp->cur_cmd==begin_group ) {
15189 @ @<Scan undelimited argument(s)@>=
15191 if ( info(r)<text_macro ) {
15193 if ( info(r)!=suffix_macro ) {
15194 if ( (mp->cur_cmd==equals)||(mp->cur_cmd==assignment) ) mp_get_x_next(mp);
15198 case primary_macro:mp_scan_primary(mp); break;
15199 case secondary_macro:mp_scan_secondary(mp); break;
15200 case tertiary_macro:mp_scan_tertiary(mp); break;
15201 case expr_macro:mp_scan_expression(mp); break;
15203 @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>;
15206 @<Scan a suffix with optional delimiters@>;
15208 case text_macro:mp_scan_text_arg(mp, 0,0); break;
15209 } /* there are no other cases */
15211 @<Append the current expression to |arg_list|@>;
15214 @ @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>=
15216 mp_scan_expression(mp); p=mp_get_avail(mp); info(p)=mp_stash_cur_exp(mp);
15217 if ( mp->internal[mp_tracing_macros]>0 ) {
15218 mp_begin_diagnostic(mp); mp_print_arg(mp, info(p),n,0);
15219 mp_end_diagnostic(mp, false);
15221 if ( arg_list==null ) arg_list=p; else mp_link(tail)=p;
15223 if ( mp->cur_cmd!=of_token ) {
15224 mp_missing_err(mp, "of"); mp_print(mp, " for ");
15226 mp_print_macro_name(mp, arg_list,macro_name);
15227 help1("I've got the first argument; will look now for the other.");
15230 mp_get_x_next(mp); mp_scan_primary(mp);
15233 @ @<Scan a suffix with optional delimiters@>=
15235 if ( mp->cur_cmd!=left_delimiter ) {
15238 l_delim=mp->cur_sym; r_delim=mp->cur_mod; mp_get_x_next(mp);
15240 mp_scan_suffix(mp);
15241 if ( l_delim!=null ) {
15242 if ((mp->cur_cmd!=right_delimiter)||(mp->cur_mod!=l_delim) ) {
15243 mp_missing_err(mp, str(text(r_delim)));
15245 help2("I've gotten to the end of the macro parameter list.",
15246 "You might want to delete some tokens before continuing.");
15253 @ Before we put a new token list on the input stack, it is wise to clean off
15254 all token lists that have recently been depleted. Then a user macro that ends
15255 with a call to itself will not require unbounded stack space.
15257 @<Feed the arguments and replacement text to the scanner@>=
15258 while ( token_state &&(loc==null) ) mp_end_token_list(mp); /* conserve stack space */
15259 if ( mp->param_ptr+n>mp->max_param_stack ) {
15260 mp->max_param_stack=mp->param_ptr+n;
15261 if ( mp->max_param_stack>mp->param_size )
15262 mp_overflow(mp, "parameter stack size",mp->param_size);
15263 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
15265 mp_begin_token_list(mp, def_ref,macro); name=macro_name; loc=r;
15269 mp->param_stack[mp->param_ptr]=info(p); incr(mp->param_ptr); p=mp_link(p);
15271 mp_flush_list(mp, arg_list);
15274 @ It's sometimes necessary to put a single argument onto |param_stack|.
15275 The |stack_argument| subroutine does this.
15278 static void mp_stack_argument (MP mp,pointer p) {
15279 if ( mp->param_ptr==mp->max_param_stack ) {
15280 incr(mp->max_param_stack);
15281 if ( mp->max_param_stack>mp->param_size )
15282 mp_overflow(mp, "parameter stack size",mp->param_size);
15283 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
15285 mp->param_stack[mp->param_ptr]=p; incr(mp->param_ptr);
15288 @* \[33] Conditional processing.
15289 Let's consider now the way \&{if} commands are handled.
15291 Conditions can be inside conditions, and this nesting has a stack
15292 that is independent of other stacks.
15293 Four global variables represent the top of the condition stack:
15294 |cond_ptr| points to pushed-down entries, if~any; |cur_if| tells whether
15295 we are processing \&{if} or \&{elseif}; |if_limit| specifies
15296 the largest code of a |fi_or_else| command that is syntactically legal;
15297 and |if_line| is the line number at which the current conditional began.
15299 If no conditions are currently in progress, the condition stack has the
15300 special state |cond_ptr=null|, |if_limit=normal|, |cur_if=0|, |if_line=0|.
15301 Otherwise |cond_ptr| points to a two-word node; the |type|, |name_type|, and
15302 |link| fields of the first word contain |if_limit|, |cur_if|, and
15303 |cond_ptr| at the next level, and the second word contains the
15304 corresponding |if_line|.
15306 @d if_node_size 2 /* number of words in stack entry for conditionals */
15307 @d if_line_field(A) mp->mem[(A)+1].cint
15308 @d if_code 1 /* code for \&{if} being evaluated */
15309 @d fi_code 2 /* code for \&{fi} */
15310 @d else_code 3 /* code for \&{else} */
15311 @d else_if_code 4 /* code for \&{elseif} */
15314 pointer cond_ptr; /* top of the condition stack */
15315 integer if_limit; /* upper bound on |fi_or_else| codes */
15316 quarterword cur_if; /* type of conditional being worked on */
15317 integer if_line; /* line where that conditional began */
15320 mp->cond_ptr=null; mp->if_limit=normal; mp->cur_if=0; mp->if_line=0;
15323 mp_primitive(mp, "if",if_test,if_code);
15324 @:if_}{\&{if} primitive@>
15325 mp_primitive(mp, "fi",fi_or_else,fi_code); mp->eqtb[frozen_fi]=mp->eqtb[mp->cur_sym];
15326 @:fi_}{\&{fi} primitive@>
15327 mp_primitive(mp, "else",fi_or_else,else_code);
15328 @:else_}{\&{else} primitive@>
15329 mp_primitive(mp, "elseif",fi_or_else,else_if_code);
15330 @:else_if_}{\&{elseif} primitive@>
15332 @ @<Cases of |print_cmd_mod|...@>=
15336 case if_code:mp_print(mp, "if"); break;
15337 case fi_code:mp_print(mp, "fi"); break;
15338 case else_code:mp_print(mp, "else"); break;
15339 default: mp_print(mp, "elseif"); break;
15343 @ Here is a procedure that ignores text until coming to an \&{elseif},
15344 \&{else}, or \&{fi} at level zero of $\&{if}\ldots\&{fi}$
15345 nesting. After it has acted, |cur_mod| will indicate the token that
15348 \MP's smallest two command codes are |if_test| and |fi_or_else|; this
15349 makes the skipping process a bit simpler.
15352 void mp_pass_text (MP mp) {
15354 mp->scanner_status=skipping;
15355 mp->warning_info=mp_true_line(mp);
15358 if ( mp->cur_cmd<=fi_or_else ) {
15359 if ( mp->cur_cmd<fi_or_else ) {
15363 if ( mp->cur_mod==fi_code ) decr(l);
15366 @<Decrease the string reference count,
15367 if the current token is a string@>;
15370 mp->scanner_status=normal;
15373 @ @<Decrease the string reference count...@>=
15374 if ( mp->cur_cmd==string_token ) { delete_str_ref(mp->cur_mod); }
15376 @ When we begin to process a new \&{if}, we set |if_limit:=if_code|; then
15377 if \&{elseif} or \&{else} or \&{fi} occurs before the current \&{if}
15378 condition has been evaluated, a colon will be inserted.
15379 A construction like `\.{if fi}' would otherwise get \MP\ confused.
15381 @<Push the condition stack@>=
15382 { p=mp_get_node(mp, if_node_size); mp_link(p)=mp->cond_ptr; type(p)=mp->if_limit;
15383 name_type(p)=mp->cur_if; if_line_field(p)=mp->if_line;
15384 mp->cond_ptr=p; mp->if_limit=if_code; mp->if_line=mp_true_line(mp);
15385 mp->cur_if=if_code;
15388 @ @<Pop the condition stack@>=
15389 { p=mp->cond_ptr; mp->if_line=if_line_field(p);
15390 mp->cur_if=name_type(p); mp->if_limit=type(p); mp->cond_ptr=mp_link(p);
15391 mp_free_node(mp, p,if_node_size);
15394 @ Here's a procedure that changes the |if_limit| code corresponding to
15395 a given value of |cond_ptr|.
15398 static void mp_change_if_limit (MP mp,quarterword l, pointer p) {
15400 if ( p==mp->cond_ptr ) {
15401 mp->if_limit=l; /* that's the easy case */
15405 if ( q==null ) mp_confusion(mp, "if");
15406 @:this can't happen if}{\quad if@>
15407 if ( mp_link(q)==p ) {
15415 @ The user is supposed to put colons into the proper parts of conditional
15416 statements. Therefore, \MP\ has to check for their presence.
15419 static void mp_check_colon (MP mp) {
15420 if ( mp->cur_cmd!=colon ) {
15421 mp_missing_err(mp, ":");
15423 help2("There should've been a colon after the condition.",
15424 "I shall pretend that one was there.");
15429 @ A condition is started when the |get_x_next| procedure encounters
15430 an |if_test| command; in that case |get_x_next| calls |conditional|,
15431 which is a recursive procedure.
15435 void mp_conditional (MP mp) {
15436 pointer save_cond_ptr; /* |cond_ptr| corresponding to this conditional */
15437 int new_if_limit; /* future value of |if_limit| */
15438 pointer p; /* temporary register */
15439 @<Push the condition stack@>;
15440 save_cond_ptr=mp->cond_ptr;
15442 mp_get_boolean(mp); new_if_limit=else_if_code;
15443 if ( mp->internal[mp_tracing_commands]>unity ) {
15444 @<Display the boolean value of |cur_exp|@>;
15447 mp_check_colon(mp);
15448 if ( mp->cur_exp==true_code ) {
15449 mp_change_if_limit(mp, new_if_limit,save_cond_ptr);
15450 return; /* wait for \&{elseif}, \&{else}, or \&{fi} */
15452 @<Skip to \&{elseif} or \&{else} or \&{fi}, then |goto done|@>;
15454 mp->cur_if=mp->cur_mod; mp->if_line=mp_true_line(mp);
15455 if ( mp->cur_mod==fi_code ) {
15456 @<Pop the condition stack@>
15457 } else if ( mp->cur_mod==else_if_code ) {
15460 mp->cur_exp=true_code; new_if_limit=fi_code; mp_get_x_next(mp);
15465 @ In a construction like `\&{if} \&{if} \&{true}: $0=1$: \\{foo}
15466 \&{else}: \\{bar} \&{fi}', the first \&{else}
15467 that we come to after learning that the \&{if} is false is not the
15468 \&{else} we're looking for. Hence the following curious logic is needed.
15470 @<Skip to \&{elseif}...@>=
15473 if ( mp->cond_ptr==save_cond_ptr ) goto DONE;
15474 else if ( mp->cur_mod==fi_code ) @<Pop the condition stack@>;
15478 @ @<Display the boolean value...@>=
15479 { mp_begin_diagnostic(mp);
15480 if ( mp->cur_exp==true_code ) mp_print(mp, "{true}");
15481 else mp_print(mp, "{false}");
15482 mp_end_diagnostic(mp, false);
15485 @ The processing of conditionals is complete except for the following
15486 code, which is actually part of |get_x_next|. It comes into play when
15487 \&{elseif}, \&{else}, or \&{fi} is scanned.
15489 @<Terminate the current conditional and skip to \&{fi}@>=
15490 if ( mp->cur_mod>mp->if_limit ) {
15491 if ( mp->if_limit==if_code ) { /* condition not yet evaluated */
15492 mp_missing_err(mp, ":");
15494 mp_back_input(mp); mp->cur_sym=frozen_colon; mp_ins_error(mp);
15496 print_err("Extra "); mp_print_cmd_mod(mp, fi_or_else,mp->cur_mod);
15500 help1("I'm ignoring this; it doesn't match any if.");
15504 while ( mp->cur_mod!=fi_code ) mp_pass_text(mp); /* skip to \&{fi} */
15505 @<Pop the condition stack@>;
15508 @* \[34] Iterations.
15509 To bring our treatment of |get_x_next| to a close, we need to consider what
15510 \MP\ does when it sees \&{for}, \&{forsuffixes}, and \&{forever}.
15512 There's a global variable |loop_ptr| that keeps track of the \&{for} loops
15513 that are currently active. If |loop_ptr=null|, no loops are in progress;
15514 otherwise |info(loop_ptr)| points to the iterative text of the current
15515 (innermost) loop, and |mp_link(loop_ptr)| points to the data for any other
15516 loops that enclose the current one.
15518 A loop-control node also has two other fields, called |loop_type| and
15519 |loop_list|, whose contents depend on the type of loop:
15521 \yskip\indent|loop_type(loop_ptr)=null| means that |loop_list(loop_ptr)|
15522 points to a list of one-word nodes whose |info| fields point to the
15523 remaining argument values of a suffix list and expression list.
15525 \yskip\indent|loop_type(loop_ptr)=mp_void| means that the current loop is
15528 \yskip\indent|loop_type(loop_ptr)=progression_flag| means that
15529 |p=loop_list(loop_ptr)| points to a ``progression node'' and |value(p)|,
15530 |step_size(p)|, and |final_value(p)| contain the data for an arithmetic
15533 \yskip\indent|loop_type(loop_ptr)=p>mp_void| means that |p| points to an edge
15534 header and |loop_list(loop_ptr)| points into the graphical object list for
15537 \yskip\noindent In the case of a progression node, the first word is not used
15538 because the link field of words in the dynamic memory area cannot be arbitrary.
15540 @d loop_list_loc(A) ((A)+1) /* where the |loop_list| field resides */
15541 @d loop_type(A) info(loop_list_loc((A))) /* the type of \&{for} loop */
15542 @d loop_list(A) mp_link(loop_list_loc((A))) /* the remaining list elements */
15543 @d loop_node_size 2 /* the number of words in a loop control node */
15544 @d progression_node_size 4 /* the number of words in a progression node */
15545 @d step_size(A) mp->mem[(A)+2].sc /* the step size in an arithmetic progression */
15546 @d final_value(A) mp->mem[(A)+3].sc /* the final value in an arithmetic progression */
15547 @d progression_flag (null+2)
15548 /* |loop_type| value when |loop_list| points to a progression node */
15551 pointer loop_ptr; /* top of the loop-control-node stack */
15556 @ If the expressions that define an arithmetic progression in
15557 a \&{for} loop don't have known numeric values, the |bad_for|
15558 subroutine screams at the user.
15561 static void mp_bad_for (MP mp, const char * s) {
15562 mp_disp_err(mp, null,"Improper "); /* show the bad expression above the message */
15563 @.Improper...replaced by 0@>
15564 mp_print(mp, s); mp_print(mp, " has been replaced by 0");
15565 help4("When you say `for x=a step b until c',",
15566 "the initial value `a' and the step size `b'",
15567 "and the final value `c' must have known numeric values.",
15568 "I'm zeroing this one. Proceed, with fingers crossed.");
15569 mp_put_get_flush_error(mp, 0);
15572 @ Here's what \MP\ does when \&{for}, \&{forsuffixes}, or \&{forever}
15573 has just been scanned. (This code requires slight familiarity with
15574 expression-parsing routines that we have not yet discussed; but it seems
15575 to belong in the present part of the program, even though the original author
15576 didn't write it until later. The reader may wish to come back to it.)
15578 @c void mp_begin_iteration (MP mp) {
15579 halfword m; /* |expr_base| (\&{for}) or |suffix_base| (\&{forsuffixes}) */
15580 halfword n; /* hash address of the current symbol */
15581 pointer s; /* the new loop-control node */
15582 pointer p; /* substitution list for |scan_toks| */
15583 pointer q; /* link manipulation register */
15584 pointer pp; /* a new progression node */
15585 m=mp->cur_mod; n=mp->cur_sym; s=mp_get_node(mp, loop_node_size);
15586 if ( m==start_forever ){
15587 loop_type(s)=mp_void; p=null; mp_get_x_next(mp);
15589 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
15590 info(p)=mp->cur_sym; value(p)=m;
15592 if ( mp->cur_cmd==within_token ) {
15593 @<Set up a picture iteration@>;
15595 @<Check for the |"="| or |":="| in a loop header@>;
15596 @<Scan the values to be used in the loop@>;
15599 @<Check for the presence of a colon@>;
15600 @<Scan the loop text and put it on the loop control stack@>;
15601 mp_resume_iteration(mp);
15604 @ @<Check for the |"="| or |":="| in a loop header@>=
15605 if ( (mp->cur_cmd!=equals)&&(mp->cur_cmd!=assignment) ) {
15606 mp_missing_err(mp, "=");
15608 help3("The next thing in this loop should have been `=' or `:='.",
15609 "But don't worry; I'll pretend that an equals sign",
15610 "was present, and I'll look for the values next.");
15614 @ @<Check for the presence of a colon@>=
15615 if ( mp->cur_cmd!=colon ) {
15616 mp_missing_err(mp, ":");
15618 help3("The next thing in this loop should have been a `:'.",
15619 "So I'll pretend that a colon was present;",
15620 "everything from here to `endfor' will be iterated.");
15624 @ We append a special |frozen_repeat_loop| token in place of the
15625 `\&{endfor}' at the end of the loop. This will come through \MP's scanner
15626 at the proper time to cause the loop to be repeated.
15628 (If the user tries some shenanigan like `\&{for} $\ldots$ \&{let} \&{endfor}',
15629 he will be foiled by the |get_symbol| routine, which keeps frozen
15630 tokens unchanged. Furthermore the |frozen_repeat_loop| is an \&{outer}
15631 token, so it won't be lost accidentally.)
15633 @ @<Scan the loop text...@>=
15634 q=mp_get_avail(mp); info(q)=frozen_repeat_loop;
15635 mp->scanner_status=loop_defining; mp->warning_info=n;
15636 info(s)=mp_scan_toks(mp, iteration,p,q,0); mp->scanner_status=normal;
15637 mp_link(s)=mp->loop_ptr; mp->loop_ptr=s
15639 @ @<Initialize table...@>=
15640 eq_type(frozen_repeat_loop)=repeat_loop+outer_tag;
15641 text(frozen_repeat_loop)=intern(" ENDFOR");
15643 @ The loop text is inserted into \MP's scanning apparatus by the
15644 |resume_iteration| routine.
15646 @c void mp_resume_iteration (MP mp) {
15647 pointer p,q; /* link registers */
15648 p=loop_type(mp->loop_ptr);
15649 if ( p==progression_flag ) {
15650 p=loop_list(mp->loop_ptr); /* now |p| points to a progression node */
15651 mp->cur_exp=value(p);
15652 if ( @<The arithmetic progression has ended@> ) {
15653 mp_stop_iteration(mp);
15656 mp->cur_type=mp_known; q=mp_stash_cur_exp(mp); /* make |q| an \&{expr} argument */
15657 value(p)=mp->cur_exp+step_size(p); /* set |value(p)| for the next iteration */
15658 } else if ( p==null ) {
15659 p=loop_list(mp->loop_ptr);
15661 mp_stop_iteration(mp);
15664 loop_list(mp->loop_ptr)=mp_link(p); q=info(p); free_avail(p);
15665 } else if ( p==mp_void ) {
15666 mp_begin_token_list(mp, info(mp->loop_ptr),forever_text); return;
15668 @<Make |q| a capsule containing the next picture component from
15669 |loop_list(loop_ptr)| or |goto not_found|@>;
15671 mp_begin_token_list(mp, info(mp->loop_ptr),loop_text);
15672 mp_stack_argument(mp, q);
15673 if ( mp->internal[mp_tracing_commands]>unity ) {
15674 @<Trace the start of a loop@>;
15678 mp_stop_iteration(mp);
15681 @ @<The arithmetic progression has ended@>=
15682 ((step_size(p)>0)&&(mp->cur_exp>final_value(p)))||
15683 ((step_size(p)<0)&&(mp->cur_exp<final_value(p)))
15685 @ @<Trace the start of a loop@>=
15687 mp_begin_diagnostic(mp); mp_print_nl(mp, "{loop value=");
15689 if ( (q!=null)&&(mp_link(q)==mp_void) ) mp_print_exp(mp, q,1);
15690 else mp_show_token_list(mp, q,null,50,0);
15691 mp_print_char(mp, xord('}')); mp_end_diagnostic(mp, false);
15694 @ @<Make |q| a capsule containing the next picture component from...@>=
15695 { q=loop_list(mp->loop_ptr);
15696 if ( q==null ) goto NOT_FOUND;
15697 skip_component(q) goto NOT_FOUND;
15698 mp->cur_exp=mp_copy_objects(mp, loop_list(mp->loop_ptr),q);
15699 mp_init_bbox(mp, mp->cur_exp);
15700 mp->cur_type=mp_picture_type;
15701 loop_list(mp->loop_ptr)=q;
15702 q=mp_stash_cur_exp(mp);
15705 @ A level of loop control disappears when |resume_iteration| has decided
15706 not to resume, or when an \&{exitif} construction has removed the loop text
15707 from the input stack.
15709 @c void mp_stop_iteration (MP mp) {
15710 pointer p,q; /* the usual */
15711 p=loop_type(mp->loop_ptr);
15712 if ( p==progression_flag ) {
15713 mp_free_node(mp, loop_list(mp->loop_ptr),progression_node_size);
15714 } else if ( p==null ){
15715 q=loop_list(mp->loop_ptr);
15716 while ( q!=null ) {
15719 if ( mp_link(p)==mp_void ) { /* it's an \&{expr} parameter */
15720 mp_recycle_value(mp, p); mp_free_node(mp, p,value_node_size);
15722 mp_flush_token_list(mp, p); /* it's a \&{suffix} or \&{text} parameter */
15725 p=q; q=mp_link(q); free_avail(p);
15727 } else if ( p>progression_flag ) {
15728 delete_edge_ref(p);
15730 p=mp->loop_ptr; mp->loop_ptr=mp_link(p); mp_flush_token_list(mp, info(p));
15731 mp_free_node(mp, p,loop_node_size);
15734 @ Now that we know all about loop control, we can finish up
15735 the missing portion of |begin_iteration| and we'll be done.
15737 The following code is performed after the `\.=' has been scanned in
15738 a \&{for} construction (if |m=expr_base|) or a \&{forsuffixes} construction
15739 (if |m=suffix_base|).
15741 @<Scan the values to be used in the loop@>=
15742 loop_type(s)=null; q=loop_list_loc(s); mp_link(q)=null; /* |mp_link(q)=loop_list(s)| */
15745 if ( m!=expr_base ) {
15746 mp_scan_suffix(mp);
15748 if ( mp->cur_cmd>=colon ) if ( mp->cur_cmd<=comma )
15750 mp_scan_expression(mp);
15751 if ( mp->cur_cmd==step_token ) if ( q==loop_list_loc(s) ) {
15752 @<Prepare for step-until construction and |break|@>;
15754 mp->cur_exp=mp_stash_cur_exp(mp);
15756 mp_link(q)=mp_get_avail(mp); q=mp_link(q);
15757 info(q)=mp->cur_exp; mp->cur_type=mp_vacuous;
15760 } while (mp->cur_cmd==comma)
15762 @ @<Prepare for step-until construction and |break|@>=
15764 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "initial value");
15765 pp=mp_get_node(mp, progression_node_size); value(pp)=mp->cur_exp;
15766 mp_get_x_next(mp); mp_scan_expression(mp);
15767 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "step size");
15768 step_size(pp)=mp->cur_exp;
15769 if ( mp->cur_cmd!=until_token ) {
15770 mp_missing_err(mp, "until");
15771 @.Missing `until'@>
15772 help2("I assume you meant to say `until' after `step'.",
15773 "So I'll look for the final value and colon next.");
15776 mp_get_x_next(mp); mp_scan_expression(mp);
15777 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "final value");
15778 final_value(pp)=mp->cur_exp; loop_list(s)=pp;
15779 loop_type(s)=progression_flag;
15783 @ The last case is when we have just seen ``\&{within}'', and we need to
15784 parse a picture expression and prepare to iterate over it.
15786 @<Set up a picture iteration@>=
15787 { mp_get_x_next(mp);
15788 mp_scan_expression(mp);
15789 @<Make sure the current expression is a known picture@>;
15790 loop_type(s)=mp->cur_exp; mp->cur_type=mp_vacuous;
15791 q=mp_link(dummy_loc(mp->cur_exp));
15793 if ( is_start_or_stop(q) )
15794 if ( mp_skip_1component(mp, q)==null ) q=mp_link(q);
15798 @ @<Make sure the current expression is a known picture@>=
15799 if ( mp->cur_type!=mp_picture_type ) {
15800 mp_disp_err(mp, null,"Improper iteration spec has been replaced by nullpicture");
15801 help1("When you say `for x in p', p must be a known picture.");
15802 mp_put_get_flush_error(mp, mp_get_node(mp, edge_header_size));
15803 mp_init_edges(mp, mp->cur_exp); mp->cur_type=mp_picture_type;
15806 @* \[35] File names.
15807 It's time now to fret about file names. Besides the fact that different
15808 operating systems treat files in different ways, we must cope with the
15809 fact that completely different naming conventions are used by different
15810 groups of people. The following programs show what is required for one
15811 particular operating system; similar routines for other systems are not
15812 difficult to devise.
15813 @^system dependencies@>
15815 \MP\ assumes that a file name has three parts: the name proper; its
15816 ``extension''; and a ``file area'' where it is found in an external file
15817 system. The extension of an input file is assumed to be
15818 `\.{.mp}' unless otherwise specified; it is `\.{.log}' on the
15819 transcript file that records each run of \MP; it is `\.{.tfm}' on the font
15820 metric files that describe characters in any fonts created by \MP; it is
15821 `\.{.ps}' or `.{\it nnn}' for some number {\it nnn} on the \ps\ output files;
15822 and it is `\.{.mem}' on the mem files written by \.{INIMP} to initialize \MP.
15823 The file area can be arbitrary on input files, but files are usually
15824 output to the user's current area. If an input file cannot be
15825 found on the specified area, \MP\ will look for it on a special system
15826 area; this special area is intended for commonly used input files.
15828 Simple uses of \MP\ refer only to file names that have no explicit
15829 extension or area. For example, a person usually says `\.{input} \.{cmr10}'
15830 instead of `\.{input} \.{cmr10.new}'. Simple file
15831 names are best, because they make the \MP\ source files portable;
15832 whenever a file name consists entirely of letters and digits, it should be
15833 treated in the same way by all implementations of \MP. However, users
15834 need the ability to refer to other files in their environment, especially
15835 when responding to error messages concerning unopenable files; therefore
15836 we want to let them use the syntax that appears in their favorite
15839 @ \MP\ uses the same conventions that have proved to be satisfactory for
15840 \TeX\ and \MF. In order to isolate the system-dependent aspects of file names,
15841 @^system dependencies@>
15842 the system-independent parts of \MP\ are expressed in terms
15843 of three system-dependent
15844 procedures called |begin_name|, |more_name|, and |end_name|. In
15845 essence, if the user-specified characters of the file name are $c_1\ldots c_n$,
15846 the system-independent driver program does the operations
15847 $$|begin_name|;\,|more_name|(c_1);\,\ldots\,;\,|more_name|(c_n);
15849 These three procedures communicate with each other via global variables.
15850 Afterwards the file name will appear in the string pool as three strings
15851 called |cur_name|\penalty10000\hskip-.05em,
15852 |cur_area|, and |cur_ext|; the latter two are null (i.e.,
15853 |""|), unless they were explicitly specified by the user.
15855 Actually the situation is slightly more complicated, because \MP\ needs
15856 to know when the file name ends. The |more_name| routine is a function
15857 (with side effects) that returns |true| on the calls |more_name|$(c_1)$,
15858 \dots, |more_name|$(c_{n-1})$. The final call |more_name|$(c_n)$
15859 returns |false|; or, it returns |true| and $c_n$ is the last character
15860 on the current input line. In other words,
15861 |more_name| is supposed to return |true| unless it is sure that the
15862 file name has been completely scanned; and |end_name| is supposed to be able
15863 to finish the assembly of |cur_name|, |cur_area|, and |cur_ext| regardless of
15864 whether $|more_name|(c_n)$ returned |true| or |false|.
15867 char * cur_name; /* name of file just scanned */
15868 char * cur_area; /* file area just scanned, or \.{""} */
15869 char * cur_ext; /* file extension just scanned, or \.{""} */
15871 @ It is easier to maintain reference counts if we assign initial values.
15874 mp->cur_name=xstrdup("");
15875 mp->cur_area=xstrdup("");
15876 mp->cur_ext=xstrdup("");
15878 @ @<Dealloc variables@>=
15879 xfree(mp->cur_area);
15880 xfree(mp->cur_name);
15881 xfree(mp->cur_ext);
15883 @ The file names we shall deal with for illustrative purposes have the
15884 following structure: If the name contains `\.>' or `\.:', the file area
15885 consists of all characters up to and including the final such character;
15886 otherwise the file area is null. If the remaining file name contains
15887 `\..', the file extension consists of all such characters from the first
15888 remaining `\..' to the end, otherwise the file extension is null.
15889 @^system dependencies@>
15891 We can scan such file names easily by using two global variables that keep track
15892 of the occurrences of area and extension delimiters. Note that these variables
15893 cannot be of type |pool_pointer| because a string pool compaction could occur
15894 while scanning a file name.
15897 integer area_delimiter;
15898 /* most recent `\.>' or `\.:' relative to |str_start[str_ptr]| */
15899 integer ext_delimiter; /* the relevant `\..', if any */
15901 @ Here now is the first of the system-dependent routines for file name scanning.
15902 @^system dependencies@>
15904 The file name length is limited to |file_name_size|. That is good, because
15905 in the current configuration we cannot call |mp_do_compaction| while a name
15906 is being scanned, |mp->area_delimiter| and |mp->ext_delimiter| are direct
15907 offsets into |mp->str_pool|. I am not in a great hurry to fix this, because
15908 calling |str_room()| just once is more efficient anyway. TODO.
15911 static void mp_begin_name (MP mp);
15912 static boolean mp_more_name (MP mp, ASCII_code c);
15913 static void mp_end_name (MP mp);
15916 void mp_begin_name (MP mp) {
15917 xfree(mp->cur_name);
15918 xfree(mp->cur_area);
15919 xfree(mp->cur_ext);
15920 mp->area_delimiter=-1;
15921 mp->ext_delimiter=-1;
15922 str_room(file_name_size);
15925 @ And here's the second.
15926 @^system dependencies@>
15929 boolean mp_more_name (MP mp, ASCII_code c) {
15933 if ( (c=='>')||(c==':') ) {
15934 mp->area_delimiter=mp->pool_ptr;
15935 mp->ext_delimiter=-1;
15936 } else if ( (c=='.')&&(mp->ext_delimiter<0) ) {
15937 mp->ext_delimiter=mp->pool_ptr;
15939 append_char(c); /* contribute |c| to the current string */
15945 @^system dependencies@>
15947 @d copy_pool_segment(A,B,C) {
15948 A = xmalloc(C+1,sizeof(char));
15949 strncpy(A,(char *)(mp->str_pool+B),C);
15953 void mp_end_name (MP mp) {
15954 pool_pointer s; /* length of area, name, and extension */
15957 s = mp->str_start[mp->str_ptr];
15958 if ( mp->area_delimiter<0 ) {
15959 mp->cur_area=xstrdup("");
15961 len = (unsigned)(mp->area_delimiter-s);
15962 copy_pool_segment(mp->cur_area,s,len);
15965 if ( mp->ext_delimiter<0 ) {
15966 mp->cur_ext=xstrdup("");
15967 len = (unsigned)(mp->pool_ptr-s);
15969 copy_pool_segment(mp->cur_ext,mp->ext_delimiter,(size_t)(mp->pool_ptr-mp->ext_delimiter));
15970 len = (unsigned)(mp->ext_delimiter-s);
15972 copy_pool_segment(mp->cur_name,s,len);
15973 mp->pool_ptr=s; /* don't need this partial string */
15976 @ Conversely, here is a routine that takes three strings and prints a file
15977 name that might have produced them. (The routine is system dependent, because
15978 some operating systems put the file area last instead of first.)
15979 @^system dependencies@>
15981 @<Basic printing...@>=
15982 static void mp_print_file_name (MP mp, char * n, char * a, char * e) {
15983 mp_print(mp, a); mp_print(mp, n); mp_print(mp, e);
15986 @ Another system-dependent routine is needed to convert three internal
15988 to the |name_of_file| value that is used to open files. The present code
15989 allows both lowercase and uppercase letters in the file name.
15990 @^system dependencies@>
15992 @d append_to_name(A) { c=xord((int)(A));
15993 if ( k<file_name_size ) {
15994 mp->name_of_file[k]=(char)xchr(c);
16000 void mp_pack_file_name (MP mp, const char *n, const char *a, const char *e) {
16001 integer k; /* number of positions filled in |name_of_file| */
16002 ASCII_code c; /* character being packed */
16003 const char *j; /* a character index */
16007 for (j=a;*j!='\0';j++) { append_to_name(*j); }
16009 for (j=n;*j!='\0';j++) { append_to_name(*j); }
16011 for (j=e;*j!='\0';j++) { append_to_name(*j); }
16013 mp->name_of_file[k]=0;
16017 @ @<Internal library declarations@>=
16018 void mp_pack_file_name (MP mp, const char *n, const char *a, const char *e) ;
16020 @ @<Option variables@>=
16021 char *mem_name; /* for commandline */
16023 @ @<Find constant sizes@>=
16024 mp->mem_name = xstrdup(opt->mem_name);
16025 if (mp->mem_name) {
16026 size_t l = strlen(mp->mem_name);
16028 char *test = strstr(mp->mem_name,".mem");
16029 if (test == mp->mem_name+l-4) {
16036 @ @<Dealloc variables@>=
16037 xfree(mp->mem_name);
16039 @ This part of the program becomes active when a ``virgin'' \MP\ is
16040 trying to get going, just after the preliminary initialization, or
16041 when the user is substituting another mem file by typing `\.\&' after
16042 the initial `\.{**}' prompt. The buffer contains the first line of
16043 input in |buffer[loc..(last-1)]|, where |loc<last| and |buffer[loc]<>""|.
16046 static boolean mp_open_mem_name (MP mp) ;
16047 static boolean mp_open_mem_file (MP mp) ;
16050 boolean mp_open_mem_name (MP mp) {
16051 if (mp->mem_name!=NULL) {
16052 size_t l = strlen(mp->mem_name);
16053 char *s = xstrdup (mp->mem_name);
16055 char *test = strstr(s,".mem");
16056 if (test == NULL || test != s+l-4) {
16057 s = xrealloc (s, l+5, 1);
16058 strcat (s, ".mem");
16061 s = xrealloc (s, l+5, 1);
16062 strcat (s, ".mem");
16064 mp->mem_file = (mp->open_file)(mp,s, "r", mp_filetype_memfile);
16066 if ( mp->mem_file ) return true;
16070 boolean mp_open_mem_file (MP mp) {
16071 if (mp->mem_file != NULL)
16073 if (mp_open_mem_name(mp))
16075 if (mp_xstrcmp(mp->mem_name, "plain")) {
16077 wterm_ln("Sorry, I can\'t find that mem file; will try PLAIN.");
16078 @.Sorry, I can't find...@>
16080 /* now pull out all the stops: try for the system \.{plain} file */
16081 xfree(mp->mem_name);
16082 mp->mem_name = xstrdup("plain");
16083 if (mp_open_mem_name(mp))
16087 wterm_ln("I can\'t find the PLAIN mem file!");
16088 @.I can't find PLAIN...@>
16093 @ Operating systems often make it possible to determine the exact name (and
16094 possible version number) of a file that has been opened. The following routine,
16095 which simply makes a \MP\ string from the value of |name_of_file|, should
16096 ideally be changed to deduce the full name of file~|f|, which is the file
16097 most recently opened, if it is possible to do this.
16098 @^system dependencies@>
16101 #define mp_a_make_name_string(A,B) mp_make_name_string(A)
16102 #define mp_b_make_name_string(A,B) mp_make_name_string(A)
16103 #define mp_w_make_name_string(A,B) mp_make_name_string(A)
16106 static str_number mp_make_name_string (MP mp) {
16107 int k; /* index into |name_of_file| */
16108 str_room(mp->name_length);
16109 for (k=0;k<mp->name_length;k++) {
16110 append_char(xord((int)mp->name_of_file[k]));
16112 return mp_make_string(mp);
16115 @ Now let's consider the ``driver''
16116 routines by which \MP\ deals with file names
16117 in a system-independent manner. First comes a procedure that looks for a
16118 file name in the input by taking the information from the input buffer.
16119 (We can't use |get_next|, because the conversion to tokens would
16120 destroy necessary information.)
16122 This procedure doesn't allow semicolons or percent signs to be part of
16123 file names, because of other conventions of \MP.
16124 {\sl The {\logos METAFONT\/}book} doesn't
16125 use semicolons or percents immediately after file names, but some users
16126 no doubt will find it natural to do so; therefore system-dependent
16127 changes to allow such characters in file names should probably
16128 be made with reluctance, and only when an entire file name that
16129 includes special characters is ``quoted'' somehow.
16130 @^system dependencies@>
16133 static void mp_scan_file_name (MP mp) {
16135 while ( mp->buffer[loc]==' ' ) incr(loc);
16137 if ( (mp->buffer[loc]==';')||(mp->buffer[loc]=='%') ) break;
16138 if ( ! mp_more_name(mp, mp->buffer[loc]) ) break;
16144 @ Here is another version that takes its input from a string.
16146 @<Declare subroutines for parsing file names@>=
16147 void mp_str_scan_file (MP mp, str_number s) ;
16150 void mp_str_scan_file (MP mp, str_number s) {
16151 pool_pointer p,q; /* current position and stopping point */
16153 p=mp->str_start[s]; q=str_stop(s);
16155 if ( ! mp_more_name(mp, mp->str_pool[p]) ) break;
16161 @ And one that reads from a |char*|.
16163 @<Declare subroutines for parsing file names@>=
16164 extern void mp_ptr_scan_file (MP mp, char *s);
16167 void mp_ptr_scan_file (MP mp, char *s) {
16168 char *p, *q; /* current position and stopping point */
16170 p=s; q=p+strlen(s);
16172 if ( ! mp_more_name(mp, xord((int)(*p)))) break;
16179 @ The global variable |job_name| contains the file name that was first
16180 \&{input} by the user. This name is extended by `\.{.log}' and `\.{ps}' and
16181 `\.{.mem}' and `\.{.tfm}' in order to make the names of \MP's output files.
16184 boolean log_opened; /* has the transcript file been opened? */
16185 char *log_name; /* full name of the log file */
16187 @ @<Option variables@>=
16188 char *job_name; /* principal file name */
16190 @ Initially |job_name=NULL|; it becomes nonzero as soon as the true name is known.
16191 We have |job_name=NULL| if and only if the `\.{log}' file has not been opened,
16192 except of course for a short time just after |job_name| has become nonzero.
16194 @<Allocate or ...@>=
16195 mp->job_name=mp_xstrdup(mp, opt->job_name);
16196 if (opt->noninteractive && opt->ini_version) {
16197 if (mp->job_name == NULL)
16198 mp->job_name=mp_xstrdup(mp,mp->mem_name);
16199 if (mp->job_name != NULL) {
16200 size_t l = strlen(mp->job_name);
16202 char *test = strstr(mp->job_name,".mem");
16203 if (test == mp->job_name+l-4)
16208 mp->log_opened=false;
16210 @ @<Dealloc variables@>=
16211 xfree(mp->job_name);
16213 @ Here is a routine that manufactures the output file names, assuming that
16214 |job_name<>0|. It ignores and changes the current settings of |cur_area|
16217 @d pack_cur_name mp_pack_file_name(mp, mp->cur_name,mp->cur_area,mp->cur_ext)
16220 static void mp_pack_job_name (MP mp, const char *s) ;
16223 void mp_pack_job_name (MP mp, const char *s) { /* |s = ".log"|, |".mem"|, |".ps"|, or .\\{nnn} */
16224 xfree(mp->cur_name); mp->cur_name=xstrdup(mp->job_name);
16225 xfree(mp->cur_area); mp->cur_area=xstrdup("");
16226 xfree(mp->cur_ext); mp->cur_ext=xstrdup(s);
16230 @ If some trouble arises when \MP\ tries to open a file, the following
16231 routine calls upon the user to supply another file name. Parameter~|s|
16232 is used in the error message to identify the type of file; parameter~|e|
16233 is the default extension if none is given. Upon exit from the routine,
16234 variables |cur_name|, |cur_area|, |cur_ext|, and |name_of_file| are
16235 ready for another attempt at file opening.
16238 static void mp_prompt_file_name (MP mp, const char * s, const char * e) ;
16240 @ @c void mp_prompt_file_name (MP mp, const char * s, const char * e) {
16241 size_t k; /* index into |buffer| */
16242 char * saved_cur_name;
16243 if ( mp->interaction==mp_scroll_mode )
16245 if (strcmp(s,"input file name")==0) {
16246 print_err("I can\'t find file `");
16247 @.I can't find file x@>
16249 print_err("I can\'t write on file `");
16250 @.I can't write on file x@>
16252 mp_print_file_name(mp, mp->cur_name,mp->cur_area,mp->cur_ext);
16253 mp_print(mp, "'.");
16254 if (strcmp(e,"")==0)
16255 mp_show_context(mp);
16256 mp_print_nl(mp, "Please type another "); mp_print(mp, s);
16258 if (mp->noninteractive || mp->interaction<mp_scroll_mode )
16259 mp_fatal_error(mp, "*** (job aborted, file error in nonstop mode)");
16260 @.job aborted, file error...@>
16261 saved_cur_name = xstrdup(mp->cur_name);
16262 clear_terminal; prompt_input(": "); @<Scan file name in the buffer@>;
16263 if (strcmp(mp->cur_ext,"")==0)
16264 mp->cur_ext=xstrdup(e);
16265 if (strlen(mp->cur_name)==0) {
16266 mp->cur_name=saved_cur_name;
16268 xfree(saved_cur_name);
16273 @ @<Scan file name in the buffer@>=
16275 mp_begin_name(mp); k=mp->first;
16276 while ( (mp->buffer[k]==' ')&&(k<mp->last) ) incr(k);
16278 if ( k==mp->last ) break;
16279 if ( ! mp_more_name(mp, mp->buffer[k]) ) break;
16285 @ The |open_log_file| routine is used to open the transcript file and to help
16286 it catch up to what has previously been printed on the terminal.
16288 @c void mp_open_log_file (MP mp) {
16289 unsigned old_setting; /* previous |selector| setting */
16290 int k; /* index into |months| and |buffer| */
16291 int l; /* end of first input line */
16292 integer m; /* the current month */
16293 const char *months="JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC";
16294 /* abbreviations of month names */
16295 old_setting=mp->selector;
16296 if ( mp->job_name==NULL ) {
16297 mp->job_name=xstrdup("mpout");
16299 mp_pack_job_name(mp,".log");
16300 while ( ! mp_a_open_out(mp, &mp->log_file, mp_filetype_log) ) {
16301 @<Try to get a different log file name@>;
16303 mp->log_name=xstrdup(mp->name_of_file);
16304 mp->selector=log_only; mp->log_opened=true;
16305 @<Print the banner line, including the date and time@>;
16306 mp->input_stack[mp->input_ptr]=mp->cur_input;
16307 /* make sure bottom level is in memory */
16308 if (!mp->noninteractive) {
16309 mp_print_nl(mp, "**");
16311 l=mp->input_stack[0].limit_field-1; /* last position of first line */
16312 for (k=0;k<=l;k++) mp_print_str(mp, mp->buffer[k]);
16313 mp_print_ln(mp); /* now the transcript file contains the first line of input */
16315 mp->selector=old_setting+2; /* |log_only| or |term_and_log| */
16318 @ @<Dealloc variables@>=
16319 xfree(mp->log_name);
16321 @ Sometimes |open_log_file| is called at awkward moments when \MP\ is
16322 unable to print error messages or even to |show_context|.
16323 The |prompt_file_name| routine can result in a |fatal_error|, but the |error|
16324 routine will not be invoked because |log_opened| will be false.
16326 The normal idea of |mp_batch_mode| is that nothing at all should be written
16327 on the terminal. However, in the unusual case that
16328 no log file could be opened, we make an exception and allow
16329 an explanatory message to be seen.
16331 Incidentally, the program always refers to the log file as a `\.{transcript
16332 file}', because some systems cannot use the extension `\.{.log}' for
16335 @<Try to get a different log file name@>=
16337 mp->selector=term_only;
16338 mp_prompt_file_name(mp, "transcript file name",".log");
16341 @ @<Print the banner...@>=
16344 mp_print(mp, mp->mem_ident); mp_print(mp, " ");
16345 mp_print_int(mp, mp_round_unscaled(mp, mp->internal[mp_day]));
16346 mp_print_char(mp, xord(' '));
16347 m=mp_round_unscaled(mp, mp->internal[mp_month]);
16348 for (k=3*m-3;k<3*m;k++) { wlog_chr((unsigned char)months[k]); }
16349 mp_print_char(mp, xord(' '));
16350 mp_print_int(mp, mp_round_unscaled(mp, mp->internal[mp_year]));
16351 mp_print_char(mp, xord(' '));
16352 m=mp_round_unscaled(mp, mp->internal[mp_time]);
16353 mp_print_dd(mp, m / 60); mp_print_char(mp, xord(':')); mp_print_dd(mp, m % 60);
16356 @ The |try_extension| function tries to open an input file determined by
16357 |cur_name|, |cur_area|, and the argument |ext|. It returns |false| if it
16358 can't find the file in |cur_area| or the appropriate system area.
16361 static boolean mp_try_extension (MP mp, const char *ext) {
16362 mp_pack_file_name(mp, mp->cur_name,mp->cur_area, ext);
16363 in_name=xstrdup(mp->cur_name);
16364 in_area=xstrdup(mp->cur_area);
16365 if ( mp_a_open_in(mp, &cur_file, mp_filetype_program) ) {
16368 mp_pack_file_name(mp, mp->cur_name,NULL,ext);
16369 return mp_a_open_in(mp, &cur_file, mp_filetype_program);
16373 @ Let's turn now to the procedure that is used to initiate file reading
16374 when an `\.{input}' command is being processed.
16376 @c void mp_start_input (MP mp) { /* \MP\ will \.{input} something */
16377 char *fname = NULL;
16378 @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>;
16380 mp_begin_file_reading(mp); /* set up |cur_file| and new level of input */
16381 if ( strlen(mp->cur_ext)==0 ) {
16382 if ( mp_try_extension(mp, ".mp") ) break;
16383 else if ( mp_try_extension(mp, "") ) break;
16384 else if ( mp_try_extension(mp, ".mf") ) break;
16385 /* |else do_nothing; | */
16386 } else if ( mp_try_extension(mp, mp->cur_ext) ) {
16389 mp_end_file_reading(mp); /* remove the level that didn't work */
16390 mp_prompt_file_name(mp, "input file name","");
16392 name=mp_a_make_name_string(mp, cur_file);
16393 fname = xstrdup(mp->name_of_file);
16394 if ( mp->job_name==NULL ) {
16395 mp->job_name=xstrdup(mp->cur_name);
16396 mp_open_log_file(mp);
16397 } /* |open_log_file| doesn't |show_context|, so |limit|
16398 and |loc| needn't be set to meaningful values yet */
16399 if ( ((int)mp->term_offset+(int)strlen(fname)) > (mp->max_print_line-2)) mp_print_ln(mp);
16400 else if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_char(mp, xord(' '));
16401 mp_print_char(mp, xord('(')); incr(mp->open_parens); mp_print(mp, fname);
16404 @<Flush |name| and replace it with |cur_name| if it won't be needed@>;
16405 @<Read the first line of the new file@>;
16408 @ This code should be omitted if |a_make_name_string| returns something other
16409 than just a copy of its argument and the full file name is needed for opening
16410 \.{MPX} files or implementing the switch-to-editor option.
16411 @^system dependencies@>
16413 @<Flush |name| and replace it with |cur_name| if it won't be needed@>=
16414 mp_flush_string(mp, name); name=rts(mp->cur_name); xfree(mp->cur_name)
16416 @ If the file is empty, it is considered to contain a single blank line,
16417 so there is no need to test the return value.
16419 @<Read the first line...@>=
16422 (void)mp_input_ln(mp, cur_file );
16423 mp_firm_up_the_line(mp);
16424 mp->buffer[limit]=xord('%'); mp->first=(size_t)(limit+1); loc=start;
16427 @ @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>=
16428 while ( token_state &&(loc==null) ) mp_end_token_list(mp);
16429 if ( token_state ) {
16430 print_err("File names can't appear within macros");
16431 @.File names can't...@>
16432 help3("Sorry...I've converted what follows to tokens,",
16433 "possibly garbaging the name you gave.",
16434 "Please delete the tokens and insert the name again.");
16437 if ( file_state ) {
16438 mp_scan_file_name(mp);
16440 xfree(mp->cur_name); mp->cur_name=xstrdup("");
16441 xfree(mp->cur_ext); mp->cur_ext =xstrdup("");
16442 xfree(mp->cur_area); mp->cur_area=xstrdup("");
16445 @ The following simple routine starts reading the \.{MPX} file associated
16446 with the current input file.
16448 @c void mp_start_mpx_input (MP mp) {
16449 char *origname = NULL; /* a copy of nameoffile */
16450 mp_pack_file_name(mp, in_name, in_area, ".mpx");
16451 @<Try to make sure |name_of_file| refers to a valid \.{MPX} file and
16452 |goto not_found| if there is a problem@>;
16453 mp_begin_file_reading(mp);
16454 if ( ! mp_a_open_in(mp, &cur_file, mp_filetype_program) ) {
16455 mp_end_file_reading(mp);
16458 name=mp_a_make_name_string(mp, cur_file);
16459 mp->mpx_name[iindex]=name; add_str_ref(name);
16460 @<Read the first line of the new file@>;
16464 @<Explain that the \.{MPX} file can't be read and |succumb|@>;
16468 @ This should ideally be changed to do whatever is necessary to create the
16469 \.{MPX} file given by |name_of_file| if it does not exist or if it is out
16470 of date. This requires invoking \.{MPtoTeX} on the |origname| and passing
16471 the results through \TeX\ and \.{DVItoMP}. (It is possible to use a
16472 completely different typesetting program if suitable postprocessor is
16473 available to perform the function of \.{DVItoMP}.)
16474 @^system dependencies@>
16476 @ @<Exported types@>=
16477 typedef int (*mp_run_make_mpx_command)(MP mp, char *origname, char *mtxname);
16479 @ @<Option variables@>=
16480 mp_run_make_mpx_command run_make_mpx;
16482 @ @<Allocate or initialize ...@>=
16483 set_callback_option(run_make_mpx);
16485 @ @<Declarations@>=
16486 static int mp_run_make_mpx (MP mp, char *origname, char *mtxname);
16488 @ The default does nothing.
16490 int mp_run_make_mpx (MP mp, char *origname, char *mtxname) {
16497 @ @<Try to make sure |name_of_file| refers to a valid \.{MPX} file and
16498 |goto not_found| if there is a problem@>=
16499 origname = mp_xstrdup(mp,mp->name_of_file);
16500 *(origname+strlen(origname)-1)=0; /* drop the x */
16501 if (!(mp->run_make_mpx)(mp, origname, mp->name_of_file))
16504 @ @<Explain that the \.{MPX} file can't be read and |succumb|@>=
16505 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
16506 mp_print_nl(mp, ">> ");
16507 mp_print(mp, origname);
16508 mp_print_nl(mp, ">> ");
16509 mp_print(mp, mp->name_of_file);
16510 mp_print_nl(mp, "! Unable to make mpx file");
16511 help4("The two files given above are one of your source files",
16512 "and an auxiliary file I need to read to find out what your",
16513 "btex..etex blocks mean. If you don't know why I had trouble,",
16514 "try running it manually through MPtoTeX, TeX, and DVItoMP");
16517 @ The last file-opening commands are for files accessed via the \&{readfrom}
16518 @:read_from_}{\&{readfrom} primitive@>
16519 operator and the \&{write} command. Such files are stored in separate arrays.
16520 @:write_}{\&{write} primitive@>
16522 @<Types in the outer block@>=
16523 typedef unsigned int readf_index; /* |0..max_read_files| */
16524 typedef unsigned int write_index; /* |0..max_write_files| */
16527 readf_index max_read_files; /* maximum number of simultaneously open \&{readfrom} files */
16528 void ** rd_file; /* \&{readfrom} files */
16529 char ** rd_fname; /* corresponding file name or 0 if file not open */
16530 readf_index read_files; /* number of valid entries in the above arrays */
16531 write_index max_write_files; /* maximum number of simultaneously open \&{write} */
16532 void ** wr_file; /* \&{write} files */
16533 char ** wr_fname; /* corresponding file name or 0 if file not open */
16534 write_index write_files; /* number of valid entries in the above arrays */
16536 @ @<Allocate or initialize ...@>=
16537 mp->max_read_files=8;
16538 mp->rd_file = xmalloc((mp->max_read_files+1),sizeof(void *));
16539 mp->rd_fname = xmalloc((mp->max_read_files+1),sizeof(char *));
16540 memset(mp->rd_fname, 0, sizeof(char *)*(mp->max_read_files+1));
16541 mp->max_write_files=8;
16542 mp->wr_file = xmalloc((mp->max_write_files+1),sizeof(void *));
16543 mp->wr_fname = xmalloc((mp->max_write_files+1),sizeof(char *));
16544 memset(mp->wr_fname, 0, sizeof(char *)*(mp->max_write_files+1));
16547 @ This routine starts reading the file named by string~|s| without setting
16548 |loc|, |limit|, or |name|. It returns |false| if the file is empty or cannot
16549 be opened. Otherwise it updates |rd_file[n]| and |rd_fname[n]|.
16552 static boolean mp_start_read_input (MP mp,char *s, readf_index n) {
16553 mp_ptr_scan_file(mp, s);
16555 mp_begin_file_reading(mp);
16556 if ( ! mp_a_open_in(mp, &mp->rd_file[n], (int)(mp_filetype_text+n)) )
16558 if ( ! mp_input_ln(mp, mp->rd_file[n] ) ) {
16559 (mp->close_file)(mp,mp->rd_file[n]);
16562 mp->rd_fname[n]=xstrdup(s);
16565 mp_end_file_reading(mp);
16569 @ Open |wr_file[n]| using file name~|s| and update |wr_fname[n]|.
16572 static void mp_open_write_file (MP mp, char *s, readf_index n) ;
16574 @ @c void mp_open_write_file (MP mp,char *s, readf_index n) {
16575 mp_ptr_scan_file(mp, s);
16577 while ( ! mp_a_open_out(mp, &mp->wr_file[n], (int)(mp_filetype_text+n)) )
16578 mp_prompt_file_name(mp, "file name for write output","");
16579 mp->wr_fname[n]=xstrdup(s);
16583 @* \[36] Introduction to the parsing routines.
16584 We come now to the central nervous system that sparks many of \MP's activities.
16585 By evaluating expressions, from their primary constituents to ever larger
16586 subexpressions, \MP\ builds the structures that ultimately define complete
16587 pictures or fonts of type.
16589 Four mutually recursive subroutines are involved in this process: We call them
16590 $$\hbox{|scan_primary|, |scan_secondary|, |scan_tertiary|,
16591 and |scan_expression|.}$$
16593 Each of them is parameterless and begins with the first token to be scanned
16594 already represented in |cur_cmd|, |cur_mod|, and |cur_sym|. After execution,
16595 the value of the primary or secondary or tertiary or expression that was
16596 found will appear in the global variables |cur_type| and |cur_exp|. The
16597 token following the expression will be represented in |cur_cmd|, |cur_mod|,
16600 Technically speaking, the parsing algorithms are ``LL(1),'' more or less;
16601 backup mechanisms have been added in order to provide reasonable error
16605 quarterword cur_type; /* the type of the expression just found */
16606 integer cur_exp; /* the value of the expression just found */
16611 @ Many different kinds of expressions are possible, so it is wise to have
16612 precise descriptions of what |cur_type| and |cur_exp| mean in all cases:
16615 |cur_type=mp_vacuous| means that this expression didn't turn out to have a
16616 value at all, because it arose from a \&{begingroup}$\,\ldots\,$\&{endgroup}
16617 construction in which there was no expression before the \&{endgroup}.
16618 In this case |cur_exp| has some irrelevant value.
16621 |cur_type=mp_boolean_type| means that |cur_exp| is either |true_code|
16625 |cur_type=mp_unknown_boolean| means that |cur_exp| points to a capsule
16627 a ring of equivalent booleans whose value has not yet been defined.
16630 |cur_type=mp_string_type| means that |cur_exp| is a string number (i.e., an
16631 integer in the range |0<=cur_exp<str_ptr|). That string's reference count
16632 includes this particular reference.
16635 |cur_type=mp_unknown_string| means that |cur_exp| points to a capsule
16637 a ring of equivalent strings whose value has not yet been defined.
16640 |cur_type=mp_pen_type| means that |cur_exp| points to a node in a pen. Nobody
16641 else points to any of the nodes in this pen. The pen may be polygonal or
16645 |cur_type=mp_unknown_pen| means that |cur_exp| points to a capsule
16647 a ring of equivalent pens whose value has not yet been defined.
16650 |cur_type=mp_path_type| means that |cur_exp| points to a the first node of
16651 a path; nobody else points to this particular path. The control points of
16652 the path will have been chosen.
16655 |cur_type=mp_unknown_path| means that |cur_exp| points to a capsule
16657 a ring of equivalent paths whose value has not yet been defined.
16660 |cur_type=mp_picture_type| means that |cur_exp| points to an edge header node.
16661 There may be other pointers to this particular set of edges. The header node
16662 contains a reference count that includes this particular reference.
16665 |cur_type=mp_unknown_picture| means that |cur_exp| points to a capsule
16667 a ring of equivalent pictures whose value has not yet been defined.
16670 |cur_type=mp_transform_type| means that |cur_exp| points to a |mp_transform_type|
16671 capsule node. The |value| part of this capsule
16672 points to a transform node that contains six numeric values,
16673 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16676 |cur_type=mp_color_type| means that |cur_exp| points to a |color_type|
16677 capsule node. The |value| part of this capsule
16678 points to a color node that contains three numeric values,
16679 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16682 |cur_type=mp_cmykcolor_type| means that |cur_exp| points to a |mp_cmykcolor_type|
16683 capsule node. The |value| part of this capsule
16684 points to a color node that contains four numeric values,
16685 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16688 |cur_type=mp_pair_type| means that |cur_exp| points to a capsule
16689 node whose type is |mp_pair_type|. The |value| part of this capsule
16690 points to a pair node that contains two numeric values,
16691 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16694 |cur_type=mp_known| means that |cur_exp| is a |scaled| value.
16697 |cur_type=mp_dependent| means that |cur_exp| points to a capsule node whose type
16698 is |dependent|. The |dep_list| field in this capsule points to the associated
16702 |cur_type=mp_proto_dependent| means that |cur_exp| points to a |mp_proto_dependent|
16703 capsule node. The |dep_list| field in this capsule
16704 points to the associated dependency list.
16707 |cur_type=independent| means that |cur_exp| points to a capsule node
16708 whose type is |independent|. This somewhat unusual case can arise, for
16709 example, in the expression
16710 `$x+\&{begingroup}\penalty0\,\&{string}\,x; 0\,\&{endgroup}$'.
16713 |cur_type=mp_token_list| means that |cur_exp| points to a linked list of
16716 \smallskip\noindent
16717 The possible settings of |cur_type| have been listed here in increasing
16718 numerical order. Notice that |cur_type| will never be |mp_numeric_type| or
16719 |suffixed_macro| or |mp_unsuffixed_macro|, although variables of those types
16720 are allowed. Conversely, \MP\ has no variables of type |mp_vacuous| or
16723 @ Capsules are two-word nodes that have a similar meaning
16724 to |cur_type| and |cur_exp|. Such nodes have |name_type=capsule|,
16725 and their |type| field is one of the possibilities for |cur_type| listed above.
16726 Also |link<=void| in capsules that aren't part of a token list.
16728 The |value| field of a capsule is, in most cases, the value that
16729 corresponds to its |type|, as |cur_exp| corresponds to |cur_type|.
16730 However, when |cur_exp| would point to a capsule,
16731 no extra layer of indirection is present; the |value|
16732 field is what would have been called |value(cur_exp)| if it had not been
16733 encapsulated. Furthermore, if the type is |dependent| or
16734 |mp_proto_dependent|, the |value| field of a capsule is replaced by
16735 |dep_list| and |prev_dep| fields, since dependency lists in capsules are
16736 always part of the general |dep_list| structure.
16738 The |get_x_next| routine is careful not to change the values of |cur_type|
16739 and |cur_exp| when it gets an expanded token. However, |get_x_next| might
16740 call a macro, which might parse an expression, which might execute lots of
16741 commands in a group; hence it's possible that |cur_type| might change
16742 from, say, |mp_unknown_boolean| to |mp_boolean_type|, or from |dependent| to
16743 |known| or |independent|, during the time |get_x_next| is called. The
16744 programs below are careful to stash sensitive intermediate results in
16745 capsules, so that \MP's generality doesn't cause trouble.
16747 Here's a procedure that illustrates these conventions. It takes
16748 the contents of $(|cur_type|\kern-.3pt,|cur_exp|\kern-.3pt)$
16749 and stashes them away in a
16750 capsule. It is not used when |cur_type=mp_token_list|.
16751 After the operation, |cur_type=mp_vacuous|; hence there is no need to
16752 copy path lists or to update reference counts, etc.
16754 The special link |mp_void| is put on the capsule returned by
16755 |stash_cur_exp|, because this procedure is used to store macro parameters
16756 that must be easily distinguishable from token lists.
16758 @<Declare the stashing/unstashing routines@>=
16759 static pointer mp_stash_cur_exp (MP mp) {
16760 pointer p; /* the capsule that will be returned */
16761 switch (mp->cur_type) {
16762 case unknown_types:
16763 case mp_transform_type:
16764 case mp_color_type:
16767 case mp_proto_dependent:
16768 case mp_independent:
16769 case mp_cmykcolor_type:
16773 p=mp_get_node(mp, value_node_size); name_type(p)=mp_capsule;
16774 type(p)=mp->cur_type; value(p)=mp->cur_exp;
16777 mp->cur_type=mp_vacuous; mp_link(p)=mp_void;
16781 @ The inverse of |stash_cur_exp| is the following procedure, which
16782 deletes an unnecessary capsule and puts its contents into |cur_type|
16785 The program steps of \MP\ can be divided into two categories: those in
16786 which |cur_type| and |cur_exp| are ``alive'' and those in which they are
16787 ``dead,'' in the sense that |cur_type| and |cur_exp| contain relevant
16788 information or not. It's important not to ignore them when they're alive,
16789 and it's important not to pay attention to them when they're dead.
16791 There's also an intermediate category: If |cur_type=mp_vacuous|, then
16792 |cur_exp| is irrelevant, hence we can proceed without caring if |cur_type|
16793 and |cur_exp| are alive or dead. In such cases we say that |cur_type|
16794 and |cur_exp| are {\sl dormant}. It is permissible to call |get_x_next|
16795 only when they are alive or dormant.
16797 The \\{stash} procedure above assumes that |cur_type| and |cur_exp|
16798 are alive or dormant. The \\{unstash} procedure assumes that they are
16799 dead or dormant; it resuscitates them.
16801 @<Declare the stashing/unstashing...@>=
16802 static void mp_unstash_cur_exp (MP mp,pointer p) ;
16805 void mp_unstash_cur_exp (MP mp,pointer p) {
16806 mp->cur_type=type(p);
16807 switch (mp->cur_type) {
16808 case unknown_types:
16809 case mp_transform_type:
16810 case mp_color_type:
16813 case mp_proto_dependent:
16814 case mp_independent:
16815 case mp_cmykcolor_type:
16819 mp->cur_exp=value(p);
16820 mp_free_node(mp, p,value_node_size);
16825 @ The following procedure prints the values of expressions in an
16826 abbreviated format. If its first parameter |p| is null, the value of
16827 |(cur_type,cur_exp)| is displayed; otherwise |p| should be a capsule
16828 containing the desired value. The second parameter controls the amount of
16829 output. If it is~0, dependency lists will be abbreviated to
16830 `\.{linearform}' unless they consist of a single term. If it is greater
16831 than~1, complicated structures (pens, pictures, and paths) will be displayed
16836 @<Declare the procedure called |print_dp|@>
16837 @<Declare the stashing/unstashing routines@>
16838 static void mp_print_exp (MP mp,pointer p, quarterword verbosity) ;
16841 void mp_print_exp (MP mp,pointer p, quarterword verbosity) {
16842 boolean restore_cur_exp; /* should |cur_exp| be restored? */
16843 quarterword t; /* the type of the expression */
16844 pointer q; /* a big node being displayed */
16845 integer v=0; /* the value of the expression */
16847 restore_cur_exp=false;
16849 p=mp_stash_cur_exp(mp); restore_cur_exp=true;
16852 if ( t<mp_dependent ) v=value(p); else if ( t<mp_independent ) v=dep_list(p);
16853 @<Print an abbreviated value of |v| with format depending on |t|@>;
16854 if ( restore_cur_exp ) mp_unstash_cur_exp(mp, p);
16857 @ @<Print an abbreviated value of |v| with format depending on |t|@>=
16859 case mp_vacuous:mp_print(mp, "mp_vacuous"); break;
16860 case mp_boolean_type:
16861 if ( v==true_code ) mp_print(mp, "true"); else mp_print(mp, "false");
16863 case unknown_types: case mp_numeric_type:
16864 @<Display a variable that's been declared but not defined@>;
16866 case mp_string_type:
16867 mp_print_char(mp, xord('"')); mp_print_str(mp, v); mp_print_char(mp, xord('"'));
16869 case mp_pen_type: case mp_path_type: case mp_picture_type:
16870 @<Display a complex type@>;
16872 case mp_transform_type: case mp_color_type: case mp_pair_type: case mp_cmykcolor_type:
16873 if ( v==null ) mp_print_type(mp, t);
16874 else @<Display a big node@>;
16876 case mp_known:mp_print_scaled(mp, v); break;
16877 case mp_dependent: case mp_proto_dependent:
16878 mp_print_dp(mp, t,v,verbosity);
16880 case mp_independent:mp_print_variable_name(mp, p); break;
16881 default: mp_confusion(mp, "exp"); break;
16882 @:this can't happen exp}{\quad exp@>
16885 @ @<Display a big node@>=
16887 mp_print_char(mp, xord('(')); q=v+mp->big_node_size[t];
16889 if ( type(v)==mp_known ) mp_print_scaled(mp, value(v));
16890 else if ( type(v)==mp_independent ) mp_print_variable_name(mp, v);
16891 else mp_print_dp(mp, type(v),dep_list(v),verbosity);
16893 if ( v!=q ) mp_print_char(mp, xord(','));
16895 mp_print_char(mp, xord(')'));
16898 @ Values of type \&{picture}, \&{path}, and \&{pen} are displayed verbosely
16899 in the log file only, unless the user has given a positive value to
16902 @<Display a complex type@>=
16903 if ( verbosity<=1 ) {
16904 mp_print_type(mp, t);
16906 if ( mp->selector==term_and_log )
16907 if ( mp->internal[mp_tracing_online]<=0 ) {
16908 mp->selector=term_only;
16909 mp_print_type(mp, t); mp_print(mp, " (see the transcript file)");
16910 mp->selector=term_and_log;
16913 case mp_pen_type:mp_print_pen(mp, v,"",false); break;
16914 case mp_path_type:mp_print_path(mp, v,"",false); break;
16915 case mp_picture_type:mp_print_edges(mp, v,"",false); break;
16916 } /* there are no other cases */
16919 @ @<Declare the procedure called |print_dp|@>=
16920 static void mp_print_dp (MP mp, quarterword t, pointer p,
16921 quarterword verbosity) {
16922 pointer q; /* the node following |p| */
16924 if ( (info(q)==null) || (verbosity>0) ) mp_print_dependency(mp, p,t);
16925 else mp_print(mp, "linearform");
16928 @ The displayed name of a variable in a ring will not be a capsule unless
16929 the ring consists entirely of capsules.
16931 @<Display a variable that's been declared but not defined@>=
16932 { mp_print_type(mp, t);
16934 { mp_print_char(mp, xord(' '));
16935 while ( (name_type(v)==mp_capsule) && (v!=p) ) v=value(v);
16936 mp_print_variable_name(mp, v);
16940 @ When errors are detected during parsing, it is often helpful to
16941 display an expression just above the error message, using |exp_err|
16942 or |disp_err| instead of |print_err|.
16944 @d exp_err(A) mp_disp_err(mp, null,(A)) /* displays the current expression */
16947 static void mp_disp_err (MP mp,pointer p, const char *s) ;
16950 void mp_disp_err (MP mp,pointer p, const char *s) {
16951 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
16952 mp_print_nl(mp, ">> ");
16954 mp_print_exp(mp, p,1); /* ``medium verbose'' printing of the expression */
16956 mp_print_nl(mp, "! "); mp_print(mp, s);
16961 @ If |cur_type| and |cur_exp| contain relevant information that should
16962 be recycled, we will use the following procedure, which changes |cur_type|
16963 to |known| and stores a given value in |cur_exp|. We can think of |cur_type|
16964 and |cur_exp| as either alive or dormant after this has been done,
16965 because |cur_exp| will not contain a pointer value.
16968 static void mp_flush_cur_exp (MP mp,scaled v) {
16969 switch (mp->cur_type) {
16970 case unknown_types: case mp_transform_type: case mp_color_type: case mp_pair_type:
16971 case mp_dependent: case mp_proto_dependent: case mp_independent: case mp_cmykcolor_type:
16972 mp_recycle_value(mp, mp->cur_exp);
16973 mp_free_node(mp, mp->cur_exp,value_node_size);
16975 case mp_string_type:
16976 delete_str_ref(mp->cur_exp); break;
16977 case mp_pen_type: case mp_path_type:
16978 mp_toss_knot_list(mp, mp->cur_exp); break;
16979 case mp_picture_type:
16980 delete_edge_ref(mp->cur_exp); break;
16984 mp->cur_type=mp_known; mp->cur_exp=v;
16987 @ There's a much more general procedure that is capable of releasing
16988 the storage associated with any two-word value packet.
16991 static void mp_recycle_value (MP mp,pointer p) ;
16994 static void mp_recycle_value (MP mp,pointer p) {
16995 quarterword t; /* a type code */
16996 integer vv; /* another value */
16997 pointer q,r,s,pp; /* link manipulation registers */
16998 integer v=0; /* a value */
17000 if ( t<mp_dependent ) v=value(p);
17002 case undefined: case mp_vacuous: case mp_boolean_type: case mp_known:
17003 case mp_numeric_type:
17005 case unknown_types:
17006 mp_ring_delete(mp, p); break;
17007 case mp_string_type:
17008 delete_str_ref(v); break;
17009 case mp_path_type: case mp_pen_type:
17010 mp_toss_knot_list(mp, v); break;
17011 case mp_picture_type:
17012 delete_edge_ref(v); break;
17013 case mp_cmykcolor_type: case mp_pair_type: case mp_color_type:
17014 case mp_transform_type:
17015 @<Recycle a big node@>; break;
17016 case mp_dependent: case mp_proto_dependent:
17017 @<Recycle a dependency list@>; break;
17018 case mp_independent:
17019 @<Recycle an independent variable@>; break;
17020 case mp_token_list: case mp_structured:
17021 mp_confusion(mp, "recycle"); break;
17022 @:this can't happen recycle}{\quad recycle@>
17023 case mp_unsuffixed_macro: case mp_suffixed_macro:
17024 mp_delete_mac_ref(mp, value(p)); break;
17025 } /* there are no other cases */
17029 @ @<Recycle a big node@>=
17031 q=v+mp->big_node_size[t];
17033 q=q-2; mp_recycle_value(mp, q);
17035 mp_free_node(mp, v,mp->big_node_size[t]);
17038 @ @<Recycle a dependency list@>=
17041 while ( info(q)!=null ) q=mp_link(q);
17042 mp_link(prev_dep(p))=mp_link(q);
17043 prev_dep(mp_link(q))=prev_dep(p);
17044 mp_link(q)=null; mp_flush_node_list(mp, dep_list(p));
17047 @ When an independent variable disappears, it simply fades away, unless
17048 something depends on it. In the latter case, a dependent variable whose
17049 coefficient of dependence is maximal will take its place.
17050 The relevant algorithm is due to Ignacio~A. Zabala, who implemented it
17051 as part of his Ph.D. thesis (Stanford University, December 1982).
17052 @^Zabala Salelles, Ignacio Andr\'es@>
17054 For example, suppose that variable $x$ is being recycled, and that the
17055 only variables depending on~$x$ are $y=2x+a$ and $z=x+b$. In this case
17056 we want to make $y$ independent and $z=.5y-.5a+b$; no other variables
17057 will depend on~$y$. If $\\{tracingequations}>0$ in this situation,
17058 we will print `\.{\#\#\# -2x=-y+a}'.
17060 There's a slight complication, however: An independent variable $x$
17061 can occur both in dependency lists and in proto-dependency lists.
17062 This makes it necessary to be careful when deciding which coefficient
17065 Furthermore, this complication is not so slight when
17066 a proto-dependent variable is chosen to become independent. For example,
17067 suppose that $y=2x+100a$ is proto-dependent while $z=x+b$ is dependent;
17068 then we must change $z=.5y-50a+b$ to a proto-dependency, because of the
17069 large coefficient `50'.
17071 In order to deal with these complications without wasting too much time,
17072 we shall link together the occurrences of~$x$ among all the linear
17073 dependencies, maintaining separate lists for the dependent and
17074 proto-dependent cases.
17076 @<Recycle an independent variable@>=
17078 mp->max_c[mp_dependent]=0; mp->max_c[mp_proto_dependent]=0;
17079 mp->max_link[mp_dependent]=null; mp->max_link[mp_proto_dependent]=null;
17080 q=mp_link(dep_head);
17081 while ( q!=dep_head ) {
17082 s=value_loc(q); /* now |mp_link(s)=dep_list(q)| */
17085 if ( info(r)==null ) break;
17086 if ( info(r)!=p ) {
17089 t=type(q); mp_link(s)=mp_link(r); info(r)=q;
17090 if ( abs(value(r))>mp->max_c[t] ) {
17091 @<Record a new maximum coefficient of type |t|@>;
17093 mp_link(r)=mp->max_link[t]; mp->max_link[t]=r;
17099 if ( (mp->max_c[mp_dependent]>0)||(mp->max_c[mp_proto_dependent]>0) ) {
17100 @<Choose a dependent variable to take the place of the disappearing
17101 independent variable, and change all remaining dependencies
17106 @ The code for independency removal makes use of three two-word arrays.
17109 integer max_c[mp_proto_dependent+1]; /* max coefficient magnitude */
17110 pointer max_ptr[mp_proto_dependent+1]; /* where |p| occurs with |max_c| */
17111 pointer max_link[mp_proto_dependent+1]; /* other occurrences of |p| */
17113 @ @<Record a new maximum coefficient...@>=
17115 if ( mp->max_c[t]>0 ) {
17116 mp_link(mp->max_ptr[t])=mp->max_link[t]; mp->max_link[t]=mp->max_ptr[t];
17118 mp->max_c[t]=abs(value(r)); mp->max_ptr[t]=r;
17121 @ @<Choose a dependent...@>=
17123 if ( (mp->max_c[mp_dependent] / 010000) >= mp->max_c[mp_proto_dependent] )
17126 t=mp_proto_dependent;
17127 @<Determine the dependency list |s| to substitute for the independent
17129 t=mp_dependent+mp_proto_dependent-t; /* complement |t| */
17130 if ( mp->max_c[t]>0 ) { /* we need to pick up an unchosen dependency */
17131 mp_link(mp->max_ptr[t])=mp->max_link[t]; mp->max_link[t]=mp->max_ptr[t];
17133 if ( t!=mp_dependent ) { @<Substitute new dependencies in place of |p|@>; }
17134 else { @<Substitute new proto-dependencies in place of |p|@>;}
17135 mp_flush_node_list(mp, s);
17136 if ( mp->fix_needed ) mp_fix_dependencies(mp);
17140 @ Let |s=max_ptr[t]|. At this point we have $|value|(s)=\pm|max_c|[t]$,
17141 and |info(s)| points to the dependent variable~|pp| of type~|t| from
17142 whose dependency list we have removed node~|s|. We must reinsert
17143 node~|s| into the dependency list, with coefficient $-1.0$, and with
17144 |pp| as the new independent variable. Since |pp| will have a larger serial
17145 number than any other variable, we can put node |s| at the head of the
17148 @<Determine the dep...@>=
17149 s=mp->max_ptr[t]; pp=info(s); v=value(s);
17150 if ( t==mp_dependent ) value(s)=-fraction_one; else value(s)=-unity;
17151 r=dep_list(pp); mp_link(s)=r;
17152 while ( info(r)!=null ) r=mp_link(r);
17153 q=mp_link(r); mp_link(r)=null;
17154 prev_dep(q)=prev_dep(pp); mp_link(prev_dep(pp))=q;
17156 if ( mp->cur_exp==pp ) if ( mp->cur_type==t ) mp->cur_type=mp_independent;
17157 if ( mp->internal[mp_tracing_equations]>0 ) {
17158 @<Show the transformed dependency@>;
17161 @ Now $(-v)$ times the formerly independent variable~|p| is being replaced
17162 by the dependency list~|s|.
17164 @<Show the transformed...@>=
17165 if ( mp_interesting(mp, p) ) {
17166 mp_begin_diagnostic(mp); mp_print_nl(mp, "### ");
17167 @:]]]\#\#\#_}{\.{\#\#\#}@>
17168 if ( v>0 ) mp_print_char(mp, xord('-'));
17169 if ( t==mp_dependent ) vv=mp_round_fraction(mp, mp->max_c[mp_dependent]);
17170 else vv=mp->max_c[mp_proto_dependent];
17171 if ( vv!=unity ) mp_print_scaled(mp, vv);
17172 mp_print_variable_name(mp, p);
17173 while ( value(p) % s_scale>0 ) {
17174 mp_print(mp, "*4"); value(p)=value(p)-2;
17176 if ( t==mp_dependent ) mp_print_char(mp, xord('=')); else mp_print(mp, " = ");
17177 mp_print_dependency(mp, s,t);
17178 mp_end_diagnostic(mp, false);
17181 @ Finally, there are dependent and proto-dependent variables whose
17182 dependency lists must be brought up to date.
17184 @<Substitute new dependencies...@>=
17185 for (t=mp_dependent;t<=mp_proto_dependent;t++){
17187 while ( r!=null ) {
17189 dep_list(q)=mp_p_plus_fq(mp, dep_list(q),
17190 mp_make_fraction(mp, value(r),-v),s,t,mp_dependent);
17191 if ( dep_list(q)==mp->dep_final ) mp_make_known(mp, q,mp->dep_final);
17192 q=r; r=mp_link(r); mp_free_node(mp, q,dep_node_size);
17196 @ @<Substitute new proto...@>=
17197 for (t=mp_dependent;t<=mp_proto_dependent;t++) {
17199 while ( r!=null ) {
17201 if ( t==mp_dependent ) { /* for safety's sake, we change |q| to |mp_proto_dependent| */
17202 if ( mp->cur_exp==q ) if ( mp->cur_type==mp_dependent )
17203 mp->cur_type=mp_proto_dependent;
17204 dep_list(q)=mp_p_over_v(mp, dep_list(q),unity,
17205 mp_dependent,mp_proto_dependent);
17206 type(q)=mp_proto_dependent;
17207 value(r)=mp_round_fraction(mp, value(r));
17209 dep_list(q)=mp_p_plus_fq(mp, dep_list(q),
17210 mp_make_scaled(mp, value(r),-v),s,
17211 mp_proto_dependent,mp_proto_dependent);
17212 if ( dep_list(q)==mp->dep_final )
17213 mp_make_known(mp, q,mp->dep_final);
17214 q=r; r=mp_link(r); mp_free_node(mp, q,dep_node_size);
17218 @ Here are some routines that provide handy combinations of actions
17219 that are often needed during error recovery. For example,
17220 `|flush_error|' flushes the current expression, replaces it by
17221 a given value, and calls |error|.
17223 Errors often are detected after an extra token has already been scanned.
17224 The `\\{put\_get}' routines put that token back before calling |error|;
17225 then they get it back again. (Or perhaps they get another token, if
17226 the user has changed things.)
17229 static void mp_flush_error (MP mp,scaled v);
17230 static void mp_put_get_error (MP mp);
17231 static void mp_put_get_flush_error (MP mp,scaled v) ;
17234 void mp_flush_error (MP mp,scaled v) {
17235 mp_error(mp); mp_flush_cur_exp(mp, v);
17237 void mp_put_get_error (MP mp) {
17238 mp_back_error(mp); mp_get_x_next(mp);
17240 void mp_put_get_flush_error (MP mp,scaled v) {
17241 mp_put_get_error(mp);
17242 mp_flush_cur_exp(mp, v);
17245 @ A global variable |var_flag| is set to a special command code
17246 just before \MP\ calls |scan_expression|, if the expression should be
17247 treated as a variable when this command code immediately follows. For
17248 example, |var_flag| is set to |assignment| at the beginning of a
17249 statement, because we want to know the {\sl location\/} of a variable at
17250 the left of `\.{:=}', not the {\sl value\/} of that variable.
17252 The |scan_expression| subroutine calls |scan_tertiary|,
17253 which calls |scan_secondary|, which calls |scan_primary|, which sets
17254 |var_flag:=0|. In this way each of the scanning routines ``knows''
17255 when it has been called with a special |var_flag|, but |var_flag| is
17258 A variable preceding a command that equals |var_flag| is converted to a
17259 token list rather than a value. Furthermore, an `\.{=}' sign following an
17260 expression with |var_flag=assignment| is not considered to be a relation
17261 that produces boolean expressions.
17265 int var_flag; /* command that wants a variable */
17270 @* \[37] Parsing primary expressions.
17271 The first parsing routine, |scan_primary|, is also the most complicated one,
17272 since it involves so many different cases. But each case---with one
17273 exception---is fairly simple by itself.
17275 When |scan_primary| begins, the first token of the primary to be scanned
17276 should already appear in |cur_cmd|, |cur_mod|, and |cur_sym|. The values
17277 of |cur_type| and |cur_exp| should be either dead or dormant, as explained
17278 earlier. If |cur_cmd| is not between |min_primary_command| and
17279 |max_primary_command|, inclusive, a syntax error will be signaled.
17281 @<Declare the basic parsing subroutines@>=
17282 void mp_scan_primary (MP mp) {
17283 pointer p,q,r; /* for list manipulation */
17284 quarterword c; /* a primitive operation code */
17285 int my_var_flag; /* initial value of |my_var_flag| */
17286 pointer l_delim,r_delim; /* hash addresses of a delimiter pair */
17287 @<Other local variables for |scan_primary|@>;
17288 my_var_flag=mp->var_flag; mp->var_flag=0;
17291 @<Supply diagnostic information, if requested@>;
17292 switch (mp->cur_cmd) {
17293 case left_delimiter:
17294 @<Scan a delimited primary@>; break;
17296 @<Scan a grouped primary@>; break;
17298 @<Scan a string constant@>; break;
17299 case numeric_token:
17300 @<Scan a primary that starts with a numeric token@>; break;
17302 @<Scan a nullary operation@>; break;
17303 case unary: case type_name: case cycle: case plus_or_minus:
17304 @<Scan a unary operation@>; break;
17305 case primary_binary:
17306 @<Scan a binary operation with `\&{of}' between its operands@>; break;
17308 @<Convert a suffix to a string@>; break;
17309 case internal_quantity:
17310 @<Scan an internal numeric quantity@>; break;
17311 case capsule_token:
17312 mp_make_exp_copy(mp, mp->cur_mod); break;
17314 @<Scan a variable primary; |goto restart| if it turns out to be a macro@>; break;
17316 mp_bad_exp(mp, "A primary"); goto RESTART; break;
17317 @.A primary expression...@>
17319 mp_get_x_next(mp); /* the routines |goto done| if they don't want this */
17321 if ( mp->cur_cmd==left_bracket ) {
17322 if ( mp->cur_type>=mp_known ) {
17323 @<Scan a mediation construction@>;
17330 @ Errors at the beginning of expressions are flagged by |bad_exp|.
17333 static void mp_bad_exp (MP mp, const char * s) {
17335 print_err(s); mp_print(mp, " expression can't begin with `");
17336 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod);
17337 mp_print_char(mp, xord('\''));
17338 help4("I'm afraid I need some sort of value in order to continue,",
17339 "so I've tentatively inserted `0'. You may want to",
17340 "delete this zero and insert something else;",
17341 "see Chapter 27 of The METAFONTbook for an example.");
17342 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
17343 mp_back_input(mp); mp->cur_sym=0; mp->cur_cmd=numeric_token;
17344 mp->cur_mod=0; mp_ins_error(mp);
17345 save_flag=mp->var_flag; mp->var_flag=0; mp_get_x_next(mp);
17346 mp->var_flag=save_flag;
17349 @ @<Supply diagnostic information, if requested@>=
17351 if ( mp->panicking ) mp_check_mem(mp, false);
17353 if ( mp->interrupt!=0 ) if ( mp->OK_to_interrupt ) {
17354 mp_back_input(mp); check_interrupt; mp_get_x_next(mp);
17357 @ @<Scan a delimited primary@>=
17359 l_delim=mp->cur_sym; r_delim=mp->cur_mod;
17360 mp_get_x_next(mp); mp_scan_expression(mp);
17361 if ( (mp->cur_cmd==comma) && (mp->cur_type>=mp_known) ) {
17362 @<Scan the rest of a delimited set of numerics@>;
17364 mp_check_delimiter(mp, l_delim,r_delim);
17368 @ The |stash_in| subroutine puts the current (numeric) expression into a field
17369 within a ``big node.''
17372 static void mp_stash_in (MP mp,pointer p) {
17373 pointer q; /* temporary register */
17374 type(p)=mp->cur_type;
17375 if ( mp->cur_type==mp_known ) {
17376 value(p)=mp->cur_exp;
17378 if ( mp->cur_type==mp_independent ) {
17379 @<Stash an independent |cur_exp| into a big node@>;
17381 mp->mem[value_loc(p)]=mp->mem[value_loc(mp->cur_exp)];
17382 /* |dep_list(p):=dep_list(cur_exp)| and |prev_dep(p):=prev_dep(cur_exp)| */
17383 mp_link(prev_dep(p))=p;
17385 mp_free_node(mp, mp->cur_exp,value_node_size);
17387 mp->cur_type=mp_vacuous;
17390 @ In rare cases the current expression can become |independent|. There
17391 may be many dependency lists pointing to such an independent capsule,
17392 so we can't simply move it into place within a big node. Instead,
17393 we copy it, then recycle it.
17395 @ @<Stash an independent |cur_exp|...@>=
17397 q=mp_single_dependency(mp, mp->cur_exp);
17398 if ( q==mp->dep_final ){
17399 type(p)=mp_known; value(p)=0; mp_free_node(mp, q,dep_node_size);
17401 type(p)=mp_dependent; mp_new_dep(mp, p,q);
17403 mp_recycle_value(mp, mp->cur_exp);
17406 @ This code uses the fact that |red_part_loc| and |green_part_loc|
17407 are synonymous with |x_part_loc| and |y_part_loc|.
17409 @<Scan the rest of a delimited set of numerics@>=
17411 p=mp_stash_cur_exp(mp);
17412 mp_get_x_next(mp); mp_scan_expression(mp);
17413 @<Make sure the second part of a pair or color has a numeric type@>;
17414 q=mp_get_node(mp, value_node_size); name_type(q)=mp_capsule;
17415 if ( mp->cur_cmd==comma ) type(q)=mp_color_type;
17416 else type(q)=mp_pair_type;
17417 mp_init_big_node(mp, q); r=value(q);
17418 mp_stash_in(mp, y_part_loc(r));
17419 mp_unstash_cur_exp(mp, p);
17420 mp_stash_in(mp, x_part_loc(r));
17421 if ( mp->cur_cmd==comma ) {
17422 @<Scan the last of a triplet of numerics@>;
17424 if ( mp->cur_cmd==comma ) {
17425 type(q)=mp_cmykcolor_type;
17426 mp_init_big_node(mp, q); t=value(q);
17427 mp->mem[cyan_part_loc(t)]=mp->mem[red_part_loc(r)];
17428 value(cyan_part_loc(t))=value(red_part_loc(r));
17429 mp->mem[magenta_part_loc(t)]=mp->mem[green_part_loc(r)];
17430 value(magenta_part_loc(t))=value(green_part_loc(r));
17431 mp->mem[yellow_part_loc(t)]=mp->mem[blue_part_loc(r)];
17432 value(yellow_part_loc(t))=value(blue_part_loc(r));
17433 mp_recycle_value(mp, r);
17435 @<Scan the last of a quartet of numerics@>;
17437 mp_check_delimiter(mp, l_delim,r_delim);
17438 mp->cur_type=type(q);
17442 @ @<Make sure the second part of a pair or color has a numeric type@>=
17443 if ( mp->cur_type<mp_known ) {
17444 exp_err("Nonnumeric ypart has been replaced by 0");
17445 @.Nonnumeric...replaced by 0@>
17446 help4("I've started to scan a pair `(a,b)' or a color `(a,b,c)';",
17447 "but after finding a nice `a' I found a `b' that isn't",
17448 "of numeric type. So I've changed that part to zero.",
17449 "(The b that I didn't like appears above the error message.)");
17450 mp_put_get_flush_error(mp, 0);
17453 @ @<Scan the last of a triplet of numerics@>=
17455 mp_get_x_next(mp); mp_scan_expression(mp);
17456 if ( mp->cur_type<mp_known ) {
17457 exp_err("Nonnumeric third part has been replaced by 0");
17458 @.Nonnumeric...replaced by 0@>
17459 help3("I've just scanned a color `(a,b,c)' or cmykcolor(a,b,c,d); but the `c'",
17460 "isn't of numeric type. So I've changed that part to zero.",
17461 "(The c that I didn't like appears above the error message.)");
17462 mp_put_get_flush_error(mp, 0);
17464 mp_stash_in(mp, blue_part_loc(r));
17467 @ @<Scan the last of a quartet of numerics@>=
17469 mp_get_x_next(mp); mp_scan_expression(mp);
17470 if ( mp->cur_type<mp_known ) {
17471 exp_err("Nonnumeric blackpart has been replaced by 0");
17472 @.Nonnumeric...replaced by 0@>
17473 help3("I've just scanned a cmykcolor `(c,m,y,k)'; but the `k' isn't",
17474 "of numeric type. So I've changed that part to zero.",
17475 "(The k that I didn't like appears above the error message.)");
17476 mp_put_get_flush_error(mp, 0);
17478 mp_stash_in(mp, black_part_loc(r));
17481 @ The local variable |group_line| keeps track of the line
17482 where a \&{begingroup} command occurred; this will be useful
17483 in an error message if the group doesn't actually end.
17485 @<Other local variables for |scan_primary|@>=
17486 integer group_line; /* where a group began */
17488 @ @<Scan a grouped primary@>=
17490 group_line=mp_true_line(mp);
17491 if ( mp->internal[mp_tracing_commands]>0 ) show_cur_cmd_mod;
17492 save_boundary_item(p);
17494 mp_do_statement(mp); /* ends with |cur_cmd>=semicolon| */
17495 } while (mp->cur_cmd==semicolon);
17496 if ( mp->cur_cmd!=end_group ) {
17497 print_err("A group begun on line ");
17498 @.A group...never ended@>
17499 mp_print_int(mp, group_line);
17500 mp_print(mp, " never ended");
17501 help2("I saw a `begingroup' back there that hasn't been matched",
17502 "by `endgroup'. So I've inserted `endgroup' now.");
17503 mp_back_error(mp); mp->cur_cmd=end_group;
17506 /* this might change |cur_type|, if independent variables are recycled */
17507 if ( mp->internal[mp_tracing_commands]>0 ) show_cur_cmd_mod;
17510 @ @<Scan a string constant@>=
17512 mp->cur_type=mp_string_type; mp->cur_exp=mp->cur_mod;
17515 @ Later we'll come to procedures that perform actual operations like
17516 addition, square root, and so on; our purpose now is to do the parsing.
17517 But we might as well mention those future procedures now, so that the
17518 suspense won't be too bad:
17521 |do_nullary(c)| does primitive operations that have no operands (e.g.,
17522 `\&{true}' or `\&{pencircle}');
17525 |do_unary(c)| applies a primitive operation to the current expression;
17528 |do_binary(p,c)| applies a primitive operation to the capsule~|p|
17529 and the current expression.
17531 @<Scan a nullary operation@>=mp_do_nullary(mp, mp->cur_mod)
17533 @ @<Scan a unary operation@>=
17535 c=mp->cur_mod; mp_get_x_next(mp); mp_scan_primary(mp);
17536 mp_do_unary(mp, c); goto DONE;
17539 @ A numeric token might be a primary by itself, or it might be the
17540 numerator of a fraction composed solely of numeric tokens, or it might
17541 multiply the primary that follows (provided that the primary doesn't begin
17542 with a plus sign or a minus sign). The code here uses the facts that
17543 |max_primary_command=plus_or_minus| and
17544 |max_primary_command-1=numeric_token|. If a fraction is found that is less
17545 than unity, we try to retain higher precision when we use it in scalar
17548 @<Other local variables for |scan_primary|@>=
17549 scaled num,denom; /* for primaries that are fractions, like `1/2' */
17551 @ @<Scan a primary that starts with a numeric token@>=
17553 mp->cur_exp=mp->cur_mod; mp->cur_type=mp_known; mp_get_x_next(mp);
17554 if ( mp->cur_cmd!=slash ) {
17558 if ( mp->cur_cmd!=numeric_token ) {
17560 mp->cur_cmd=slash; mp->cur_mod=over; mp->cur_sym=frozen_slash;
17563 num=mp->cur_exp; denom=mp->cur_mod;
17564 if ( denom==0 ) { @<Protest division by zero@>; }
17565 else { mp->cur_exp=mp_make_scaled(mp, num,denom); }
17566 check_arith; mp_get_x_next(mp);
17568 if ( mp->cur_cmd>=min_primary_command ) {
17569 if ( mp->cur_cmd<numeric_token ) { /* in particular, |cur_cmd<>plus_or_minus| */
17570 p=mp_stash_cur_exp(mp); mp_scan_primary(mp);
17571 if ( (abs(num)>=abs(denom))||(mp->cur_type<mp_color_type) ) {
17572 mp_do_binary(mp, p,times);
17574 mp_frac_mult(mp, num,denom);
17575 mp_free_node(mp, p,value_node_size);
17582 @ @<Protest division...@>=
17584 print_err("Division by zero");
17585 @.Division by zero@>
17586 help1("I'll pretend that you meant to divide by 1."); mp_error(mp);
17589 @ @<Scan a binary operation with `\&{of}' between its operands@>=
17591 c=mp->cur_mod; mp_get_x_next(mp); mp_scan_expression(mp);
17592 if ( mp->cur_cmd!=of_token ) {
17593 mp_missing_err(mp, "of"); mp_print(mp, " for ");
17594 mp_print_cmd_mod(mp, primary_binary,c);
17596 help1("I've got the first argument; will look now for the other.");
17599 p=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_primary(mp);
17600 mp_do_binary(mp, p,c); goto DONE;
17603 @ @<Convert a suffix to a string@>=
17605 mp_get_x_next(mp); mp_scan_suffix(mp);
17606 mp->old_setting=mp->selector; mp->selector=new_string;
17607 mp_show_token_list(mp, mp->cur_exp,null,100000,0);
17608 mp_flush_token_list(mp, mp->cur_exp);
17609 mp->cur_exp=mp_make_string(mp); mp->selector=mp->old_setting;
17610 mp->cur_type=mp_string_type;
17614 @ If an internal quantity appears all by itself on the left of an
17615 assignment, we return a token list of length one, containing the address
17616 of the internal quantity plus |hash_end|. (This accords with the conventions
17617 of the save stack, as described earlier.)
17619 @<Scan an internal...@>=
17622 if ( my_var_flag==assignment ) {
17624 if ( mp->cur_cmd==assignment ) {
17625 mp->cur_exp=mp_get_avail(mp);
17626 info(mp->cur_exp)=q+hash_end; mp->cur_type=mp_token_list;
17631 mp->cur_type=mp_known; mp->cur_exp=mp->internal[q];
17634 @ The most difficult part of |scan_primary| has been saved for last, since
17635 it was necessary to build up some confidence first. We can now face the task
17636 of scanning a variable.
17638 As we scan a variable, we build a token list containing the relevant
17639 names and subscript values, simultaneously following along in the
17640 ``collective'' structure to see if we are actually dealing with a macro
17641 instead of a value.
17643 The local variables |pre_head| and |post_head| will point to the beginning
17644 of the prefix and suffix lists; |tail| will point to the end of the list
17645 that is currently growing.
17647 Another local variable, |tt|, contains partial information about the
17648 declared type of the variable-so-far. If |tt>=mp_unsuffixed_macro|, the
17649 relation |tt=type(q)| will always hold. If |tt=undefined|, the routine
17650 doesn't bother to update its information about type. And if
17651 |undefined<tt<mp_unsuffixed_macro|, the precise value of |tt| isn't critical.
17653 @ @<Other local variables for |scan_primary|@>=
17654 pointer pre_head,post_head,tail;
17655 /* prefix and suffix list variables */
17656 quarterword tt; /* approximation to the type of the variable-so-far */
17657 pointer t; /* a token */
17658 pointer macro_ref = 0; /* reference count for a suffixed macro */
17660 @ @<Scan a variable primary...@>=
17662 fast_get_avail(pre_head); tail=pre_head; post_head=null; tt=mp_vacuous;
17664 t=mp_cur_tok(mp); mp_link(tail)=t;
17665 if ( tt!=undefined ) {
17666 @<Find the approximate type |tt| and corresponding~|q|@>;
17667 if ( tt>=mp_unsuffixed_macro ) {
17668 @<Either begin an unsuffixed macro call or
17669 prepare for a suffixed one@>;
17672 mp_get_x_next(mp); tail=t;
17673 if ( mp->cur_cmd==left_bracket ) {
17674 @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>;
17676 if ( mp->cur_cmd>max_suffix_token ) break;
17677 if ( mp->cur_cmd<min_suffix_token ) break;
17678 } /* now |cur_cmd| is |internal_quantity|, |tag_token|, or |numeric_token| */
17679 @<Handle unusual cases that masquerade as variables, and |goto restart|
17680 or |goto done| if appropriate;
17681 otherwise make a copy of the variable and |goto done|@>;
17684 @ @<Either begin an unsuffixed macro call or...@>=
17686 mp_link(tail)=null;
17687 if ( tt>mp_unsuffixed_macro ) { /* |tt=mp_suffixed_macro| */
17688 post_head=mp_get_avail(mp); tail=post_head; mp_link(tail)=t;
17689 tt=undefined; macro_ref=value(q); add_mac_ref(macro_ref);
17691 @<Set up unsuffixed macro call and |goto restart|@>;
17695 @ @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>=
17697 mp_get_x_next(mp); mp_scan_expression(mp);
17698 if ( mp->cur_cmd!=right_bracket ) {
17699 @<Put the left bracket and the expression back to be rescanned@>;
17701 if ( mp->cur_type!=mp_known ) mp_bad_subscript(mp);
17702 mp->cur_cmd=numeric_token; mp->cur_mod=mp->cur_exp; mp->cur_sym=0;
17706 @ The left bracket that we thought was introducing a subscript might have
17707 actually been the left bracket in a mediation construction like `\.{x[a,b]}'.
17708 So we don't issue an error message at this point; but we do want to back up
17709 so as to avoid any embarrassment about our incorrect assumption.
17711 @<Put the left bracket and the expression back to be rescanned@>=
17713 mp_back_input(mp); /* that was the token following the current expression */
17714 mp_back_expr(mp); mp->cur_cmd=left_bracket;
17715 mp->cur_mod=0; mp->cur_sym=frozen_left_bracket;
17718 @ Here's a routine that puts the current expression back to be read again.
17721 static void mp_back_expr (MP mp) {
17722 pointer p; /* capsule token */
17723 p=mp_stash_cur_exp(mp); mp_link(p)=null; back_list(p);
17726 @ Unknown subscripts lead to the following error message.
17729 static void mp_bad_subscript (MP mp) {
17730 exp_err("Improper subscript has been replaced by zero");
17731 @.Improper subscript...@>
17732 help3("A bracketed subscript must have a known numeric value;",
17733 "unfortunately, what I found was the value that appears just",
17734 "above this error message. So I'll try a zero subscript.");
17735 mp_flush_error(mp, 0);
17738 @ Every time we call |get_x_next|, there's a chance that the variable we've
17739 been looking at will disappear. Thus, we cannot safely keep |q| pointing
17740 into the variable structure; we need to start searching from the root each time.
17742 @<Find the approximate type |tt| and corresponding~|q|@>=
17745 p=mp_link(pre_head); q=info(p); tt=undefined;
17746 if ( eq_type(q) % outer_tag==tag_token ) {
17748 if ( q==null ) goto DONE2;
17752 tt=type(q); goto DONE2;
17754 if ( type(q)!=mp_structured ) goto DONE2;
17755 q=mp_link(attr_head(q)); /* the |collective_subscript| attribute */
17756 if ( p>=mp->hi_mem_min ) { /* it's not a subscript */
17757 do { q=mp_link(q); } while (! (attr_loc(q)>=info(p)));
17758 if ( attr_loc(q)>info(p) ) goto DONE2;
17766 @ How do things stand now? Well, we have scanned an entire variable name,
17767 including possible subscripts and/or attributes; |cur_cmd|, |cur_mod|, and
17768 |cur_sym| represent the token that follows. If |post_head=null|, a
17769 token list for this variable name starts at |mp_link(pre_head)|, with all
17770 subscripts evaluated. But if |post_head<>null|, the variable turned out
17771 to be a suffixed macro; |pre_head| is the head of the prefix list, while
17772 |post_head| is the head of a token list containing both `\.{\AT!}' and
17775 Our immediate problem is to see if this variable still exists. (Variable
17776 structures can change drastically whenever we call |get_x_next|; users
17777 aren't supposed to do this, but the fact that it is possible means that
17778 we must be cautious.)
17780 The following procedure prints an error message when a variable
17781 unexpectedly disappears. Its help message isn't quite right for
17782 our present purposes, but we'll be able to fix that up.
17785 static void mp_obliterated (MP mp,pointer q) {
17786 print_err("Variable "); mp_show_token_list(mp, q,null,1000,0);
17787 mp_print(mp, " has been obliterated");
17788 @.Variable...obliterated@>
17789 help5("It seems you did a nasty thing---probably by accident,",
17790 "but nevertheless you nearly hornswoggled me...",
17791 "While I was evaluating the right-hand side of this",
17792 "command, something happened, and the left-hand side",
17793 "is no longer a variable! So I won't change anything.");
17796 @ If the variable does exist, we also need to check
17797 for a few other special cases before deciding that a plain old ordinary
17798 variable has, indeed, been scanned.
17800 @<Handle unusual cases that masquerade as variables...@>=
17801 if ( post_head!=null ) {
17802 @<Set up suffixed macro call and |goto restart|@>;
17804 q=mp_link(pre_head); free_avail(pre_head);
17805 if ( mp->cur_cmd==my_var_flag ) {
17806 mp->cur_type=mp_token_list; mp->cur_exp=q; goto DONE;
17808 p=mp_find_variable(mp, q);
17810 mp_make_exp_copy(mp, p);
17812 mp_obliterated(mp, q);
17813 mp->help_line[2]="While I was evaluating the suffix of this variable,";
17814 mp->help_line[1]="something was redefined, and it's no longer a variable!";
17815 mp->help_line[0]="In order to get back on my feet, I've inserted `0' instead.";
17816 mp_put_get_flush_error(mp, 0);
17818 mp_flush_node_list(mp, q);
17821 @ The only complication associated with macro calling is that the prefix
17822 and ``at'' parameters must be packaged in an appropriate list of lists.
17824 @<Set up unsuffixed macro call and |goto restart|@>=
17826 p=mp_get_avail(mp); info(pre_head)=mp_link(pre_head); mp_link(pre_head)=p;
17827 info(p)=t; mp_macro_call(mp, value(q),pre_head,null);
17832 @ If the ``variable'' that turned out to be a suffixed macro no longer exists,
17833 we don't care, because we have reserved a pointer (|macro_ref|) to its
17836 @<Set up suffixed macro call and |goto restart|@>=
17838 mp_back_input(mp); p=mp_get_avail(mp); q=mp_link(post_head);
17839 info(pre_head)=mp_link(pre_head); mp_link(pre_head)=post_head;
17840 info(post_head)=q; mp_link(post_head)=p; info(p)=mp_link(q); mp_link(q)=null;
17841 mp_macro_call(mp, macro_ref,pre_head,null); decr(ref_count(macro_ref));
17842 mp_get_x_next(mp); goto RESTART;
17845 @ Our remaining job is simply to make a copy of the value that has been
17846 found. Some cases are harder than others, but complexity arises solely
17847 because of the multiplicity of possible cases.
17849 @<Declare the procedure called |make_exp_copy|@>=
17850 @<Declare subroutines needed by |make_exp_copy|@>
17851 static void mp_make_exp_copy (MP mp,pointer p) {
17852 pointer q,r,t; /* registers for list manipulation */
17854 mp->cur_type=type(p);
17855 switch (mp->cur_type) {
17856 case mp_vacuous: case mp_boolean_type: case mp_known:
17857 mp->cur_exp=value(p); break;
17858 case unknown_types:
17859 mp->cur_exp=mp_new_ring_entry(mp, p);
17861 case mp_string_type:
17862 mp->cur_exp=value(p); add_str_ref(mp->cur_exp);
17864 case mp_picture_type:
17865 mp->cur_exp=value(p);add_edge_ref(mp->cur_exp);
17868 mp->cur_exp=copy_pen(value(p));
17871 mp->cur_exp=mp_copy_path(mp, value(p));
17873 case mp_transform_type: case mp_color_type:
17874 case mp_cmykcolor_type: case mp_pair_type:
17875 @<Copy the big node |p|@>;
17877 case mp_dependent: case mp_proto_dependent:
17878 mp_encapsulate(mp, mp_copy_dep_list(mp, dep_list(p)));
17880 case mp_numeric_type:
17881 new_indep(p); goto RESTART;
17883 case mp_independent:
17884 q=mp_single_dependency(mp, p);
17885 if ( q==mp->dep_final ){
17886 mp->cur_type=mp_known; mp->cur_exp=0; mp_free_node(mp, q,dep_node_size);
17888 mp->cur_type=mp_dependent; mp_encapsulate(mp, q);
17892 mp_confusion(mp, "copy");
17893 @:this can't happen copy}{\quad copy@>
17898 @ The |encapsulate| subroutine assumes that |dep_final| is the
17899 tail of dependency list~|p|.
17901 @<Declare subroutines needed by |make_exp_copy|@>=
17902 static void mp_encapsulate (MP mp,pointer p) {
17903 mp->cur_exp=mp_get_node(mp, value_node_size); type(mp->cur_exp)=mp->cur_type;
17904 name_type(mp->cur_exp)=mp_capsule; mp_new_dep(mp, mp->cur_exp,p);
17907 @ The most tedious case arises when the user refers to a
17908 \&{pair}, \&{color}, or \&{transform} variable; we must copy several fields,
17909 each of which can be |independent|, |dependent|, |mp_proto_dependent|,
17912 @<Copy the big node |p|@>=
17914 if ( value(p)==null )
17915 mp_init_big_node(mp, p);
17916 t=mp_get_node(mp, value_node_size); name_type(t)=mp_capsule; type(t)=mp->cur_type;
17917 mp_init_big_node(mp, t);
17918 q=value(p)+mp->big_node_size[mp->cur_type];
17919 r=value(t)+mp->big_node_size[mp->cur_type];
17921 q=q-2; r=r-2; mp_install(mp, r,q);
17922 } while (q!=value(p));
17926 @ The |install| procedure copies a numeric field~|q| into field~|r| of
17927 a big node that will be part of a capsule.
17929 @<Declare subroutines needed by |make_exp_copy|@>=
17930 static void mp_install (MP mp,pointer r, pointer q) {
17931 pointer p; /* temporary register */
17932 if ( type(q)==mp_known ){
17933 value(r)=value(q); type(r)=mp_known;
17934 } else if ( type(q)==mp_independent ) {
17935 p=mp_single_dependency(mp, q);
17936 if ( p==mp->dep_final ) {
17937 type(r)=mp_known; value(r)=0; mp_free_node(mp, p,dep_node_size);
17939 type(r)=mp_dependent; mp_new_dep(mp, r,p);
17942 type(r)=type(q); mp_new_dep(mp, r,mp_copy_dep_list(mp, dep_list(q)));
17946 @ Expressions of the form `\.{a[b,c]}' are converted into
17947 `\.{b+a*(c-b)}', without checking the types of \.b~or~\.c,
17948 provided that \.a is numeric.
17950 @<Scan a mediation...@>=
17952 p=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_expression(mp);
17953 if ( mp->cur_cmd!=comma ) {
17954 @<Put the left bracket and the expression back...@>;
17955 mp_unstash_cur_exp(mp, p);
17957 q=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_expression(mp);
17958 if ( mp->cur_cmd!=right_bracket ) {
17959 mp_missing_err(mp, "]");
17961 help3("I've scanned an expression of the form `a[b,c',",
17962 "so a right bracket should have come next.",
17963 "I shall pretend that one was there.");
17966 r=mp_stash_cur_exp(mp); mp_make_exp_copy(mp, q);
17967 mp_do_binary(mp, r,minus); mp_do_binary(mp, p,times);
17968 mp_do_binary(mp, q,plus); mp_get_x_next(mp);
17972 @ Here is a comparatively simple routine that is used to scan the
17973 \&{suffix} parameters of a macro.
17975 @<Declare the basic parsing subroutines@>=
17976 static void mp_scan_suffix (MP mp) {
17977 pointer h,t; /* head and tail of the list being built */
17978 pointer p; /* temporary register */
17979 h=mp_get_avail(mp); t=h;
17981 if ( mp->cur_cmd==left_bracket ) {
17982 @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>;
17984 if ( mp->cur_cmd==numeric_token ) {
17985 p=mp_new_num_tok(mp, mp->cur_mod);
17986 } else if ((mp->cur_cmd==tag_token)||(mp->cur_cmd==internal_quantity) ) {
17987 p=mp_get_avail(mp); info(p)=mp->cur_sym;
17991 mp_link(t)=p; t=p; mp_get_x_next(mp);
17993 mp->cur_exp=mp_link(h); free_avail(h); mp->cur_type=mp_token_list;
17996 @ @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>=
17998 mp_get_x_next(mp); mp_scan_expression(mp);
17999 if ( mp->cur_type!=mp_known ) mp_bad_subscript(mp);
18000 if ( mp->cur_cmd!=right_bracket ) {
18001 mp_missing_err(mp, "]");
18003 help3("I've seen a `[' and a subscript value, in a suffix,",
18004 "so a right bracket should have come next.",
18005 "I shall pretend that one was there.");
18008 mp->cur_cmd=numeric_token; mp->cur_mod=mp->cur_exp;
18011 @* \[38] Parsing secondary and higher expressions.
18013 After the intricacies of |scan_primary|\kern-1pt,
18014 the |scan_secondary| routine is
18015 refreshingly simple. It's not trivial, but the operations are relatively
18016 straightforward; the main difficulty is, again, that expressions and data
18017 structures might change drastically every time we call |get_x_next|, so a
18018 cautious approach is mandatory. For example, a macro defined by
18019 \&{primarydef} might have disappeared by the time its second argument has
18020 been scanned; we solve this by increasing the reference count of its token
18021 list, so that the macro can be called even after it has been clobbered.
18023 @<Declare the basic parsing subroutines@>=
18024 static void mp_scan_secondary (MP mp) {
18025 pointer p; /* for list manipulation */
18026 halfword c,d; /* operation codes or modifiers */
18027 pointer mac_name; /* token defined with \&{primarydef} */
18029 if ((mp->cur_cmd<min_primary_command)||
18030 (mp->cur_cmd>max_primary_command) )
18031 mp_bad_exp(mp, "A secondary");
18032 @.A secondary expression...@>
18033 mp_scan_primary(mp);
18035 if ( mp->cur_cmd<=max_secondary_command &&
18036 mp->cur_cmd>=min_secondary_command ) {
18037 p=mp_stash_cur_exp(mp);
18038 c=mp->cur_mod; d=mp->cur_cmd;
18039 if ( d==secondary_primary_macro ) {
18040 mac_name=mp->cur_sym;
18044 mp_scan_primary(mp);
18045 if ( d!=secondary_primary_macro ) {
18046 mp_do_binary(mp, p,c);
18049 mp_binary_mac(mp, p,c,mac_name);
18050 decr(ref_count(c));
18058 @ The following procedure calls a macro that has two parameters,
18062 static void mp_binary_mac (MP mp,pointer p, pointer c, pointer n) {
18063 pointer q,r; /* nodes in the parameter list */
18064 q=mp_get_avail(mp); r=mp_get_avail(mp); mp_link(q)=r;
18065 info(q)=p; info(r)=mp_stash_cur_exp(mp);
18066 mp_macro_call(mp, c,q,n);
18069 @ The next procedure, |scan_tertiary|, is pretty much the same deal.
18071 @<Declare the basic parsing subroutines@>=
18072 static void mp_scan_tertiary (MP mp) {
18073 pointer p; /* for list manipulation */
18074 halfword c,d; /* operation codes or modifiers */
18075 pointer mac_name; /* token defined with \&{secondarydef} */
18077 if ((mp->cur_cmd<min_primary_command)||
18078 (mp->cur_cmd>max_primary_command) )
18079 mp_bad_exp(mp, "A tertiary");
18080 @.A tertiary expression...@>
18081 mp_scan_secondary(mp);
18083 if ( mp->cur_cmd<=max_tertiary_command ) {
18084 if ( mp->cur_cmd>=min_tertiary_command ) {
18085 p=mp_stash_cur_exp(mp); c=mp->cur_mod; d=mp->cur_cmd;
18086 if ( d==tertiary_secondary_macro ) {
18087 mac_name=mp->cur_sym; add_mac_ref(c);
18089 mp_get_x_next(mp); mp_scan_secondary(mp);
18090 if ( d!=tertiary_secondary_macro ) {
18091 mp_do_binary(mp, p,c);
18093 mp_back_input(mp); mp_binary_mac(mp, p,c,mac_name);
18094 decr(ref_count(c)); mp_get_x_next(mp);
18102 @ Finally we reach the deepest level in our quartet of parsing routines.
18103 This one is much like the others; but it has an extra complication from
18104 paths, which materialize here.
18106 @d continue_path 25 /* a label inside of |scan_expression| */
18107 @d finish_path 26 /* another */
18109 @<Declare the basic parsing subroutines@>=
18110 static void mp_scan_expression (MP mp) {
18111 pointer p,q,r,pp,qq; /* for list manipulation */
18112 halfword c,d; /* operation codes or modifiers */
18113 int my_var_flag; /* initial value of |var_flag| */
18114 pointer mac_name; /* token defined with \&{tertiarydef} */
18115 boolean cycle_hit; /* did a path expression just end with `\&{cycle}'? */
18116 scaled x,y; /* explicit coordinates or tension at a path join */
18117 int t; /* knot type following a path join */
18119 my_var_flag=mp->var_flag; mac_name=null;
18121 if ((mp->cur_cmd<min_primary_command)||
18122 (mp->cur_cmd>max_primary_command) )
18123 mp_bad_exp(mp, "An");
18124 @.An expression...@>
18125 mp_scan_tertiary(mp);
18127 if ( mp->cur_cmd<=max_expression_command )
18128 if ( mp->cur_cmd>=min_expression_command ) {
18129 if ( (mp->cur_cmd!=equals)||(my_var_flag!=assignment) ) {
18130 p=mp_stash_cur_exp(mp); c=mp->cur_mod; d=mp->cur_cmd;
18131 if ( d==expression_tertiary_macro ) {
18132 mac_name=mp->cur_sym; add_mac_ref(c);
18134 if ( (d<ampersand)||((d==ampersand)&&
18135 ((type(p)==mp_pair_type)||(type(p)==mp_path_type))) ) {
18136 @<Scan a path construction operation;
18137 but |return| if |p| has the wrong type@>;
18139 mp_get_x_next(mp); mp_scan_tertiary(mp);
18140 if ( d!=expression_tertiary_macro ) {
18141 mp_do_binary(mp, p,c);
18143 mp_back_input(mp); mp_binary_mac(mp, p,c,mac_name);
18144 decr(ref_count(c)); mp_get_x_next(mp);
18153 @ The reader should review the data structure conventions for paths before
18154 hoping to understand the next part of this code.
18156 @<Scan a path construction operation...@>=
18159 @<Convert the left operand, |p|, into a partial path ending at~|q|;
18160 but |return| if |p| doesn't have a suitable type@>;
18162 @<Determine the path join parameters;
18163 but |goto finish_path| if there's only a direction specifier@>;
18164 if ( mp->cur_cmd==cycle ) {
18165 @<Get ready to close a cycle@>;
18167 mp_scan_tertiary(mp);
18168 @<Convert the right operand, |cur_exp|,
18169 into a partial path from |pp| to~|qq|@>;
18171 @<Join the partial paths and reset |p| and |q| to the head and tail
18173 if ( mp->cur_cmd>=min_expression_command )
18174 if ( mp->cur_cmd<=ampersand ) if ( ! cycle_hit ) goto CONTINUE_PATH;
18176 @<Choose control points for the path and put the result into |cur_exp|@>;
18179 @ @<Convert the left operand, |p|, into a partial path ending at~|q|...@>=
18181 mp_unstash_cur_exp(mp, p);
18182 if ( mp->cur_type==mp_pair_type ) p=mp_new_knot(mp);
18183 else if ( mp->cur_type==mp_path_type ) p=mp->cur_exp;
18186 while ( mp_link(q)!=p ) q=mp_link(q);
18187 if ( left_type(p)!=mp_endpoint ) { /* open up a cycle */
18188 r=mp_copy_knot(mp, p); mp_link(q)=r; q=r;
18190 left_type(p)=mp_open; right_type(q)=mp_open;
18193 @ A pair of numeric values is changed into a knot node for a one-point path
18194 when \MP\ discovers that the pair is part of a path.
18197 static pointer mp_new_knot (MP mp) { /* convert a pair to a knot with two endpoints */
18198 pointer q; /* the new node */
18199 q=mp_get_node(mp, knot_node_size); left_type(q)=mp_endpoint;
18200 right_type(q)=mp_endpoint; originator(q)=mp_metapost_user; mp_link(q)=q;
18201 mp_known_pair(mp); x_coord(q)=mp->cur_x; y_coord(q)=mp->cur_y;
18205 @ The |known_pair| subroutine sets |cur_x| and |cur_y| to the components
18206 of the current expression, assuming that the current expression is a
18207 pair of known numerics. Unknown components are zeroed, and the
18208 current expression is flushed.
18211 static void mp_known_pair (MP mp);
18214 void mp_known_pair (MP mp) {
18215 pointer p; /* the pair node */
18216 if ( mp->cur_type!=mp_pair_type ) {
18217 exp_err("Undefined coordinates have been replaced by (0,0)");
18218 @.Undefined coordinates...@>
18219 help5("I need x and y numbers for this part of the path.",
18220 "The value I found (see above) was no good;",
18221 "so I'll try to keep going by using zero instead.",
18222 "(Chapter 27 of The METAFONTbook explains that",
18223 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18224 "you might want to type `I ??" "?' now.)");
18225 mp_put_get_flush_error(mp, 0); mp->cur_x=0; mp->cur_y=0;
18227 p=value(mp->cur_exp);
18228 @<Make sure that both |x| and |y| parts of |p| are known;
18229 copy them into |cur_x| and |cur_y|@>;
18230 mp_flush_cur_exp(mp, 0);
18234 @ @<Make sure that both |x| and |y| parts of |p| are known...@>=
18235 if ( type(x_part_loc(p))==mp_known ) {
18236 mp->cur_x=value(x_part_loc(p));
18238 mp_disp_err(mp, x_part_loc(p),
18239 "Undefined x coordinate has been replaced by 0");
18240 @.Undefined coordinates...@>
18241 help5("I need a `known' x value for this part of the path.",
18242 "The value I found (see above) was no good;",
18243 "so I'll try to keep going by using zero instead.",
18244 "(Chapter 27 of The METAFONTbook explains that",
18245 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18246 "you might want to type `I ??" "?' now.)");
18247 mp_put_get_error(mp); mp_recycle_value(mp, x_part_loc(p)); mp->cur_x=0;
18249 if ( type(y_part_loc(p))==mp_known ) {
18250 mp->cur_y=value(y_part_loc(p));
18252 mp_disp_err(mp, y_part_loc(p),
18253 "Undefined y coordinate has been replaced by 0");
18254 help5("I need a `known' y value for this part of the path.",
18255 "The value I found (see above) was no good;",
18256 "so I'll try to keep going by using zero instead.",
18257 "(Chapter 27 of The METAFONTbook explains that",
18258 "you might want to type `I ??" "?' now.)");
18259 mp_put_get_error(mp); mp_recycle_value(mp, y_part_loc(p)); mp->cur_y=0;
18262 @ At this point |cur_cmd| is either |ampersand|, |left_brace|, or |path_join|.
18264 @<Determine the path join parameters...@>=
18265 if ( mp->cur_cmd==left_brace ) {
18266 @<Put the pre-join direction information into node |q|@>;
18269 if ( d==path_join ) {
18270 @<Determine the tension and/or control points@>;
18271 } else if ( d!=ampersand ) {
18275 if ( mp->cur_cmd==left_brace ) {
18276 @<Put the post-join direction information into |x| and |t|@>;
18277 } else if ( right_type(q)!=mp_explicit ) {
18281 @ The |scan_direction| subroutine looks at the directional information
18282 that is enclosed in braces, and also scans ahead to the following character.
18283 A type code is returned, either |open| (if the direction was $(0,0)$),
18284 or |curl| (if the direction was a curl of known value |cur_exp|), or
18285 |given| (if the direction is given by the |angle| value that now
18286 appears in |cur_exp|).
18288 There's nothing difficult about this subroutine, but the program is rather
18289 lengthy because a variety of potential errors need to be nipped in the bud.
18292 static quarterword mp_scan_direction (MP mp) {
18293 int t; /* the type of information found */
18294 scaled x; /* an |x| coordinate */
18296 if ( mp->cur_cmd==curl_command ) {
18297 @<Scan a curl specification@>;
18299 @<Scan a given direction@>;
18301 if ( mp->cur_cmd!=right_brace ) {
18302 mp_missing_err(mp, "}");
18303 @.Missing `\char`\}'@>
18304 help3("I've scanned a direction spec for part of a path,",
18305 "so a right brace should have come next.",
18306 "I shall pretend that one was there.");
18313 @ @<Scan a curl specification@>=
18314 { mp_get_x_next(mp); mp_scan_expression(mp);
18315 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<0) ){
18316 exp_err("Improper curl has been replaced by 1");
18318 help1("A curl must be a known, nonnegative number.");
18319 mp_put_get_flush_error(mp, unity);
18324 @ @<Scan a given direction@>=
18325 { mp_scan_expression(mp);
18326 if ( mp->cur_type>mp_pair_type ) {
18327 @<Get given directions separated by commas@>;
18331 if ( (mp->cur_x==0)&&(mp->cur_y==0) ) t=mp_open;
18332 else { t=mp_given; mp->cur_exp=mp_n_arg(mp, mp->cur_x,mp->cur_y);}
18335 @ @<Get given directions separated by commas@>=
18337 if ( mp->cur_type!=mp_known ) {
18338 exp_err("Undefined x coordinate has been replaced by 0");
18339 @.Undefined coordinates...@>
18340 help5("I need a `known' x value for this part of the path.",
18341 "The value I found (see above) was no good;",
18342 "so I'll try to keep going by using zero instead.",
18343 "(Chapter 27 of The METAFONTbook explains that",
18344 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18345 "you might want to type `I ??" "?' now.)");
18346 mp_put_get_flush_error(mp, 0);
18349 if ( mp->cur_cmd!=comma ) {
18350 mp_missing_err(mp, ",");
18352 help2("I've got the x coordinate of a path direction;",
18353 "will look for the y coordinate next.");
18356 mp_get_x_next(mp); mp_scan_expression(mp);
18357 if ( mp->cur_type!=mp_known ) {
18358 exp_err("Undefined y coordinate has been replaced by 0");
18359 help5("I need a `known' y value for this part of the path.",
18360 "The value I found (see above) was no good;",
18361 "so I'll try to keep going by using zero instead.",
18362 "(Chapter 27 of The METAFONTbook explains that",
18363 "you might want to type `I ??" "?' now.)");
18364 mp_put_get_flush_error(mp, 0);
18366 mp->cur_y=mp->cur_exp; mp->cur_x=x;
18369 @ At this point |right_type(q)| is usually |open|, but it may have been
18370 set to some other value by a previous operation. We must maintain
18371 the value of |right_type(q)| in cases such as
18372 `\.{..\{curl2\}z\{0,0\}..}'.
18374 @<Put the pre-join...@>=
18376 t=mp_scan_direction(mp);
18377 if ( t!=mp_open ) {
18378 right_type(q)=t; right_given(q)=mp->cur_exp;
18379 if ( left_type(q)==mp_open ) {
18380 left_type(q)=t; left_given(q)=mp->cur_exp;
18381 } /* note that |left_given(q)=left_curl(q)| */
18385 @ Since |left_tension| and |left_y| share the same position in knot nodes,
18386 and since |left_given| is similarly equivalent to |left_x|, we use
18387 |x| and |y| to hold the given direction and tension information when
18388 there are no explicit control points.
18390 @<Put the post-join...@>=
18392 t=mp_scan_direction(mp);
18393 if ( right_type(q)!=mp_explicit ) x=mp->cur_exp;
18394 else t=mp_explicit; /* the direction information is superfluous */
18397 @ @<Determine the tension and/or...@>=
18400 if ( mp->cur_cmd==tension ) {
18401 @<Set explicit tensions@>;
18402 } else if ( mp->cur_cmd==controls ) {
18403 @<Set explicit control points@>;
18405 right_tension(q)=unity; y=unity; mp_back_input(mp); /* default tension */
18408 if ( mp->cur_cmd!=path_join ) {
18409 mp_missing_err(mp, "..");
18411 help1("A path join command should end with two dots.");
18418 @ @<Set explicit tensions@>=
18420 mp_get_x_next(mp); y=mp->cur_cmd;
18421 if ( mp->cur_cmd==at_least ) mp_get_x_next(mp);
18422 mp_scan_primary(mp);
18423 @<Make sure that the current expression is a valid tension setting@>;
18424 if ( y==at_least ) negate(mp->cur_exp);
18425 right_tension(q)=mp->cur_exp;
18426 if ( mp->cur_cmd==and_command ) {
18427 mp_get_x_next(mp); y=mp->cur_cmd;
18428 if ( mp->cur_cmd==at_least ) mp_get_x_next(mp);
18429 mp_scan_primary(mp);
18430 @<Make sure that the current expression is a valid tension setting@>;
18431 if ( y==at_least ) negate(mp->cur_exp);
18436 @ @d min_tension three_quarter_unit
18438 @<Make sure that the current expression is a valid tension setting@>=
18439 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<min_tension) ) {
18440 exp_err("Improper tension has been set to 1");
18441 @.Improper tension@>
18442 help1("The expression above should have been a number >=3/4.");
18443 mp_put_get_flush_error(mp, unity);
18446 @ @<Set explicit control points@>=
18448 right_type(q)=mp_explicit; t=mp_explicit; mp_get_x_next(mp); mp_scan_primary(mp);
18449 mp_known_pair(mp); right_x(q)=mp->cur_x; right_y(q)=mp->cur_y;
18450 if ( mp->cur_cmd!=and_command ) {
18451 x=right_x(q); y=right_y(q);
18453 mp_get_x_next(mp); mp_scan_primary(mp);
18454 mp_known_pair(mp); x=mp->cur_x; y=mp->cur_y;
18458 @ @<Convert the right operand, |cur_exp|, into a partial path...@>=
18460 if ( mp->cur_type!=mp_path_type ) pp=mp_new_knot(mp);
18461 else pp=mp->cur_exp;
18463 while ( mp_link(qq)!=pp ) qq=mp_link(qq);
18464 if ( left_type(pp)!=mp_endpoint ) { /* open up a cycle */
18465 r=mp_copy_knot(mp, pp); mp_link(qq)=r; qq=r;
18467 left_type(pp)=mp_open; right_type(qq)=mp_open;
18470 @ If a person tries to define an entire path by saying `\.{(x,y)\&cycle}',
18471 we silently change the specification to `\.{(x,y)..cycle}', since a cycle
18472 shouldn't have length zero.
18474 @<Get ready to close a cycle@>=
18476 cycle_hit=true; mp_get_x_next(mp); pp=p; qq=p;
18477 if ( d==ampersand ) if ( p==q ) {
18478 d=path_join; right_tension(q)=unity; y=unity;
18482 @ @<Join the partial paths and reset |p| and |q|...@>=
18484 if ( d==ampersand ) {
18485 if ( (x_coord(q)!=x_coord(pp))||(y_coord(q)!=y_coord(pp)) ) {
18486 print_err("Paths don't touch; `&' will be changed to `..'");
18487 @.Paths don't touch@>
18488 help3("When you join paths `p&q', the ending point of p",
18489 "must be exactly equal to the starting point of q.",
18490 "So I'm going to pretend that you said `p..q' instead.");
18491 mp_put_get_error(mp); d=path_join; right_tension(q)=unity; y=unity;
18494 @<Plug an opening in |right_type(pp)|, if possible@>;
18495 if ( d==ampersand ) {
18496 @<Splice independent paths together@>;
18498 @<Plug an opening in |right_type(q)|, if possible@>;
18499 mp_link(q)=pp; left_y(pp)=y;
18500 if ( t!=mp_open ) { left_x(pp)=x; left_type(pp)=t; };
18505 @ @<Plug an opening in |right_type(q)|...@>=
18506 if ( right_type(q)==mp_open ) {
18507 if ( (left_type(q)==mp_curl)||(left_type(q)==mp_given) ) {
18508 right_type(q)=left_type(q); right_given(q)=left_given(q);
18512 @ @<Plug an opening in |right_type(pp)|...@>=
18513 if ( right_type(pp)==mp_open ) {
18514 if ( (t==mp_curl)||(t==mp_given) ) {
18515 right_type(pp)=t; right_given(pp)=x;
18519 @ @<Splice independent paths together@>=
18521 if ( left_type(q)==mp_open ) if ( right_type(q)==mp_open ) {
18522 left_type(q)=mp_curl; left_curl(q)=unity;
18524 if ( right_type(pp)==mp_open ) if ( t==mp_open ) {
18525 right_type(pp)=mp_curl; right_curl(pp)=unity;
18527 right_type(q)=right_type(pp); mp_link(q)=mp_link(pp);
18528 right_x(q)=right_x(pp); right_y(q)=right_y(pp);
18529 mp_free_node(mp, pp,knot_node_size);
18530 if ( qq==pp ) qq=q;
18533 @ @<Choose control points for the path...@>=
18535 if ( d==ampersand ) p=q;
18537 left_type(p)=mp_endpoint;
18538 if ( right_type(p)==mp_open ) {
18539 right_type(p)=mp_curl; right_curl(p)=unity;
18541 right_type(q)=mp_endpoint;
18542 if ( left_type(q)==mp_open ) {
18543 left_type(q)=mp_curl; left_curl(q)=unity;
18547 mp_make_choices(mp, p);
18548 mp->cur_type=mp_path_type; mp->cur_exp=p
18550 @ Finally, we sometimes need to scan an expression whose value is
18551 supposed to be either |true_code| or |false_code|.
18553 @<Declare the basic parsing subroutines@>=
18554 static void mp_get_boolean (MP mp) {
18555 mp_get_x_next(mp); mp_scan_expression(mp);
18556 if ( mp->cur_type!=mp_boolean_type ) {
18557 exp_err("Undefined condition will be treated as `false'");
18558 @.Undefined condition...@>
18559 help2("The expression shown above should have had a definite",
18560 "true-or-false value. I'm changing it to `false'.");
18561 mp_put_get_flush_error(mp, false_code); mp->cur_type=mp_boolean_type;
18565 @* \[39] Doing the operations.
18566 The purpose of parsing is primarily to permit people to avoid piles of
18567 parentheses. But the real work is done after the structure of an expression
18568 has been recognized; that's when new expressions are generated. We
18569 turn now to the guts of \MP, which handles individual operators that
18570 have come through the parsing mechanism.
18572 We'll start with the easy ones that take no operands, then work our way
18573 up to operators with one and ultimately two arguments. In other words,
18574 we will write the three procedures |do_nullary|, |do_unary|, and |do_binary|
18575 that are invoked periodically by the expression scanners.
18577 First let's make sure that all of the primitive operators are in the
18578 hash table. Although |scan_primary| and its relatives made use of the
18579 \\{cmd} code for these operators, the \\{do} routines base everything
18580 on the \\{mod} code. For example, |do_binary| doesn't care whether the
18581 operation it performs is a |primary_binary| or |secondary_binary|, etc.
18584 mp_primitive(mp, "true",nullary,true_code);
18585 @:true_}{\&{true} primitive@>
18586 mp_primitive(mp, "false",nullary,false_code);
18587 @:false_}{\&{false} primitive@>
18588 mp_primitive(mp, "nullpicture",nullary,null_picture_code);
18589 @:null_picture_}{\&{nullpicture} primitive@>
18590 mp_primitive(mp, "nullpen",nullary,null_pen_code);
18591 @:null_pen_}{\&{nullpen} primitive@>
18592 mp_primitive(mp, "jobname",nullary,job_name_op);
18593 @:job_name_}{\&{jobname} primitive@>
18594 mp_primitive(mp, "readstring",nullary,read_string_op);
18595 @:read_string_}{\&{readstring} primitive@>
18596 mp_primitive(mp, "pencircle",nullary,pen_circle);
18597 @:pen_circle_}{\&{pencircle} primitive@>
18598 mp_primitive(mp, "normaldeviate",nullary,normal_deviate);
18599 @:normal_deviate_}{\&{normaldeviate} primitive@>
18600 mp_primitive(mp, "readfrom",unary,read_from_op);
18601 @:read_from_}{\&{readfrom} primitive@>
18602 mp_primitive(mp, "closefrom",unary,close_from_op);
18603 @:close_from_}{\&{closefrom} primitive@>
18604 mp_primitive(mp, "odd",unary,odd_op);
18605 @:odd_}{\&{odd} primitive@>
18606 mp_primitive(mp, "known",unary,known_op);
18607 @:known_}{\&{known} primitive@>
18608 mp_primitive(mp, "unknown",unary,unknown_op);
18609 @:unknown_}{\&{unknown} primitive@>
18610 mp_primitive(mp, "not",unary,not_op);
18611 @:not_}{\&{not} primitive@>
18612 mp_primitive(mp, "decimal",unary,decimal);
18613 @:decimal_}{\&{decimal} primitive@>
18614 mp_primitive(mp, "reverse",unary,reverse);
18615 @:reverse_}{\&{reverse} primitive@>
18616 mp_primitive(mp, "makepath",unary,make_path_op);
18617 @:make_path_}{\&{makepath} primitive@>
18618 mp_primitive(mp, "makepen",unary,make_pen_op);
18619 @:make_pen_}{\&{makepen} primitive@>
18620 mp_primitive(mp, "oct",unary,oct_op);
18621 @:oct_}{\&{oct} primitive@>
18622 mp_primitive(mp, "hex",unary,hex_op);
18623 @:hex_}{\&{hex} primitive@>
18624 mp_primitive(mp, "ASCII",unary,ASCII_op);
18625 @:ASCII_}{\&{ASCII} primitive@>
18626 mp_primitive(mp, "char",unary,char_op);
18627 @:char_}{\&{char} primitive@>
18628 mp_primitive(mp, "length",unary,length_op);
18629 @:length_}{\&{length} primitive@>
18630 mp_primitive(mp, "turningnumber",unary,turning_op);
18631 @:turning_number_}{\&{turningnumber} primitive@>
18632 mp_primitive(mp, "xpart",unary,x_part);
18633 @:x_part_}{\&{xpart} primitive@>
18634 mp_primitive(mp, "ypart",unary,y_part);
18635 @:y_part_}{\&{ypart} primitive@>
18636 mp_primitive(mp, "xxpart",unary,xx_part);
18637 @:xx_part_}{\&{xxpart} primitive@>
18638 mp_primitive(mp, "xypart",unary,xy_part);
18639 @:xy_part_}{\&{xypart} primitive@>
18640 mp_primitive(mp, "yxpart",unary,yx_part);
18641 @:yx_part_}{\&{yxpart} primitive@>
18642 mp_primitive(mp, "yypart",unary,yy_part);
18643 @:yy_part_}{\&{yypart} primitive@>
18644 mp_primitive(mp, "redpart",unary,red_part);
18645 @:red_part_}{\&{redpart} primitive@>
18646 mp_primitive(mp, "greenpart",unary,green_part);
18647 @:green_part_}{\&{greenpart} primitive@>
18648 mp_primitive(mp, "bluepart",unary,blue_part);
18649 @:blue_part_}{\&{bluepart} primitive@>
18650 mp_primitive(mp, "cyanpart",unary,cyan_part);
18651 @:cyan_part_}{\&{cyanpart} primitive@>
18652 mp_primitive(mp, "magentapart",unary,magenta_part);
18653 @:magenta_part_}{\&{magentapart} primitive@>
18654 mp_primitive(mp, "yellowpart",unary,yellow_part);
18655 @:yellow_part_}{\&{yellowpart} primitive@>
18656 mp_primitive(mp, "blackpart",unary,black_part);
18657 @:black_part_}{\&{blackpart} primitive@>
18658 mp_primitive(mp, "greypart",unary,grey_part);
18659 @:grey_part_}{\&{greypart} primitive@>
18660 mp_primitive(mp, "colormodel",unary,color_model_part);
18661 @:color_model_part_}{\&{colormodel} primitive@>
18662 mp_primitive(mp, "fontpart",unary,font_part);
18663 @:font_part_}{\&{fontpart} primitive@>
18664 mp_primitive(mp, "textpart",unary,text_part);
18665 @:text_part_}{\&{textpart} primitive@>
18666 mp_primitive(mp, "pathpart",unary,path_part);
18667 @:path_part_}{\&{pathpart} primitive@>
18668 mp_primitive(mp, "penpart",unary,pen_part);
18669 @:pen_part_}{\&{penpart} primitive@>
18670 mp_primitive(mp, "dashpart",unary,dash_part);
18671 @:dash_part_}{\&{dashpart} primitive@>
18672 mp_primitive(mp, "sqrt",unary,sqrt_op);
18673 @:sqrt_}{\&{sqrt} primitive@>
18674 mp_primitive(mp, "mexp",unary,mp_m_exp_op);
18675 @:m_exp_}{\&{mexp} primitive@>
18676 mp_primitive(mp, "mlog",unary,mp_m_log_op);
18677 @:m_log_}{\&{mlog} primitive@>
18678 mp_primitive(mp, "sind",unary,sin_d_op);
18679 @:sin_d_}{\&{sind} primitive@>
18680 mp_primitive(mp, "cosd",unary,cos_d_op);
18681 @:cos_d_}{\&{cosd} primitive@>
18682 mp_primitive(mp, "floor",unary,floor_op);
18683 @:floor_}{\&{floor} primitive@>
18684 mp_primitive(mp, "uniformdeviate",unary,uniform_deviate);
18685 @:uniform_deviate_}{\&{uniformdeviate} primitive@>
18686 mp_primitive(mp, "charexists",unary,char_exists_op);
18687 @:char_exists_}{\&{charexists} primitive@>
18688 mp_primitive(mp, "fontsize",unary,font_size);
18689 @:font_size_}{\&{fontsize} primitive@>
18690 mp_primitive(mp, "llcorner",unary,ll_corner_op);
18691 @:ll_corner_}{\&{llcorner} primitive@>
18692 mp_primitive(mp, "lrcorner",unary,lr_corner_op);
18693 @:lr_corner_}{\&{lrcorner} primitive@>
18694 mp_primitive(mp, "ulcorner",unary,ul_corner_op);
18695 @:ul_corner_}{\&{ulcorner} primitive@>
18696 mp_primitive(mp, "urcorner",unary,ur_corner_op);
18697 @:ur_corner_}{\&{urcorner} primitive@>
18698 mp_primitive(mp, "arclength",unary,arc_length);
18699 @:arc_length_}{\&{arclength} primitive@>
18700 mp_primitive(mp, "angle",unary,angle_op);
18701 @:angle_}{\&{angle} primitive@>
18702 mp_primitive(mp, "cycle",cycle,cycle_op);
18703 @:cycle_}{\&{cycle} primitive@>
18704 mp_primitive(mp, "stroked",unary,stroked_op);
18705 @:stroked_}{\&{stroked} primitive@>
18706 mp_primitive(mp, "filled",unary,filled_op);
18707 @:filled_}{\&{filled} primitive@>
18708 mp_primitive(mp, "textual",unary,textual_op);
18709 @:textual_}{\&{textual} primitive@>
18710 mp_primitive(mp, "clipped",unary,clipped_op);
18711 @:clipped_}{\&{clipped} primitive@>
18712 mp_primitive(mp, "bounded",unary,bounded_op);
18713 @:bounded_}{\&{bounded} primitive@>
18714 mp_primitive(mp, "+",plus_or_minus,plus);
18715 @:+ }{\.{+} primitive@>
18716 mp_primitive(mp, "-",plus_or_minus,minus);
18717 @:- }{\.{-} primitive@>
18718 mp_primitive(mp, "*",secondary_binary,times);
18719 @:* }{\.{*} primitive@>
18720 mp_primitive(mp, "/",slash,over); mp->eqtb[frozen_slash]=mp->eqtb[mp->cur_sym];
18721 @:/ }{\.{/} primitive@>
18722 mp_primitive(mp, "++",tertiary_binary,pythag_add);
18723 @:++_}{\.{++} primitive@>
18724 mp_primitive(mp, "+-+",tertiary_binary,pythag_sub);
18725 @:+-+_}{\.{+-+} primitive@>
18726 mp_primitive(mp, "or",tertiary_binary,or_op);
18727 @:or_}{\&{or} primitive@>
18728 mp_primitive(mp, "and",and_command,and_op);
18729 @:and_}{\&{and} primitive@>
18730 mp_primitive(mp, "<",expression_binary,less_than);
18731 @:< }{\.{<} primitive@>
18732 mp_primitive(mp, "<=",expression_binary,less_or_equal);
18733 @:<=_}{\.{<=} primitive@>
18734 mp_primitive(mp, ">",expression_binary,greater_than);
18735 @:> }{\.{>} primitive@>
18736 mp_primitive(mp, ">=",expression_binary,greater_or_equal);
18737 @:>=_}{\.{>=} primitive@>
18738 mp_primitive(mp, "=",equals,equal_to);
18739 @:= }{\.{=} primitive@>
18740 mp_primitive(mp, "<>",expression_binary,unequal_to);
18741 @:<>_}{\.{<>} primitive@>
18742 mp_primitive(mp, "substring",primary_binary,substring_of);
18743 @:substring_}{\&{substring} primitive@>
18744 mp_primitive(mp, "subpath",primary_binary,subpath_of);
18745 @:subpath_}{\&{subpath} primitive@>
18746 mp_primitive(mp, "directiontime",primary_binary,direction_time_of);
18747 @:direction_time_}{\&{directiontime} primitive@>
18748 mp_primitive(mp, "point",primary_binary,point_of);
18749 @:point_}{\&{point} primitive@>
18750 mp_primitive(mp, "precontrol",primary_binary,precontrol_of);
18751 @:precontrol_}{\&{precontrol} primitive@>
18752 mp_primitive(mp, "postcontrol",primary_binary,postcontrol_of);
18753 @:postcontrol_}{\&{postcontrol} primitive@>
18754 mp_primitive(mp, "penoffset",primary_binary,pen_offset_of);
18755 @:pen_offset_}{\&{penoffset} primitive@>
18756 mp_primitive(mp, "arctime",primary_binary,arc_time_of);
18757 @:arc_time_of_}{\&{arctime} primitive@>
18758 mp_primitive(mp, "mpversion",nullary,mp_version);
18759 @:mp_verison_}{\&{mpversion} primitive@>
18760 mp_primitive(mp, "&",ampersand,concatenate);
18761 @:!!!}{\.{\&} primitive@>
18762 mp_primitive(mp, "rotated",secondary_binary,rotated_by);
18763 @:rotated_}{\&{rotated} primitive@>
18764 mp_primitive(mp, "slanted",secondary_binary,slanted_by);
18765 @:slanted_}{\&{slanted} primitive@>
18766 mp_primitive(mp, "scaled",secondary_binary,scaled_by);
18767 @:scaled_}{\&{scaled} primitive@>
18768 mp_primitive(mp, "shifted",secondary_binary,shifted_by);
18769 @:shifted_}{\&{shifted} primitive@>
18770 mp_primitive(mp, "transformed",secondary_binary,transformed_by);
18771 @:transformed_}{\&{transformed} primitive@>
18772 mp_primitive(mp, "xscaled",secondary_binary,x_scaled);
18773 @:x_scaled_}{\&{xscaled} primitive@>
18774 mp_primitive(mp, "yscaled",secondary_binary,y_scaled);
18775 @:y_scaled_}{\&{yscaled} primitive@>
18776 mp_primitive(mp, "zscaled",secondary_binary,z_scaled);
18777 @:z_scaled_}{\&{zscaled} primitive@>
18778 mp_primitive(mp, "infont",secondary_binary,in_font);
18779 @:in_font_}{\&{infont} primitive@>
18780 mp_primitive(mp, "intersectiontimes",tertiary_binary,intersect);
18781 @:intersection_times_}{\&{intersectiontimes} primitive@>
18782 mp_primitive(mp, "envelope",primary_binary,envelope_of);
18783 @:envelope_}{\&{envelope} primitive@>
18785 @ @<Cases of |print_cmd...@>=
18788 case primary_binary:
18789 case secondary_binary:
18790 case tertiary_binary:
18791 case expression_binary:
18793 case plus_or_minus:
18798 mp_print_op(mp, m);
18801 @ OK, let's look at the simplest \\{do} procedure first.
18803 @c @<Declare nullary action procedure@>
18804 static void mp_do_nullary (MP mp,quarterword c) {
18806 if ( mp->internal[mp_tracing_commands]>two )
18807 mp_show_cmd_mod(mp, nullary,c);
18809 case true_code: case false_code:
18810 mp->cur_type=mp_boolean_type; mp->cur_exp=c;
18812 case null_picture_code:
18813 mp->cur_type=mp_picture_type;
18814 mp->cur_exp=mp_get_node(mp, edge_header_size);
18815 mp_init_edges(mp, mp->cur_exp);
18817 case null_pen_code:
18818 mp->cur_type=mp_pen_type; mp->cur_exp=mp_get_pen_circle(mp, 0);
18820 case normal_deviate:
18821 mp->cur_type=mp_known; mp->cur_exp=mp_norm_rand(mp);
18824 mp->cur_type=mp_pen_type; mp->cur_exp=mp_get_pen_circle(mp, unity);
18827 if ( mp->job_name==NULL ) mp_open_log_file(mp);
18828 mp->cur_type=mp_string_type; mp->cur_exp=rts(mp->job_name);
18831 mp->cur_type=mp_string_type;
18832 mp->cur_exp=intern(metapost_version) ;
18834 case read_string_op:
18835 @<Read a string from the terminal@>;
18837 } /* there are no other cases */
18841 @ @<Read a string...@>=
18843 if (mp->noninteractive || mp->interaction<=mp_nonstop_mode )
18844 mp_fatal_error(mp, "*** (cannot readstring in nonstop modes)");
18845 mp_begin_file_reading(mp); name=is_read;
18846 limit=start; prompt_input("");
18847 mp_finish_read(mp);
18850 @ @<Declare nullary action procedure@>=
18851 static void mp_finish_read (MP mp) { /* copy |buffer| line to |cur_exp| */
18853 str_room((int)mp->last-start);
18854 for (k=(size_t)start;k<=mp->last-1;k++) {
18855 append_char(mp->buffer[k]);
18857 mp_end_file_reading(mp); mp->cur_type=mp_string_type;
18858 mp->cur_exp=mp_make_string(mp);
18861 @ Things get a bit more interesting when there's an operand. The
18862 operand to |do_unary| appears in |cur_type| and |cur_exp|.
18864 @c @<Declare unary action procedures@>
18865 static void mp_do_unary (MP mp,quarterword c) {
18866 pointer p,q,r; /* for list manipulation */
18867 integer x; /* a temporary register */
18869 if ( mp->internal[mp_tracing_commands]>two )
18870 @<Trace the current unary operation@>;
18873 if ( mp->cur_type<mp_color_type ) mp_bad_unary(mp, plus);
18876 @<Negate the current expression@>;
18878 @<Additional cases of unary operators@>;
18879 } /* there are no other cases */
18883 @ The |nice_pair| function returns |true| if both components of a pair
18886 @<Declare unary action procedures@>=
18887 static boolean mp_nice_pair (MP mp,integer p, quarterword t) {
18888 if ( t==mp_pair_type ) {
18890 if ( type(x_part_loc(p))==mp_known )
18891 if ( type(y_part_loc(p))==mp_known )
18897 @ The |nice_color_or_pair| function is analogous except that it also accepts
18898 fully known colors.
18900 @<Declare unary action procedures@>=
18901 static boolean mp_nice_color_or_pair (MP mp,integer p, quarterword t) {
18902 pointer q,r; /* for scanning the big node */
18903 if ( (t!=mp_pair_type)&&(t!=mp_color_type)&&(t!=mp_cmykcolor_type) ) {
18907 r=q+mp->big_node_size[type(p)];
18910 if ( type(r)!=mp_known )
18917 @ @<Declare unary action...@>=
18918 static void mp_print_known_or_unknown_type (MP mp,quarterword t, integer v) {
18919 mp_print_char(mp, xord('('));
18920 if ( t>mp_known ) mp_print(mp, "unknown numeric");
18921 else { if ( (t==mp_pair_type)||(t==mp_color_type)||(t==mp_cmykcolor_type) )
18922 if ( ! mp_nice_color_or_pair(mp, v,t) ) mp_print(mp, "unknown ");
18923 mp_print_type(mp, t);
18925 mp_print_char(mp, xord(')'));
18928 @ @<Declare unary action...@>=
18929 static void mp_bad_unary (MP mp,quarterword c) {
18930 exp_err("Not implemented: "); mp_print_op(mp, c);
18931 @.Not implemented...@>
18932 mp_print_known_or_unknown_type(mp, mp->cur_type,mp->cur_exp);
18933 help3("I'm afraid I don't know how to apply that operation to that",
18934 "particular type. Continue, and I'll simply return the",
18935 "argument (shown above) as the result of the operation.");
18936 mp_put_get_error(mp);
18939 @ @<Trace the current unary operation@>=
18941 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
18942 mp_print_op(mp, c); mp_print_char(mp, xord('('));
18943 mp_print_exp(mp, null,0); /* show the operand, but not verbosely */
18944 mp_print(mp, ")}"); mp_end_diagnostic(mp, false);
18947 @ Negation is easy except when the current expression
18948 is of type |independent|, or when it is a pair with one or more
18949 |independent| components.
18951 It is tempting to argue that the negative of an independent variable
18952 is an independent variable, hence we don't have to do anything when
18953 negating it. The fallacy is that other dependent variables pointing
18954 to the current expression must change the sign of their
18955 coefficients if we make no change to the current expression.
18957 Instead, we work around the problem by copying the current expression
18958 and recycling it afterwards (cf.~the |stash_in| routine).
18960 @<Negate the current expression@>=
18961 switch (mp->cur_type) {
18962 case mp_color_type:
18963 case mp_cmykcolor_type:
18965 case mp_independent:
18966 q=mp->cur_exp; mp_make_exp_copy(mp, q);
18967 if ( mp->cur_type==mp_dependent ) {
18968 mp_negate_dep_list(mp, dep_list(mp->cur_exp));
18969 } else if ( mp->cur_type<=mp_pair_type ) { /* |mp_color_type| or |mp_pair_type| */
18970 p=value(mp->cur_exp);
18971 r=p+mp->big_node_size[mp->cur_type];
18974 if ( type(r)==mp_known ) negate(value(r));
18975 else mp_negate_dep_list(mp, dep_list(r));
18977 } /* if |cur_type=mp_known| then |cur_exp=0| */
18978 mp_recycle_value(mp, q); mp_free_node(mp, q,value_node_size);
18981 case mp_proto_dependent:
18982 mp_negate_dep_list(mp, dep_list(mp->cur_exp));
18985 negate(mp->cur_exp);
18988 mp_bad_unary(mp, minus);
18992 @ @<Declare unary action...@>=
18993 static void mp_negate_dep_list (MP mp,pointer p) {
18996 if ( info(p)==null ) return;
19001 @ @<Additional cases of unary operators@>=
19003 if ( mp->cur_type!=mp_boolean_type ) mp_bad_unary(mp, not_op);
19004 else mp->cur_exp=true_code+false_code-mp->cur_exp;
19007 @ @d three_sixty_units 23592960 /* that's |360*unity| */
19008 @d boolean_reset(A) if ( (A) ) mp->cur_exp=true_code; else mp->cur_exp=false_code
19010 @<Additional cases of unary operators@>=
19017 case uniform_deviate:
19019 case char_exists_op:
19020 if ( mp->cur_type!=mp_known ) {
19021 mp_bad_unary(mp, c);
19024 case sqrt_op:mp->cur_exp=mp_square_rt(mp, mp->cur_exp);break;
19025 case mp_m_exp_op:mp->cur_exp=mp_m_exp(mp, mp->cur_exp);break;
19026 case mp_m_log_op:mp->cur_exp=mp_m_log(mp, mp->cur_exp);break;
19029 mp_n_sin_cos(mp, (mp->cur_exp % three_sixty_units)*16);
19030 if ( c==sin_d_op ) mp->cur_exp=mp_round_fraction(mp, mp->n_sin);
19031 else mp->cur_exp=mp_round_fraction(mp, mp->n_cos);
19033 case floor_op:mp->cur_exp=mp_floor_scaled(mp, mp->cur_exp);break;
19034 case uniform_deviate:mp->cur_exp=mp_unif_rand(mp, mp->cur_exp);break;
19036 boolean_reset(odd(mp_round_unscaled(mp, mp->cur_exp)));
19037 mp->cur_type=mp_boolean_type;
19039 case char_exists_op:
19040 @<Determine if a character has been shipped out@>;
19042 } /* there are no other cases */
19046 @ @<Additional cases of unary operators@>=
19048 if ( mp_nice_pair(mp, mp->cur_exp,mp->cur_type) ) {
19049 p=value(mp->cur_exp);
19050 x=mp_n_arg(mp, value(x_part_loc(p)),value(y_part_loc(p)));
19051 if ( x>=0 ) mp_flush_cur_exp(mp, (x+8)/ 16);
19052 else mp_flush_cur_exp(mp, -((-x+8)/ 16));
19054 mp_bad_unary(mp, angle_op);
19058 @ If the current expression is a pair, but the context wants it to
19059 be a path, we call |pair_to_path|.
19061 @<Declare unary action...@>=
19062 static void mp_pair_to_path (MP mp) {
19063 mp->cur_exp=mp_new_knot(mp);
19064 mp->cur_type=mp_path_type;
19068 @d pict_color_type(A) ((mp_link(dummy_loc(mp->cur_exp))!=null) &&
19069 (has_color(mp_link(dummy_loc(mp->cur_exp)))) &&
19070 ((color_model(mp_link(dummy_loc(mp->cur_exp)))==A)
19072 ((color_model(mp_link(dummy_loc(mp->cur_exp)))==mp_uninitialized_model) &&
19073 (mp->internal[mp_default_color_model]/unity)==(A))))
19075 @<Additional cases of unary operators@>=
19078 if ( (mp->cur_type==mp_pair_type)||(mp->cur_type==mp_transform_type) )
19079 mp_take_part(mp, c);
19080 else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
19081 else mp_bad_unary(mp, c);
19087 if ( mp->cur_type==mp_transform_type ) mp_take_part(mp, c);
19088 else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
19089 else mp_bad_unary(mp, c);
19094 if ( mp->cur_type==mp_color_type ) mp_take_part(mp, c);
19095 else if ( mp->cur_type==mp_picture_type ) {
19096 if pict_color_type(mp_rgb_model) mp_take_pict_part(mp, c);
19097 else mp_bad_color_part(mp, c);
19099 else mp_bad_unary(mp, c);
19105 if ( mp->cur_type==mp_cmykcolor_type) mp_take_part(mp, c);
19106 else if ( mp->cur_type==mp_picture_type ) {
19107 if pict_color_type(mp_cmyk_model) mp_take_pict_part(mp, c);
19108 else mp_bad_color_part(mp, c);
19110 else mp_bad_unary(mp, c);
19113 if ( mp->cur_type==mp_known ) mp->cur_exp=value(c);
19114 else if ( mp->cur_type==mp_picture_type ) {
19115 if pict_color_type(mp_grey_model) mp_take_pict_part(mp, c);
19116 else mp_bad_color_part(mp, c);
19118 else mp_bad_unary(mp, c);
19120 case color_model_part:
19121 if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
19122 else mp_bad_unary(mp, c);
19125 @ @<Declarations@>=
19126 static void mp_bad_color_part(MP mp, quarterword c);
19129 static void mp_bad_color_part(MP mp, quarterword c) {
19130 pointer p; /* the big node */
19131 p=mp_link(dummy_loc(mp->cur_exp));
19132 exp_err("Wrong picture color model: "); mp_print_op(mp, c);
19133 @.Wrong picture color model...@>
19134 if (color_model(p)==mp_grey_model)
19135 mp_print(mp, " of grey object");
19136 else if (color_model(p)==mp_cmyk_model)
19137 mp_print(mp, " of cmyk object");
19138 else if (color_model(p)==mp_rgb_model)
19139 mp_print(mp, " of rgb object");
19140 else if (color_model(p)==mp_no_model)
19141 mp_print(mp, " of marking object");
19143 mp_print(mp," of defaulted object");
19144 help3("You can only ask for the redpart, greenpart, bluepart of a rgb object,",
19145 "the cyanpart, magentapart, yellowpart or blackpart of a cmyk object, ",
19146 "or the greypart of a grey object. No mixing and matching, please.");
19149 mp_flush_cur_exp(mp,unity);
19151 mp_flush_cur_exp(mp,0);
19154 @ In the following procedure, |cur_exp| points to a capsule, which points to
19155 a big node. We want to delete all but one part of the big node.
19157 @<Declare unary action...@>=
19158 static void mp_take_part (MP mp,quarterword c) {
19159 pointer p; /* the big node */
19160 p=value(mp->cur_exp); value(temp_val)=p; type(temp_val)=mp->cur_type;
19161 mp_link(p)=temp_val; mp_free_node(mp, mp->cur_exp,value_node_size);
19162 mp_make_exp_copy(mp, p+mp->sector_offset[c+mp_x_part_sector-x_part]);
19163 mp_recycle_value(mp, temp_val);
19166 @ @<Initialize table entries...@>=
19167 name_type(temp_val)=mp_capsule;
19169 @ @<Additional cases of unary operators@>=
19175 if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
19176 else mp_bad_unary(mp, c);
19179 @ @<Declarations@>=
19180 static void mp_scale_edges (MP mp);
19182 @ @<Declare unary action...@>=
19183 static void mp_take_pict_part (MP mp,quarterword c) {
19184 pointer p; /* first graphical object in |cur_exp| */
19185 p=mp_link(dummy_loc(mp->cur_exp));
19188 case x_part: case y_part: case xx_part:
19189 case xy_part: case yx_part: case yy_part:
19190 if ( type(p)==mp_text_code ) mp_flush_cur_exp(mp, text_trans_part(p+c));
19191 else goto NOT_FOUND;
19193 case red_part: case green_part: case blue_part:
19194 if ( has_color(p) ) mp_flush_cur_exp(mp, obj_color_part(p+c));
19195 else goto NOT_FOUND;
19197 case cyan_part: case magenta_part: case yellow_part:
19199 if ( has_color(p) ) {
19200 if ( color_model(p)==mp_uninitialized_model && c==black_part)
19201 mp_flush_cur_exp(mp, unity);
19203 mp_flush_cur_exp(mp, obj_color_part(p+c+(red_part-cyan_part)));
19204 } else goto NOT_FOUND;
19207 if ( has_color(p) )
19208 mp_flush_cur_exp(mp, obj_color_part(p+c+(red_part-grey_part)));
19209 else goto NOT_FOUND;
19211 case color_model_part:
19212 if ( has_color(p) ) {
19213 if ( color_model(p)==mp_uninitialized_model )
19214 mp_flush_cur_exp(mp, mp->internal[mp_default_color_model]);
19216 mp_flush_cur_exp(mp, color_model(p)*unity);
19217 } else goto NOT_FOUND;
19219 @<Handle other cases in |take_pict_part| or |goto not_found|@>;
19220 } /* all cases have been enumerated */
19224 @<Convert the current expression to a null value appropriate
19228 @ @<Handle other cases in |take_pict_part| or |goto not_found|@>=
19230 if ( type(p)!=mp_text_code ) goto NOT_FOUND;
19232 mp_flush_cur_exp(mp, text_p(p));
19233 add_str_ref(mp->cur_exp);
19234 mp->cur_type=mp_string_type;
19238 if ( type(p)!=mp_text_code ) goto NOT_FOUND;
19240 mp_flush_cur_exp(mp, rts(mp->font_name[font_n(p)]));
19241 add_str_ref(mp->cur_exp);
19242 mp->cur_type=mp_string_type;
19246 if ( type(p)==mp_text_code ) goto NOT_FOUND;
19247 else if ( is_stop(p) ) mp_confusion(mp, "pict");
19248 @:this can't happen pict}{\quad pict@>
19250 mp_flush_cur_exp(mp, mp_copy_path(mp, path_p(p)));
19251 mp->cur_type=mp_path_type;
19255 if ( ! has_pen(p) ) goto NOT_FOUND;
19257 if ( pen_p(p)==null ) goto NOT_FOUND;
19258 else { mp_flush_cur_exp(mp, copy_pen(pen_p(p)));
19259 mp->cur_type=mp_pen_type;
19264 if ( type(p)!=mp_stroked_code ) goto NOT_FOUND;
19265 else { if ( dash_p(p)==null ) goto NOT_FOUND;
19266 else { add_edge_ref(dash_p(p));
19267 mp->se_sf=dash_scale(p);
19268 mp->se_pic=dash_p(p);
19269 mp_scale_edges(mp);
19270 mp_flush_cur_exp(mp, mp->se_pic);
19271 mp->cur_type=mp_picture_type;
19276 @ Since |scale_edges| had to be declared |forward|, it had to be declared as a
19277 parameterless procedure even though it really takes two arguments and updates
19278 one of them. Hence the following globals are needed.
19281 pointer se_pic; /* edge header used and updated by |scale_edges| */
19282 scaled se_sf; /* the scale factor argument to |scale_edges| */
19284 @ @<Convert the current expression to a null value appropriate...@>=
19286 case text_part: case font_part:
19287 mp_flush_cur_exp(mp, null_str);
19288 mp->cur_type=mp_string_type;
19291 mp_flush_cur_exp(mp, mp_get_node(mp, knot_node_size));
19292 left_type(mp->cur_exp)=mp_endpoint;
19293 right_type(mp->cur_exp)=mp_endpoint;
19294 mp_link(mp->cur_exp)=mp->cur_exp;
19295 x_coord(mp->cur_exp)=0;
19296 y_coord(mp->cur_exp)=0;
19297 originator(mp->cur_exp)=mp_metapost_user;
19298 mp->cur_type=mp_path_type;
19301 mp_flush_cur_exp(mp, mp_get_pen_circle(mp, 0));
19302 mp->cur_type=mp_pen_type;
19305 mp_flush_cur_exp(mp, mp_get_node(mp, edge_header_size));
19306 mp_init_edges(mp, mp->cur_exp);
19307 mp->cur_type=mp_picture_type;
19310 mp_flush_cur_exp(mp, 0);
19314 @ @<Additional cases of unary...@>=
19316 if ( mp->cur_type!=mp_known ) {
19317 mp_bad_unary(mp, char_op);
19319 mp->cur_exp=mp_round_unscaled(mp, mp->cur_exp) % 256;
19320 mp->cur_type=mp_string_type;
19321 if ( mp->cur_exp<0 ) mp->cur_exp=mp->cur_exp+256;
19325 if ( mp->cur_type!=mp_known ) {
19326 mp_bad_unary(mp, decimal);
19328 mp->old_setting=mp->selector; mp->selector=new_string;
19329 mp_print_scaled(mp, mp->cur_exp); mp->cur_exp=mp_make_string(mp);
19330 mp->selector=mp->old_setting; mp->cur_type=mp_string_type;
19336 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, c);
19337 else mp_str_to_num(mp, c);
19340 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, font_size);
19341 else @<Find the design size of the font whose name is |cur_exp|@>;
19344 @ @<Declare unary action...@>=
19345 static void mp_str_to_num (MP mp,quarterword c) { /* converts a string to a number */
19346 integer n; /* accumulator */
19347 ASCII_code m; /* current character */
19348 pool_pointer k; /* index into |str_pool| */
19349 int b; /* radix of conversion */
19350 boolean bad_char; /* did the string contain an invalid digit? */
19351 if ( c==ASCII_op ) {
19352 if ( length(mp->cur_exp)==0 ) n=-1;
19353 else n=mp->str_pool[mp->str_start[mp->cur_exp]];
19355 if ( c==oct_op ) b=8; else b=16;
19356 n=0; bad_char=false;
19357 for (k=mp->str_start[mp->cur_exp];k<=str_stop(mp->cur_exp)-1;k++) {
19359 if ( (m>='0')&&(m<='9') ) m=m-'0';
19360 else if ( (m>='A')&&(m<='F') ) m=m-'A'+10;
19361 else if ( (m>='a')&&(m<='f') ) m=m-'a'+10;
19362 else { bad_char=true; m=0; };
19363 if ( (int)m>=b ) { bad_char=true; m=0; };
19364 if ( n<32768 / b ) n=n*b+m; else n=32767;
19366 @<Give error messages if |bad_char| or |n>=4096|@>;
19368 mp_flush_cur_exp(mp, n*unity);
19371 @ @<Give error messages if |bad_char|...@>=
19373 exp_err("String contains illegal digits");
19374 @.String contains illegal digits@>
19376 help1("I zeroed out characters that weren't in the range 0..7.");
19378 help1("I zeroed out characters that weren't hex digits.");
19380 mp_put_get_error(mp);
19383 if ( mp->internal[mp_warning_check]>0 ) {
19384 print_err("Number too large (");
19385 mp_print_int(mp, n); mp_print_char(mp, xord(')'));
19386 @.Number too large@>
19387 help2("I have trouble with numbers greater than 4095; watch out.",
19388 "(Set warningcheck:=0 to suppress this message.)");
19389 mp_put_get_error(mp);
19393 @ The length operation is somewhat unusual in that it applies to a variety
19394 of different types of operands.
19396 @<Additional cases of unary...@>=
19398 switch (mp->cur_type) {
19399 case mp_string_type: mp_flush_cur_exp(mp, length(mp->cur_exp)*unity); break;
19400 case mp_path_type: mp_flush_cur_exp(mp, mp_path_length(mp)); break;
19401 case mp_known: mp->cur_exp=abs(mp->cur_exp); break;
19402 case mp_picture_type: mp_flush_cur_exp(mp, mp_pict_length(mp)); break;
19404 if ( mp_nice_pair(mp, mp->cur_exp,mp->cur_type) )
19405 mp_flush_cur_exp(mp, mp_pyth_add(mp,
19406 value(x_part_loc(value(mp->cur_exp))),
19407 value(y_part_loc(value(mp->cur_exp)))));
19408 else mp_bad_unary(mp, c);
19413 @ @<Declare unary action...@>=
19414 static scaled mp_path_length (MP mp) { /* computes the length of the current path */
19415 scaled n; /* the path length so far */
19416 pointer p; /* traverser */
19418 if ( left_type(p)==mp_endpoint ) n=-unity; else n=0;
19419 do { p=mp_link(p); n=n+unity; } while (p!=mp->cur_exp);
19423 @ @<Declare unary action...@>=
19424 static scaled mp_pict_length (MP mp) {
19425 /* counts interior components in picture |cur_exp| */
19426 scaled n; /* the count so far */
19427 pointer p; /* traverser */
19429 p=mp_link(dummy_loc(mp->cur_exp));
19431 if ( is_start_or_stop(p) )
19432 if ( mp_skip_1component(mp, p)==null ) p=mp_link(p);
19433 while ( p!=null ) {
19434 skip_component(p) return n;
19441 @ Implement |turningnumber|
19443 @<Additional cases of unary...@>=
19445 if ( mp->cur_type==mp_pair_type ) mp_flush_cur_exp(mp, 0);
19446 else if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, turning_op);
19447 else if ( left_type(mp->cur_exp)==mp_endpoint )
19448 mp_flush_cur_exp(mp, 0); /* not a cyclic path */
19450 mp_flush_cur_exp(mp, mp_turn_cycles_wrapper(mp, mp->cur_exp));
19453 @ The function |an_angle| returns the value of the |angle| primitive, or $0$ if the
19454 argument is |origin|.
19456 @<Declare unary action...@>=
19457 static angle mp_an_angle (MP mp,scaled xpar, scaled ypar) {
19458 if ( (! ((xpar==0) && (ypar==0))) )
19459 return mp_n_arg(mp, xpar,ypar);
19464 @ The actual turning number is (for the moment) computed in a C function
19465 that receives eight integers corresponding to the four controlling points,
19466 and returns a single angle. Besides those, we have to account for discrete
19467 moves at the actual points.
19469 @d mp_floor(a) ((a)>=0 ? (int)(a) : -(int)(-(a)))
19470 @d bezier_error (720*(256*256*16))+1
19471 @d mp_sign(v) ((v)>0 ? 1 : ((v)<0 ? -1 : 0 ))
19472 @d mp_out(A) (double)((A)/(256*256*16))
19473 @d divisor (256*256)
19474 @d double2angle(a) (int)mp_floor(a*256.0*256.0*16.0)
19476 @<Declare unary action...@>=
19477 static angle mp_bezier_slope(MP mp, integer AX,integer AY,integer BX,integer BY,
19478 integer CX,integer CY,integer DX,integer DY);
19481 static angle mp_bezier_slope(MP mp, integer AX,integer AY,integer BX,integer BY,
19482 integer CX,integer CY,integer DX,integer DY) {
19484 integer deltax,deltay;
19485 double ax,ay,bx,by,cx,cy,dx,dy;
19486 angle xi = 0, xo = 0, xm = 0;
19488 ax=(double)(AX/divisor); ay=(double)(AY/divisor);
19489 bx=(double)(BX/divisor); by=(double)(BY/divisor);
19490 cx=(double)(CX/divisor); cy=(double)(CY/divisor);
19491 dx=(double)(DX/divisor); dy=(double)(DY/divisor);
19493 deltax = (BX-AX); deltay = (BY-AY);
19494 if (deltax==0 && deltay == 0) { deltax=(CX-AX); deltay=(CY-AY); }
19495 if (deltax==0 && deltay == 0) { deltax=(DX-AX); deltay=(DY-AY); }
19496 xi = mp_an_angle(mp,deltax,deltay);
19498 deltax = (CX-BX); deltay = (CY-BY);
19499 xm = mp_an_angle(mp,deltax,deltay);
19501 deltax = (DX-CX); deltay = (DY-CY);
19502 if (deltax==0 && deltay == 0) { deltax=(DX-BX); deltay=(DY-BY); }
19503 if (deltax==0 && deltay == 0) { deltax=(DX-AX); deltay=(DY-AY); }
19504 xo = mp_an_angle(mp,deltax,deltay);
19506 a = (bx-ax)*(cy-by) - (cx-bx)*(by-ay); /* a = (bp-ap)x(cp-bp); */
19507 b = (bx-ax)*(dy-cy) - (by-ay)*(dx-cx);; /* b = (bp-ap)x(dp-cp);*/
19508 c = (cx-bx)*(dy-cy) - (dx-cx)*(cy-by); /* c = (cp-bp)x(dp-cp);*/
19510 if ((a==0)&&(c==0)) {
19511 res = (b==0 ? 0 : (mp_out(xo)-mp_out(xi)));
19512 } else if ((a==0)||(c==0)) {
19513 if ((mp_sign(b) == mp_sign(a)) || (mp_sign(b) == mp_sign(c))) {
19514 res = mp_out(xo)-mp_out(xi); /* ? */
19517 else if (res>180.0)
19520 res = mp_out(xo)-mp_out(xi); /* ? */
19522 } else if ((mp_sign(a)*mp_sign(c))<0) {
19523 res = mp_out(xo)-mp_out(xi); /* ? */
19526 else if (res>180.0)
19529 if (mp_sign(a) == mp_sign(b)) {
19530 res = mp_out(xo)-mp_out(xi); /* ? */
19533 else if (res>180.0)
19536 if ((b*b) == (4*a*c)) {
19537 res = (double)bezier_error;
19538 } else if ((b*b) < (4*a*c)) {
19539 res = mp_out(xo)-mp_out(xi); /* ? */
19540 if (res<=0.0 &&res>-180.0)
19542 else if (res>=0.0 && res<180.0)
19545 res = mp_out(xo)-mp_out(xi);
19548 else if (res>180.0)
19553 return double2angle(res);
19557 @d p_nextnext mp_link(mp_link(p))
19558 @d p_next mp_link(p)
19559 @d seven_twenty_deg 05500000000 /* $720\cdot2^{20}$, represents $720^\circ$ */
19561 @<Declare unary action...@>=
19562 static scaled mp_new_turn_cycles (MP mp,pointer c) {
19563 angle res,ang; /* the angles of intermediate results */
19564 scaled turns; /* the turn counter */
19565 pointer p; /* for running around the path */
19566 integer xp,yp; /* coordinates of next point */
19567 integer x,y; /* helper coordinates */
19568 angle in_angle,out_angle; /* helper angles */
19569 unsigned old_setting; /* saved |selector| setting */
19573 old_setting = mp->selector; mp->selector=term_only;
19574 if ( mp->internal[mp_tracing_commands]>unity ) {
19575 mp_begin_diagnostic(mp);
19576 mp_print_nl(mp, "");
19577 mp_end_diagnostic(mp, false);
19580 xp = x_coord(p_next); yp = y_coord(p_next);
19581 ang = mp_bezier_slope(mp,x_coord(p), y_coord(p), right_x(p), right_y(p),
19582 left_x(p_next), left_y(p_next), xp, yp);
19583 if ( ang>seven_twenty_deg ) {
19584 print_err("Strange path");
19586 mp->selector=old_setting;
19590 if ( res > one_eighty_deg ) {
19591 res = res - three_sixty_deg;
19592 turns = turns + unity;
19594 if ( res <= -one_eighty_deg ) {
19595 res = res + three_sixty_deg;
19596 turns = turns - unity;
19598 /* incoming angle at next point */
19599 x = left_x(p_next); y = left_y(p_next);
19600 if ( (xp==x)&&(yp==y) ) { x = right_x(p); y = right_y(p); };
19601 if ( (xp==x)&&(yp==y) ) { x = x_coord(p); y = y_coord(p); };
19602 in_angle = mp_an_angle(mp, xp - x, yp - y);
19603 /* outgoing angle at next point */
19604 x = right_x(p_next); y = right_y(p_next);
19605 if ( (xp==x)&&(yp==y) ) { x = left_x(p_nextnext); y = left_y(p_nextnext); };
19606 if ( (xp==x)&&(yp==y) ) { x = x_coord(p_nextnext); y = y_coord(p_nextnext); };
19607 out_angle = mp_an_angle(mp, x - xp, y- yp);
19608 ang = (out_angle - in_angle);
19612 if ( res >= one_eighty_deg ) {
19613 res = res - three_sixty_deg;
19614 turns = turns + unity;
19616 if ( res <= -one_eighty_deg ) {
19617 res = res + three_sixty_deg;
19618 turns = turns - unity;
19623 mp->selector=old_setting;
19628 @ This code is based on Bogus\l{}av Jackowski's
19629 |emergency_turningnumber| macro, with some minor changes by Taco
19630 Hoekwater. The macro code looked more like this:
19632 vardef turning\_number primary p =
19633 ~~save res, ang, turns;
19635 ~~if length p <= 2:
19636 ~~~~if Angle ((point 0 of p) - (postcontrol 0 of p)) >= 0: 1 else: -1 fi
19638 ~~~~for t = 0 upto length p-1 :
19639 ~~~~~~angc := Angle ((point t+1 of p) - (point t of p))
19640 ~~~~~~~~- Angle ((point t of p) - (point t-1 of p));
19641 ~~~~~~if angc > 180: angc := angc - 360; fi;
19642 ~~~~~~if angc < -180: angc := angc + 360; fi;
19643 ~~~~~~res := res + angc;
19648 The general idea is to calculate only the sum of the angles of
19649 straight lines between the points, of a path, not worrying about cusps
19650 or self-intersections in the segments at all. If the segment is not
19651 well-behaved, the result is not necesarily correct. But the old code
19652 was not always correct either, and worse, it sometimes failed for
19653 well-behaved paths as well. All known bugs that were triggered by the
19654 original code no longer occur with this code, and it runs roughly 3
19655 times as fast because the algorithm is much simpler.
19657 @ It is possible to overflow the return value of the |turn_cycles|
19658 function when the path is sufficiently long and winding, but I am not
19659 going to bother testing for that. In any case, it would only return
19660 the looped result value, which is not a big problem.
19662 The macro code for the repeat loop was a bit nicer to look
19663 at than the pascal code, because it could use |point -1 of p|. In
19664 pascal, the fastest way to loop around the path is not to look
19665 backward once, but forward twice. These defines help hide the trick.
19667 @d p_to mp_link(mp_link(p))
19668 @d p_here mp_link(p)
19671 @<Declare unary action...@>=
19672 static scaled mp_turn_cycles (MP mp,pointer c) {
19673 angle res,ang; /* the angles of intermediate results */
19674 scaled turns; /* the turn counter */
19675 pointer p; /* for running around the path */
19676 res=0; turns= 0; p=c;
19678 ang = mp_an_angle (mp, x_coord(p_to) - x_coord(p_here),
19679 y_coord(p_to) - y_coord(p_here))
19680 - mp_an_angle (mp, x_coord(p_here) - x_coord(p_from),
19681 y_coord(p_here) - y_coord(p_from));
19684 if ( res >= three_sixty_deg ) {
19685 res = res - three_sixty_deg;
19686 turns = turns + unity;
19688 if ( res <= -three_sixty_deg ) {
19689 res = res + three_sixty_deg;
19690 turns = turns - unity;
19697 @ @<Declare unary action...@>=
19698 static scaled mp_turn_cycles_wrapper (MP mp,pointer c) {
19700 scaled saved_t_o; /* tracing\_online saved */
19701 if ( (mp_link(c)==c)||(mp_link(mp_link(c))==c) ) {
19702 if ( mp_an_angle (mp, x_coord(c) - right_x(c), y_coord(c) - right_y(c)) > 0 )
19707 nval = mp_new_turn_cycles(mp, c);
19708 oval = mp_turn_cycles(mp, c);
19709 if ( nval!=oval ) {
19710 saved_t_o=mp->internal[mp_tracing_online];
19711 mp->internal[mp_tracing_online]=unity;
19712 mp_begin_diagnostic(mp);
19713 mp_print_nl (mp, "Warning: the turningnumber algorithms do not agree."
19714 " The current computed value is ");
19715 mp_print_scaled(mp, nval);
19716 mp_print(mp, ", but the 'connect-the-dots' algorithm returned ");
19717 mp_print_scaled(mp, oval);
19718 mp_end_diagnostic(mp, false);
19719 mp->internal[mp_tracing_online]=saved_t_o;
19725 @ @d type_range(A,B) {
19726 if ( (mp->cur_type>=(A)) && (mp->cur_type<=(B)) )
19727 mp_flush_cur_exp(mp, true_code);
19728 else mp_flush_cur_exp(mp, false_code);
19729 mp->cur_type=mp_boolean_type;
19732 if ( mp->cur_type==(A) ) mp_flush_cur_exp(mp, true_code);
19733 else mp_flush_cur_exp(mp, false_code);
19734 mp->cur_type=mp_boolean_type;
19737 @<Additional cases of unary operators@>=
19738 case mp_boolean_type:
19739 type_range(mp_boolean_type,mp_unknown_boolean); break;
19740 case mp_string_type:
19741 type_range(mp_string_type,mp_unknown_string); break;
19743 type_range(mp_pen_type,mp_unknown_pen); break;
19745 type_range(mp_path_type,mp_unknown_path); break;
19746 case mp_picture_type:
19747 type_range(mp_picture_type,mp_unknown_picture); break;
19748 case mp_transform_type: case mp_color_type: case mp_cmykcolor_type:
19750 type_test(c); break;
19751 case mp_numeric_type:
19752 type_range(mp_known,mp_independent); break;
19753 case known_op: case unknown_op:
19754 mp_test_known(mp, c); break;
19756 @ @<Declare unary action procedures@>=
19757 static void mp_test_known (MP mp,quarterword c) {
19758 int b; /* is the current expression known? */
19759 pointer p,q; /* locations in a big node */
19761 switch (mp->cur_type) {
19762 case mp_vacuous: case mp_boolean_type: case mp_string_type:
19763 case mp_pen_type: case mp_path_type: case mp_picture_type:
19767 case mp_transform_type:
19768 case mp_color_type: case mp_cmykcolor_type: case mp_pair_type:
19769 p=value(mp->cur_exp);
19770 q=p+mp->big_node_size[mp->cur_type];
19773 if ( type(q)!=mp_known )
19782 if ( c==known_op ) mp_flush_cur_exp(mp, b);
19783 else mp_flush_cur_exp(mp, true_code+false_code-b);
19784 mp->cur_type=mp_boolean_type;
19787 @ @<Additional cases of unary operators@>=
19789 if ( mp->cur_type!=mp_path_type ) mp_flush_cur_exp(mp, false_code);
19790 else if ( left_type(mp->cur_exp)!=mp_endpoint ) mp_flush_cur_exp(mp, true_code);
19791 else mp_flush_cur_exp(mp, false_code);
19792 mp->cur_type=mp_boolean_type;
19795 @ @<Additional cases of unary operators@>=
19797 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19798 if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, arc_length);
19799 else mp_flush_cur_exp(mp, mp_get_arc_length(mp, mp->cur_exp));
19802 @ Here we use the fact that |c-filled_op+fill_code| is the desired graphical
19804 @^data structure assumptions@>
19806 @<Additional cases of unary operators@>=
19812 if ( mp->cur_type!=mp_picture_type ) mp_flush_cur_exp(mp, false_code);
19813 else if ( mp_link(dummy_loc(mp->cur_exp))==null ) mp_flush_cur_exp(mp, false_code);
19814 else if ( type(mp_link(dummy_loc(mp->cur_exp)))==c+mp_fill_code-filled_op )
19815 mp_flush_cur_exp(mp, true_code);
19816 else mp_flush_cur_exp(mp, false_code);
19817 mp->cur_type=mp_boolean_type;
19820 @ @<Additional cases of unary operators@>=
19822 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19823 if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, make_pen_op);
19825 mp->cur_type=mp_pen_type;
19826 mp->cur_exp=mp_make_pen(mp, mp->cur_exp,true);
19830 if ( mp->cur_type!=mp_pen_type ) mp_bad_unary(mp, make_path_op);
19832 mp->cur_type=mp_path_type;
19833 mp_make_path(mp, mp->cur_exp);
19837 if ( mp->cur_type==mp_path_type ) {
19838 p=mp_htap_ypoc(mp, mp->cur_exp);
19839 if ( right_type(p)==mp_endpoint ) p=mp_link(p);
19840 mp_toss_knot_list(mp, mp->cur_exp); mp->cur_exp=p;
19841 } else if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19842 else mp_bad_unary(mp, reverse);
19845 @ The |pair_value| routine changes the current expression to a
19846 given ordered pair of values.
19848 @<Declare unary action procedures@>=
19849 static void mp_pair_value (MP mp,scaled x, scaled y) {
19850 pointer p; /* a pair node */
19851 p=mp_get_node(mp, value_node_size);
19852 mp_flush_cur_exp(mp, p); mp->cur_type=mp_pair_type;
19853 type(p)=mp_pair_type; name_type(p)=mp_capsule; mp_init_big_node(mp, p);
19855 type(x_part_loc(p))=mp_known; value(x_part_loc(p))=x;
19856 type(y_part_loc(p))=mp_known; value(y_part_loc(p))=y;
19859 @ @<Additional cases of unary operators@>=
19861 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ll_corner_op);
19862 else mp_pair_value(mp, minx,miny);
19865 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, lr_corner_op);
19866 else mp_pair_value(mp, maxx,miny);
19869 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ul_corner_op);
19870 else mp_pair_value(mp, minx,maxy);
19873 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ur_corner_op);
19874 else mp_pair_value(mp, maxx,maxy);
19877 @ Here is a function that sets |minx|, |maxx|, |miny|, |maxy| to the bounding
19878 box of the current expression. The boolean result is |false| if the expression
19879 has the wrong type.
19881 @<Declare unary action procedures@>=
19882 static boolean mp_get_cur_bbox (MP mp) {
19883 switch (mp->cur_type) {
19884 case mp_picture_type:
19885 mp_set_bbox(mp, mp->cur_exp,true);
19886 if ( minx_val(mp->cur_exp)>maxx_val(mp->cur_exp) ) {
19887 minx=0; maxx=0; miny=0; maxy=0;
19889 minx=minx_val(mp->cur_exp);
19890 maxx=maxx_val(mp->cur_exp);
19891 miny=miny_val(mp->cur_exp);
19892 maxy=maxy_val(mp->cur_exp);
19896 mp_path_bbox(mp, mp->cur_exp);
19899 mp_pen_bbox(mp, mp->cur_exp);
19907 @ @<Additional cases of unary operators@>=
19909 case close_from_op:
19910 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, c);
19911 else mp_do_read_or_close(mp,c);
19914 @ Here is a routine that interprets |cur_exp| as a file name and tries to read
19915 a line from the file or to close the file.
19917 @<Declare unary action procedures@>=
19918 static void mp_do_read_or_close (MP mp,quarterword c) {
19919 readf_index n,n0; /* indices for searching |rd_fname| */
19920 @<Find the |n| where |rd_fname[n]=cur_exp|; if |cur_exp| must be inserted,
19921 call |start_read_input| and |goto found| or |not_found|@>;
19922 mp_begin_file_reading(mp);
19924 if ( mp_input_ln(mp, mp->rd_file[n] ) )
19926 mp_end_file_reading(mp);
19928 @<Record the end of file and set |cur_exp| to a dummy value@>;
19931 mp_flush_cur_exp(mp, 0); mp->cur_type=mp_vacuous;
19934 mp_flush_cur_exp(mp, 0);
19935 mp_finish_read(mp);
19938 @ Free slots in the |rd_file| and |rd_fname| arrays are marked with NULL's in
19941 @<Find the |n| where |rd_fname[n]=cur_exp|...@>=
19946 fn = str(mp->cur_exp);
19947 while (mp_xstrcmp(fn,mp->rd_fname[n])!=0) {
19950 } else if ( c==close_from_op ) {
19953 if ( n0==mp->read_files ) {
19954 if ( mp->read_files<mp->max_read_files ) {
19955 incr(mp->read_files);
19960 l = mp->max_read_files + (mp->max_read_files/4);
19961 rd_file = xmalloc((l+1), sizeof(void *));
19962 rd_fname = xmalloc((l+1), sizeof(char *));
19963 for (k=0;k<=l;k++) {
19964 if (k<=mp->max_read_files) {
19965 rd_file[k]=mp->rd_file[k];
19966 rd_fname[k]=mp->rd_fname[k];
19972 xfree(mp->rd_file); xfree(mp->rd_fname);
19973 mp->max_read_files = l;
19974 mp->rd_file = rd_file;
19975 mp->rd_fname = rd_fname;
19979 if ( mp_start_read_input(mp,fn,n) )
19984 if ( mp->rd_fname[n]==NULL ) { n0=n; }
19986 if ( c==close_from_op ) {
19987 (mp->close_file)(mp,mp->rd_file[n]);
19992 @ @<Record the end of file and set |cur_exp| to a dummy value@>=
19993 xfree(mp->rd_fname[n]);
19994 mp->rd_fname[n]=NULL;
19995 if ( n==mp->read_files-1 ) mp->read_files=n;
19996 if ( c==close_from_op )
19998 mp_flush_cur_exp(mp, mp->eof_line);
19999 mp->cur_type=mp_string_type
20001 @ The string denoting end-of-file is a one-byte string at position zero, by definition
20004 str_number eof_line;
20009 @ Finally, we have the operations that combine a capsule~|p|
20010 with the current expression.
20012 @d binary_return { mp_finish_binary(mp, old_p, old_exp); return; }
20014 @c @<Declare binary action procedures@>
20015 static void mp_finish_binary (MP mp, pointer old_p, pointer old_exp ){
20017 @<Recycle any sidestepped |independent| capsules@>;
20019 static void mp_do_binary (MP mp,pointer p, quarterword c) {
20020 pointer q,r,rr; /* for list manipulation */
20021 pointer old_p,old_exp; /* capsules to recycle */
20022 integer v; /* for numeric manipulation */
20024 if ( mp->internal[mp_tracing_commands]>two ) {
20025 @<Trace the current binary operation@>;
20027 @<Sidestep |independent| cases in capsule |p|@>;
20028 @<Sidestep |independent| cases in the current expression@>;
20030 case plus: case minus:
20031 @<Add or subtract the current expression from |p|@>;
20033 @<Additional cases of binary operators@>;
20034 }; /* there are no other cases */
20035 mp_recycle_value(mp, p);
20036 mp_free_node(mp, p,value_node_size); /* |return| to avoid this */
20037 mp_finish_binary(mp, old_p, old_exp);
20040 @ @<Declare binary action...@>=
20041 static void mp_bad_binary (MP mp,pointer p, quarterword c) {
20042 mp_disp_err(mp, p,"");
20043 exp_err("Not implemented: ");
20044 @.Not implemented...@>
20045 if ( c>=min_of ) mp_print_op(mp, c);
20046 mp_print_known_or_unknown_type(mp, type(p),p);
20047 if ( c>=min_of ) mp_print(mp, "of"); else mp_print_op(mp, c);
20048 mp_print_known_or_unknown_type(mp, mp->cur_type,mp->cur_exp);
20049 help3("I'm afraid I don't know how to apply that operation to that",
20050 "combination of types. Continue, and I'll return the second",
20051 "argument (see above) as the result of the operation.");
20052 mp_put_get_error(mp);
20054 static void mp_bad_envelope_pen (MP mp) {
20055 mp_disp_err(mp, null,"");
20056 exp_err("Not implemented: envelope(elliptical pen)of(path)");
20057 @.Not implemented...@>
20058 help3("I'm afraid I don't know how to apply that operation to that",
20059 "combination of types. Continue, and I'll return the second",
20060 "argument (see above) as the result of the operation.");
20061 mp_put_get_error(mp);
20064 @ @<Trace the current binary operation@>=
20066 mp_begin_diagnostic(mp); mp_print_nl(mp, "{(");
20067 mp_print_exp(mp,p,0); /* show the operand, but not verbosely */
20068 mp_print_char(mp,xord(')')); mp_print_op(mp,c); mp_print_char(mp,xord('('));
20069 mp_print_exp(mp,null,0); mp_print(mp,")}");
20070 mp_end_diagnostic(mp, false);
20073 @ Several of the binary operations are potentially complicated by the
20074 fact that |independent| values can sneak into capsules. For example,
20075 we've seen an instance of this difficulty in the unary operation
20076 of negation. In order to reduce the number of cases that need to be
20077 handled, we first change the two operands (if necessary)
20078 to rid them of |independent| components. The original operands are
20079 put into capsules called |old_p| and |old_exp|, which will be
20080 recycled after the binary operation has been safely carried out.
20082 @<Recycle any sidestepped |independent| capsules@>=
20083 if ( old_p!=null ) {
20084 mp_recycle_value(mp, old_p); mp_free_node(mp, old_p,value_node_size);
20086 if ( old_exp!=null ) {
20087 mp_recycle_value(mp, old_exp); mp_free_node(mp, old_exp,value_node_size);
20090 @ A big node is considered to be ``tarnished'' if it contains at least one
20091 independent component. We will define a simple function called `|tarnished|'
20092 that returns |null| if and only if its argument is not tarnished.
20094 @<Sidestep |independent| cases in capsule |p|@>=
20096 case mp_transform_type:
20097 case mp_color_type:
20098 case mp_cmykcolor_type:
20100 old_p=mp_tarnished(mp, p);
20102 case mp_independent: old_p=mp_void; break;
20103 default: old_p=null; break;
20105 if ( old_p!=null ) {
20106 q=mp_stash_cur_exp(mp); old_p=p; mp_make_exp_copy(mp, old_p);
20107 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q);
20110 @ @<Sidestep |independent| cases in the current expression@>=
20111 switch (mp->cur_type) {
20112 case mp_transform_type:
20113 case mp_color_type:
20114 case mp_cmykcolor_type:
20116 old_exp=mp_tarnished(mp, mp->cur_exp);
20118 case mp_independent:old_exp=mp_void; break;
20119 default: old_exp=null; break;
20121 if ( old_exp!=null ) {
20122 old_exp=mp->cur_exp; mp_make_exp_copy(mp, old_exp);
20125 @ @<Declare binary action...@>=
20126 static pointer mp_tarnished (MP mp,pointer p) {
20127 pointer q; /* beginning of the big node */
20128 pointer r; /* current position in the big node */
20129 q=value(p); r=q+mp->big_node_size[type(p)];
20132 if ( type(r)==mp_independent ) return mp_void;
20137 @ @<Add or subtract the current expression from |p|@>=
20138 if ( (mp->cur_type<mp_color_type)||(type(p)<mp_color_type) ) {
20139 mp_bad_binary(mp, p,c);
20141 if ((mp->cur_type>mp_pair_type)&&(type(p)>mp_pair_type) ) {
20142 mp_add_or_subtract(mp, p,null,c);
20144 if ( mp->cur_type!=type(p) ) {
20145 mp_bad_binary(mp, p,c);
20147 q=value(p); r=value(mp->cur_exp);
20148 rr=r+mp->big_node_size[mp->cur_type];
20150 mp_add_or_subtract(mp, q,r,c);
20157 @ The first argument to |add_or_subtract| is the location of a value node
20158 in a capsule or pair node that will soon be recycled. The second argument
20159 is either a location within a pair or transform node of |cur_exp|,
20160 or it is null (which means that |cur_exp| itself should be the second
20161 argument). The third argument is either |plus| or |minus|.
20163 The sum or difference of the numeric quantities will replace the second
20164 operand. Arithmetic overflow may go undetected; users aren't supposed to
20165 be monkeying around with really big values.
20166 @^overflow in arithmetic@>
20168 @<Declare binary action...@>=
20169 @<Declare the procedure called |dep_finish|@>
20170 static void mp_add_or_subtract (MP mp,pointer p, pointer q, quarterword c) {
20171 quarterword s,t; /* operand types */
20172 pointer r; /* list traverser */
20173 integer v; /* second operand value */
20176 if ( t<mp_dependent ) v=mp->cur_exp; else v=dep_list(mp->cur_exp);
20179 if ( t<mp_dependent ) v=value(q); else v=dep_list(q);
20181 if ( t==mp_known ) {
20182 if ( c==minus ) negate(v);
20183 if ( type(p)==mp_known ) {
20184 v=mp_slow_add(mp, value(p),v);
20185 if ( q==null ) mp->cur_exp=v; else value(q)=v;
20188 @<Add a known value to the constant term of |dep_list(p)|@>;
20190 if ( c==minus ) mp_negate_dep_list(mp, v);
20191 @<Add operand |p| to the dependency list |v|@>;
20195 @ @<Add a known value to the constant term of |dep_list(p)|@>=
20197 while ( info(r)!=null ) r=mp_link(r);
20198 value(r)=mp_slow_add(mp, value(r),v);
20200 q=mp_get_node(mp, value_node_size); mp->cur_exp=q; mp->cur_type=type(p);
20201 name_type(q)=mp_capsule;
20203 dep_list(q)=dep_list(p); type(q)=type(p);
20204 prev_dep(q)=prev_dep(p); mp_link(prev_dep(p))=q;
20205 type(p)=mp_known; /* this will keep the recycler from collecting non-garbage */
20207 @ We prefer |dependent| lists to |mp_proto_dependent| ones, because it is
20208 nice to retain the extra accuracy of |fraction| coefficients.
20209 But we have to handle both kinds, and mixtures too.
20211 @<Add operand |p| to the dependency list |v|@>=
20212 if ( type(p)==mp_known ) {
20213 @<Add the known |value(p)| to the constant term of |v|@>;
20215 s=type(p); r=dep_list(p);
20216 if ( t==mp_dependent ) {
20217 if ( s==mp_dependent ) {
20218 if ( mp_max_coef(mp, r)+mp_max_coef(mp, v)<coef_bound )
20219 v=mp_p_plus_q(mp, v,r,mp_dependent); goto DONE;
20220 } /* |fix_needed| will necessarily be false */
20221 t=mp_proto_dependent;
20222 v=mp_p_over_v(mp, v,unity,mp_dependent,mp_proto_dependent);
20224 if ( s==mp_proto_dependent ) v=mp_p_plus_q(mp, v,r,mp_proto_dependent);
20225 else v=mp_p_plus_fq(mp, v,unity,r,mp_proto_dependent,mp_dependent);
20227 @<Output the answer, |v| (which might have become |known|)@>;
20230 @ @<Add the known |value(p)| to the constant term of |v|@>=
20232 while ( info(v)!=null ) v=mp_link(v);
20233 value(v)=mp_slow_add(mp, value(p),value(v));
20236 @ @<Output the answer, |v| (which might have become |known|)@>=
20237 if ( q!=null ) mp_dep_finish(mp, v,q,t);
20238 else { mp->cur_type=t; mp_dep_finish(mp, v,null,t); }
20240 @ Here's the current situation: The dependency list |v| of type |t|
20241 should either be put into the current expression (if |q=null|) or
20242 into location |q| within a pair node (otherwise). The destination (|cur_exp|
20243 or |q|) formerly held a dependency list with the same
20244 final pointer as the list |v|.
20246 @<Declare the procedure called |dep_finish|@>=
20247 static void mp_dep_finish (MP mp, pointer v, pointer q, quarterword t) {
20248 pointer p; /* the destination */
20249 scaled vv; /* the value, if it is |known| */
20250 if ( q==null ) p=mp->cur_exp; else p=q;
20251 dep_list(p)=v; type(p)=t;
20252 if ( info(v)==null ) {
20255 mp_flush_cur_exp(mp, vv);
20257 mp_recycle_value(mp, p); type(q)=mp_known; value(q)=vv;
20259 } else if ( q==null ) {
20262 if ( mp->fix_needed ) mp_fix_dependencies(mp);
20265 @ Let's turn now to the six basic relations of comparison.
20267 @<Additional cases of binary operators@>=
20268 case less_than: case less_or_equal: case greater_than:
20269 case greater_or_equal: case equal_to: case unequal_to:
20270 check_arith; /* at this point |arith_error| should be |false|? */
20271 if ( (mp->cur_type>mp_pair_type)&&(type(p)>mp_pair_type) ) {
20272 mp_add_or_subtract(mp, p,null,minus); /* |cur_exp:=(p)-cur_exp| */
20273 } else if ( mp->cur_type!=type(p) ) {
20274 mp_bad_binary(mp, p,c); goto DONE;
20275 } else if ( mp->cur_type==mp_string_type ) {
20276 mp_flush_cur_exp(mp, mp_str_vs_str(mp, value(p),mp->cur_exp));
20277 } else if ((mp->cur_type==mp_unknown_string)||
20278 (mp->cur_type==mp_unknown_boolean) ) {
20279 @<Check if unknowns have been equated@>;
20280 } else if ( (mp->cur_type<=mp_pair_type)&&(mp->cur_type>=mp_transform_type)) {
20281 @<Reduce comparison of big nodes to comparison of scalars@>;
20282 } else if ( mp->cur_type==mp_boolean_type ) {
20283 mp_flush_cur_exp(mp, mp->cur_exp-value(p));
20285 mp_bad_binary(mp, p,c); goto DONE;
20287 @<Compare the current expression with zero@>;
20289 mp->arith_error=false; /* ignore overflow in comparisons */
20292 @ @<Compare the current expression with zero@>=
20293 if ( mp->cur_type!=mp_known ) {
20294 if ( mp->cur_type<mp_known ) {
20295 mp_disp_err(mp, p,"");
20296 help1("The quantities shown above have not been equated.")
20298 help2("Oh dear. I can\'t decide if the expression above is positive,",
20299 "negative, or zero. So this comparison test won't be `true'.");
20301 exp_err("Unknown relation will be considered false");
20302 @.Unknown relation...@>
20303 mp_put_get_flush_error(mp, false_code);
20306 case less_than: boolean_reset(mp->cur_exp<0); break;
20307 case less_or_equal: boolean_reset(mp->cur_exp<=0); break;
20308 case greater_than: boolean_reset(mp->cur_exp>0); break;
20309 case greater_or_equal: boolean_reset(mp->cur_exp>=0); break;
20310 case equal_to: boolean_reset(mp->cur_exp==0); break;
20311 case unequal_to: boolean_reset(mp->cur_exp!=0); break;
20312 }; /* there are no other cases */
20314 mp->cur_type=mp_boolean_type
20316 @ When two unknown strings are in the same ring, we know that they are
20317 equal. Otherwise, we don't know whether they are equal or not, so we
20320 @<Check if unknowns have been equated@>=
20322 q=value(mp->cur_exp);
20323 while ( (q!=mp->cur_exp)&&(q!=p) ) q=value(q);
20324 if ( q==p ) mp_flush_cur_exp(mp, 0);
20327 @ @<Reduce comparison of big nodes to comparison of scalars@>=
20329 q=value(p); r=value(mp->cur_exp);
20330 rr=r+mp->big_node_size[mp->cur_type]-2;
20331 while (1) { mp_add_or_subtract(mp, q,r,minus);
20332 if ( type(r)!=mp_known ) break;
20333 if ( value(r)!=0 ) break;
20334 if ( r==rr ) break;
20337 mp_take_part(mp, name_type(r)+x_part-mp_x_part_sector);
20340 @ Here we use the sneaky fact that |and_op-false_code=or_op-true_code|.
20342 @<Additional cases of binary operators@>=
20345 if ( (type(p)!=mp_boolean_type)||(mp->cur_type!=mp_boolean_type) )
20346 mp_bad_binary(mp, p,c);
20347 else if ( value(p)==c+false_code-and_op ) mp->cur_exp=value(p);
20350 @ @<Additional cases of binary operators@>=
20352 if ( (mp->cur_type<mp_color_type)||(type(p)<mp_color_type) ) {
20353 mp_bad_binary(mp, p,times);
20354 } else if ( (mp->cur_type==mp_known)||(type(p)==mp_known) ) {
20355 @<Multiply when at least one operand is known@>;
20356 } else if ( (mp_nice_color_or_pair(mp, p,type(p))&&(mp->cur_type>mp_pair_type))
20357 ||(mp_nice_color_or_pair(mp, mp->cur_exp,mp->cur_type)&&
20358 (type(p)>mp_pair_type)) ) {
20359 mp_hard_times(mp, p);
20362 mp_bad_binary(mp, p,times);
20366 @ @<Multiply when at least one operand is known@>=
20368 if ( type(p)==mp_known ) {
20369 v=value(p); mp_free_node(mp, p,value_node_size);
20371 v=mp->cur_exp; mp_unstash_cur_exp(mp, p);
20373 if ( mp->cur_type==mp_known ) {
20374 mp->cur_exp=mp_take_scaled(mp, mp->cur_exp,v);
20375 } else if ( (mp->cur_type==mp_pair_type)||
20376 (mp->cur_type==mp_color_type)||
20377 (mp->cur_type==mp_cmykcolor_type) ) {
20378 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20380 p=p-2; mp_dep_mult(mp, p,v,true);
20381 } while (p!=value(mp->cur_exp));
20383 mp_dep_mult(mp, null,v,true);
20388 @ @<Declare binary action...@>=
20389 static void mp_dep_mult (MP mp,pointer p, integer v, boolean v_is_scaled) {
20390 pointer q; /* the dependency list being multiplied by |v| */
20391 quarterword s,t; /* its type, before and after */
20394 } else if ( type(p)!=mp_known ) {
20397 if ( v_is_scaled ) value(p)=mp_take_scaled(mp, value(p),v);
20398 else value(p)=mp_take_fraction(mp, value(p),v);
20401 t=type(q); q=dep_list(q); s=t;
20402 if ( t==mp_dependent ) if ( v_is_scaled )
20403 if (mp_ab_vs_cd(mp, mp_max_coef(mp,q),abs(v),coef_bound-1,unity)>=0 )
20404 t=mp_proto_dependent;
20405 q=mp_p_times_v(mp, q,v,s,t,v_is_scaled);
20406 mp_dep_finish(mp, q,p,t);
20409 @ Here is a routine that is similar to |times|; but it is invoked only
20410 internally, when |v| is a |fraction| whose magnitude is at most~1,
20411 and when |cur_type>=mp_color_type|.
20414 static void mp_frac_mult (MP mp,scaled n, scaled d) {
20415 /* multiplies |cur_exp| by |n/d| */
20416 pointer p; /* a pair node */
20417 pointer old_exp; /* a capsule to recycle */
20418 fraction v; /* |n/d| */
20419 if ( mp->internal[mp_tracing_commands]>two ) {
20420 @<Trace the fraction multiplication@>;
20422 switch (mp->cur_type) {
20423 case mp_transform_type:
20424 case mp_color_type:
20425 case mp_cmykcolor_type:
20427 old_exp=mp_tarnished(mp, mp->cur_exp);
20429 case mp_independent: old_exp=mp_void; break;
20430 default: old_exp=null; break;
20432 if ( old_exp!=null ) {
20433 old_exp=mp->cur_exp; mp_make_exp_copy(mp, old_exp);
20435 v=mp_make_fraction(mp, n,d);
20436 if ( mp->cur_type==mp_known ) {
20437 mp->cur_exp=mp_take_fraction(mp, mp->cur_exp,v);
20438 } else if ( mp->cur_type<=mp_pair_type ) {
20439 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20442 mp_dep_mult(mp, p,v,false);
20443 } while (p!=value(mp->cur_exp));
20445 mp_dep_mult(mp, null,v,false);
20447 if ( old_exp!=null ) {
20448 mp_recycle_value(mp, old_exp);
20449 mp_free_node(mp, old_exp,value_node_size);
20453 @ @<Trace the fraction multiplication@>=
20455 mp_begin_diagnostic(mp);
20456 mp_print_nl(mp, "{("); mp_print_scaled(mp,n); mp_print_char(mp,xord('/'));
20457 mp_print_scaled(mp,d); mp_print(mp,")*("); mp_print_exp(mp,null,0);
20459 mp_end_diagnostic(mp, false);
20462 @ The |hard_times| routine multiplies a nice color or pair by a dependency list.
20464 @<Declare binary action procedures@>=
20465 static void mp_hard_times (MP mp,pointer p) {
20466 pointer q; /* a copy of the dependent variable |p| */
20467 pointer r; /* a component of the big node for the nice color or pair */
20468 scaled v; /* the known value for |r| */
20469 if ( type(p)<=mp_pair_type ) {
20470 q=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, p); p=q;
20471 }; /* now |cur_type=mp_pair_type| or |cur_type=mp_color_type| */
20472 r=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20477 if ( r==value(mp->cur_exp) )
20479 mp_new_dep(mp, r,mp_copy_dep_list(mp, dep_list(p)));
20480 mp_dep_mult(mp, r,v,true);
20482 mp->mem[value_loc(r)]=mp->mem[value_loc(p)];
20483 mp_link(prev_dep(p))=r;
20484 mp_free_node(mp, p,value_node_size);
20485 mp_dep_mult(mp, r,v,true);
20488 @ @<Additional cases of binary operators@>=
20490 if ( (mp->cur_type!=mp_known)||(type(p)<mp_color_type) ) {
20491 mp_bad_binary(mp, p,over);
20493 v=mp->cur_exp; mp_unstash_cur_exp(mp, p);
20495 @<Squeal about division by zero@>;
20497 if ( mp->cur_type==mp_known ) {
20498 mp->cur_exp=mp_make_scaled(mp, mp->cur_exp,v);
20499 } else if ( mp->cur_type<=mp_pair_type ) {
20500 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20502 p=p-2; mp_dep_div(mp, p,v);
20503 } while (p!=value(mp->cur_exp));
20505 mp_dep_div(mp, null,v);
20512 @ @<Declare binary action...@>=
20513 static void mp_dep_div (MP mp,pointer p, scaled v) {
20514 pointer q; /* the dependency list being divided by |v| */
20515 quarterword s,t; /* its type, before and after */
20516 if ( p==null ) q=mp->cur_exp;
20517 else if ( type(p)!=mp_known ) q=p;
20518 else { value(p)=mp_make_scaled(mp, value(p),v); return; };
20519 t=type(q); q=dep_list(q); s=t;
20520 if ( t==mp_dependent )
20521 if ( mp_ab_vs_cd(mp, mp_max_coef(mp,q),unity,coef_bound-1,abs(v))>=0 )
20522 t=mp_proto_dependent;
20523 q=mp_p_over_v(mp, q,v,s,t);
20524 mp_dep_finish(mp, q,p,t);
20527 @ @<Squeal about division by zero@>=
20529 exp_err("Division by zero");
20530 @.Division by zero@>
20531 help2("You're trying to divide the quantity shown above the error",
20532 "message by zero. I'm going to divide it by one instead.");
20533 mp_put_get_error(mp);
20536 @ @<Additional cases of binary operators@>=
20539 if ( (mp->cur_type==mp_known)&&(type(p)==mp_known) ) {
20540 if ( c==pythag_add ) mp->cur_exp=mp_pyth_add(mp, value(p),mp->cur_exp);
20541 else mp->cur_exp=mp_pyth_sub(mp, value(p),mp->cur_exp);
20542 } else mp_bad_binary(mp, p,c);
20545 @ The next few sections of the program deal with affine transformations
20546 of coordinate data.
20548 @<Additional cases of binary operators@>=
20549 case rotated_by: case slanted_by:
20550 case scaled_by: case shifted_by: case transformed_by:
20551 case x_scaled: case y_scaled: case z_scaled:
20552 if ( type(p)==mp_path_type ) {
20553 path_trans(c,p); binary_return;
20554 } else if ( type(p)==mp_pen_type ) {
20556 mp->cur_exp=mp_convex_hull(mp, mp->cur_exp);
20557 /* rounding error could destroy convexity */
20559 } else if ( (type(p)==mp_pair_type)||(type(p)==mp_transform_type) ) {
20560 mp_big_trans(mp, p,c);
20561 } else if ( type(p)==mp_picture_type ) {
20562 mp_do_edges_trans(mp, p,c); binary_return;
20564 mp_bad_binary(mp, p,c);
20568 @ Let |c| be one of the eight transform operators. The procedure call
20569 |set_up_trans(c)| first changes |cur_exp| to a transform that corresponds to
20570 |c| and the original value of |cur_exp|. (In particular, |cur_exp| doesn't
20571 change at all if |c=transformed_by|.)
20573 Then, if all components of the resulting transform are |known|, they are
20574 moved to the global variables |txx|, |txy|, |tyx|, |tyy|, |tx|, |ty|;
20575 and |cur_exp| is changed to the known value zero.
20577 @<Declare binary action...@>=
20578 static void mp_set_up_trans (MP mp,quarterword c) {
20579 pointer p,q,r; /* list manipulation registers */
20580 if ( (c!=transformed_by)||(mp->cur_type!=mp_transform_type) ) {
20581 @<Put the current transform into |cur_exp|@>;
20583 @<If the current transform is entirely known, stash it in global variables;
20584 otherwise |return|@>;
20593 scaled ty; /* current transform coefficients */
20595 @ @<Put the current transform...@>=
20597 p=mp_stash_cur_exp(mp);
20598 mp->cur_exp=mp_id_transform(mp);
20599 mp->cur_type=mp_transform_type;
20600 q=value(mp->cur_exp);
20602 @<For each of the eight cases, change the relevant fields of |cur_exp|
20604 but do nothing if capsule |p| doesn't have the appropriate type@>;
20605 }; /* there are no other cases */
20606 mp_disp_err(mp, p,"Improper transformation argument");
20607 @.Improper transformation argument@>
20608 help3("The expression shown above has the wrong type,",
20609 "so I can\'t transform anything using it.",
20610 "Proceed, and I'll omit the transformation.");
20611 mp_put_get_error(mp);
20613 mp_recycle_value(mp, p);
20614 mp_free_node(mp, p,value_node_size);
20617 @ @<If the current transform is entirely known, ...@>=
20618 q=value(mp->cur_exp); r=q+transform_node_size;
20621 if ( type(r)!=mp_known ) return;
20623 mp->txx=value(xx_part_loc(q));
20624 mp->txy=value(xy_part_loc(q));
20625 mp->tyx=value(yx_part_loc(q));
20626 mp->tyy=value(yy_part_loc(q));
20627 mp->tx=value(x_part_loc(q));
20628 mp->ty=value(y_part_loc(q));
20629 mp_flush_cur_exp(mp, 0)
20631 @ @<For each of the eight cases...@>=
20633 if ( type(p)==mp_known )
20634 @<Install sines and cosines, then |goto done|@>;
20637 if ( type(p)>mp_pair_type ) {
20638 mp_install(mp, xy_part_loc(q),p); goto DONE;
20642 if ( type(p)>mp_pair_type ) {
20643 mp_install(mp, xx_part_loc(q),p); mp_install(mp, yy_part_loc(q),p);
20648 if ( type(p)==mp_pair_type ) {
20649 r=value(p); mp_install(mp, x_part_loc(q),x_part_loc(r));
20650 mp_install(mp, y_part_loc(q),y_part_loc(r)); goto DONE;
20654 if ( type(p)>mp_pair_type ) {
20655 mp_install(mp, xx_part_loc(q),p); goto DONE;
20659 if ( type(p)>mp_pair_type ) {
20660 mp_install(mp, yy_part_loc(q),p); goto DONE;
20664 if ( type(p)==mp_pair_type )
20665 @<Install a complex multiplier, then |goto done|@>;
20667 case transformed_by:
20671 @ @<Install sines and cosines, then |goto done|@>=
20672 { mp_n_sin_cos(mp, (value(p) % three_sixty_units)*16);
20673 value(xx_part_loc(q))=mp_round_fraction(mp, mp->n_cos);
20674 value(yx_part_loc(q))=mp_round_fraction(mp, mp->n_sin);
20675 value(xy_part_loc(q))=-value(yx_part_loc(q));
20676 value(yy_part_loc(q))=value(xx_part_loc(q));
20680 @ @<Install a complex multiplier, then |goto done|@>=
20683 mp_install(mp, xx_part_loc(q),x_part_loc(r));
20684 mp_install(mp, yy_part_loc(q),x_part_loc(r));
20685 mp_install(mp, yx_part_loc(q),y_part_loc(r));
20686 if ( type(y_part_loc(r))==mp_known ) negate(value(y_part_loc(r)));
20687 else mp_negate_dep_list(mp, dep_list(y_part_loc(r)));
20688 mp_install(mp, xy_part_loc(q),y_part_loc(r));
20692 @ Procedure |set_up_known_trans| is like |set_up_trans|, but it
20693 insists that the transformation be entirely known.
20695 @<Declare binary action...@>=
20696 static void mp_set_up_known_trans (MP mp,quarterword c) {
20697 mp_set_up_trans(mp, c);
20698 if ( mp->cur_type!=mp_known ) {
20699 exp_err("Transform components aren't all known");
20700 @.Transform components...@>
20701 help3("I'm unable to apply a partially specified transformation",
20702 "except to a fully known pair or transform.",
20703 "Proceed, and I'll omit the transformation.");
20704 mp_put_get_flush_error(mp, 0);
20705 mp->txx=unity; mp->txy=0; mp->tyx=0; mp->tyy=unity;
20706 mp->tx=0; mp->ty=0;
20710 @ Here's a procedure that applies the transform |txx..ty| to a pair of
20711 coordinates in locations |p| and~|q|.
20713 @<Declare binary action...@>=
20714 static void mp_trans (MP mp,pointer p, pointer q) {
20715 scaled v; /* the new |x| value */
20716 v=mp_take_scaled(mp, mp->mem[p].sc,mp->txx)+
20717 mp_take_scaled(mp, mp->mem[q].sc,mp->txy)+mp->tx;
20718 mp->mem[q].sc=mp_take_scaled(mp, mp->mem[p].sc,mp->tyx)+
20719 mp_take_scaled(mp, mp->mem[q].sc,mp->tyy)+mp->ty;
20723 @ The simplest transformation procedure applies a transform to all
20724 coordinates of a path. The |path_trans(c)(p)| macro applies
20725 a transformation defined by |cur_exp| and the transform operator |c|
20728 @d path_trans(A,B) { mp_set_up_known_trans(mp, (A));
20729 mp_unstash_cur_exp(mp, (B));
20730 mp_do_path_trans(mp, mp->cur_exp); }
20732 @<Declare binary action...@>=
20733 static void mp_do_path_trans (MP mp,pointer p) {
20734 pointer q; /* list traverser */
20737 if ( left_type(q)!=mp_endpoint )
20738 mp_trans(mp, q+3,q+4); /* that's |left_x| and |left_y| */
20739 mp_trans(mp, q+1,q+2); /* that's |x_coord| and |y_coord| */
20740 if ( right_type(q)!=mp_endpoint )
20741 mp_trans(mp, q+5,q+6); /* that's |right_x| and |right_y| */
20742 @^data structure assumptions@>
20747 @ Transforming a pen is very similar, except that there are no |left_type|
20748 and |right_type| fields.
20750 @d pen_trans(A,B) { mp_set_up_known_trans(mp, (A));
20751 mp_unstash_cur_exp(mp, (B));
20752 mp_do_pen_trans(mp, mp->cur_exp); }
20754 @<Declare binary action...@>=
20755 static void mp_do_pen_trans (MP mp,pointer p) {
20756 pointer q; /* list traverser */
20757 if ( pen_is_elliptical(p) ) {
20758 mp_trans(mp, p+3,p+4); /* that's |left_x| and |left_y| */
20759 mp_trans(mp, p+5,p+6); /* that's |right_x| and |right_y| */
20763 mp_trans(mp, q+1,q+2); /* that's |x_coord| and |y_coord| */
20764 @^data structure assumptions@>
20769 @ The next transformation procedure applies to edge structures. It will do
20770 any transformation, but the results may be substandard if the picture contains
20771 text that uses downloaded bitmap fonts. The binary action procedure is
20772 |do_edges_trans|, but we also need a function that just scales a picture.
20773 That routine is |scale_edges|. Both it and the underlying routine |edges_trans|
20774 should be thought of as procedures that update an edge structure |h|, except
20775 that they have to return a (possibly new) structure because of the need to call
20778 @<Declare binary action...@>=
20779 static pointer mp_edges_trans (MP mp, pointer h) {
20780 pointer q; /* the object being transformed */
20781 pointer r,s; /* for list manipulation */
20782 scaled sx,sy; /* saved transformation parameters */
20783 scaled sqdet; /* square root of determinant for |dash_scale| */
20784 integer sgndet; /* sign of the determinant */
20785 scaled v; /* a temporary value */
20786 h=mp_private_edges(mp, h);
20787 sqdet=mp_sqrt_det(mp, mp->txx,mp->txy,mp->tyx,mp->tyy);
20788 sgndet=mp_ab_vs_cd(mp, mp->txx,mp->tyy,mp->txy,mp->tyx);
20789 if ( dash_list(h)!=null_dash ) {
20790 @<Try to transform the dash list of |h|@>;
20792 @<Make the bounding box of |h| unknown if it can't be updated properly
20793 without scanning the whole structure@>;
20794 q=mp_link(dummy_loc(h));
20795 while ( q!=null ) {
20796 @<Transform graphical object |q|@>;
20801 static void mp_do_edges_trans (MP mp,pointer p, quarterword c) {
20802 mp_set_up_known_trans(mp, c);
20803 value(p)=mp_edges_trans(mp, value(p));
20804 mp_unstash_cur_exp(mp, p);
20806 static void mp_scale_edges (MP mp) {
20807 mp->txx=mp->se_sf; mp->tyy=mp->se_sf;
20808 mp->txy=0; mp->tyx=0; mp->tx=0; mp->ty=0;
20809 mp->se_pic=mp_edges_trans(mp, mp->se_pic);
20812 @ @<Try to transform the dash list of |h|@>=
20813 if ( (mp->txy!=0)||(mp->tyx!=0)||
20814 (mp->ty!=0)||(abs(mp->txx)!=abs(mp->tyy))) {
20815 mp_flush_dash_list(mp, h);
20817 if ( mp->txx<0 ) { @<Reverse the dash list of |h|@>; }
20818 @<Scale the dash list by |txx| and shift it by |tx|@>;
20819 dash_y(h)=mp_take_scaled(mp, dash_y(h),abs(mp->tyy));
20822 @ @<Reverse the dash list of |h|@>=
20825 dash_list(h)=null_dash;
20826 while ( r!=null_dash ) {
20828 v=start_x(s); start_x(s)=stop_x(s); stop_x(s)=v;
20829 mp_link(s)=dash_list(h);
20834 @ @<Scale the dash list by |txx| and shift it by |tx|@>=
20836 while ( r!=null_dash ) {
20837 start_x(r)=mp_take_scaled(mp, start_x(r),mp->txx)+mp->tx;
20838 stop_x(r)=mp_take_scaled(mp, stop_x(r),mp->txx)+mp->tx;
20842 @ @<Make the bounding box of |h| unknown if it can't be updated properly...@>=
20843 if ( (mp->txx==0)&&(mp->tyy==0) ) {
20844 @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>;
20845 } else if ( (mp->txy!=0)||(mp->tyx!=0) ) {
20846 mp_init_bbox(mp, h);
20849 if ( minx_val(h)<=maxx_val(h) ) {
20850 @<Scale the bounding box by |txx+txy| and |tyx+tyy|; then shift by
20857 @ @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>=
20859 v=minx_val(h); minx_val(h)=miny_val(h); miny_val(h)=v;
20860 v=maxx_val(h); maxx_val(h)=maxy_val(h); maxy_val(h)=v;
20863 @ The sum ``|txx+txy|'' is whichever of |txx| or |txy| is nonzero. The other
20866 @<Scale the bounding box by |txx+txy| and |tyx+tyy|; then shift...@>=
20868 minx_val(h)=mp_take_scaled(mp, minx_val(h),mp->txx+mp->txy)+mp->tx;
20869 maxx_val(h)=mp_take_scaled(mp, maxx_val(h),mp->txx+mp->txy)+mp->tx;
20870 miny_val(h)=mp_take_scaled(mp, miny_val(h),mp->tyx+mp->tyy)+mp->ty;
20871 maxy_val(h)=mp_take_scaled(mp, maxy_val(h),mp->tyx+mp->tyy)+mp->ty;
20872 if ( mp->txx+mp->txy<0 ) {
20873 v=minx_val(h); minx_val(h)=maxx_val(h); maxx_val(h)=v;
20875 if ( mp->tyx+mp->tyy<0 ) {
20876 v=miny_val(h); miny_val(h)=maxy_val(h); maxy_val(h)=v;
20880 @ Now we ready for the main task of transforming the graphical objects in edge
20883 @<Transform graphical object |q|@>=
20885 case mp_fill_code: case mp_stroked_code:
20886 mp_do_path_trans(mp, path_p(q));
20887 @<Transform |pen_p(q)|, making sure polygonal pens stay counter-clockwise@>;
20889 case mp_start_clip_code: case mp_start_bounds_code:
20890 mp_do_path_trans(mp, path_p(q));
20894 @<Transform the compact transformation starting at |r|@>;
20896 case mp_stop_clip_code: case mp_stop_bounds_code:
20898 } /* there are no other cases */
20900 @ Note that the shift parameters |(tx,ty)| apply only to the path being stroked.
20901 The |dash_scale| has to be adjusted to scale the dash lengths in |dash_p(q)|
20902 since the \ps\ output procedures will try to compensate for the transformation
20903 we are applying to |pen_p(q)|. Since this compensation is based on the square
20904 root of the determinant, |sqdet| is the appropriate factor.
20906 @<Transform |pen_p(q)|, making sure...@>=
20907 if ( pen_p(q)!=null ) {
20908 sx=mp->tx; sy=mp->ty;
20909 mp->tx=0; mp->ty=0;
20910 mp_do_pen_trans(mp, pen_p(q));
20911 if ( ((type(q)==mp_stroked_code)&&(dash_p(q)!=null)) )
20912 dash_scale(q)=mp_take_scaled(mp, dash_scale(q),sqdet);
20913 if ( ! pen_is_elliptical(pen_p(q)) )
20915 pen_p(q)=mp_make_pen(mp, mp_copy_path(mp, pen_p(q)),true);
20916 /* this unreverses the pen */
20917 mp->tx=sx; mp->ty=sy;
20920 @ This uses the fact that transformations are stored in the order
20921 |(tx,ty,txx,txy,tyx,tyy)|.
20922 @^data structure assumptions@>
20924 @<Transform the compact transformation starting at |r|@>=
20925 mp_trans(mp, r,r+1);
20926 sx=mp->tx; sy=mp->ty;
20927 mp->tx=0; mp->ty=0;
20928 mp_trans(mp, r+2,r+4);
20929 mp_trans(mp, r+3,r+5);
20930 mp->tx=sx; mp->ty=sy
20932 @ The hard cases of transformation occur when big nodes are involved,
20933 and when some of their components are unknown.
20935 @<Declare binary action...@>=
20936 @<Declare subroutines needed by |big_trans|@>
20937 static void mp_big_trans (MP mp,pointer p, quarterword c) {
20938 pointer q,r,pp,qq; /* list manipulation registers */
20939 quarterword s; /* size of a big node */
20940 s=mp->big_node_size[type(p)]; q=value(p); r=q+s;
20943 if ( type(r)!=mp_known ) {
20944 @<Transform an unknown big node and |return|@>;
20947 @<Transform a known big node@>;
20948 } /* node |p| will now be recycled by |do_binary| */
20950 @ @<Transform an unknown big node and |return|@>=
20952 mp_set_up_known_trans(mp, c); mp_make_exp_copy(mp, p);
20953 r=value(mp->cur_exp);
20954 if ( mp->cur_type==mp_transform_type ) {
20955 mp_bilin1(mp, yy_part_loc(r),mp->tyy,xy_part_loc(q),mp->tyx,0);
20956 mp_bilin1(mp, yx_part_loc(r),mp->tyy,xx_part_loc(q),mp->tyx,0);
20957 mp_bilin1(mp, xy_part_loc(r),mp->txx,yy_part_loc(q),mp->txy,0);
20958 mp_bilin1(mp, xx_part_loc(r),mp->txx,yx_part_loc(q),mp->txy,0);
20960 mp_bilin1(mp, y_part_loc(r),mp->tyy,x_part_loc(q),mp->tyx,mp->ty);
20961 mp_bilin1(mp, x_part_loc(r),mp->txx,y_part_loc(q),mp->txy,mp->tx);
20965 @ Let |p| point to a two-word value field inside a big node of |cur_exp|,
20966 and let |q| point to a another value field. The |bilin1| procedure
20967 replaces |p| by $p\cdot t+q\cdot u+\delta$.
20969 @<Declare subroutines needed by |big_trans|@>=
20970 static void mp_bilin1 (MP mp, pointer p, scaled t, pointer q,
20971 scaled u, scaled delta) {
20972 pointer r; /* list traverser */
20973 if ( t!=unity ) mp_dep_mult(mp, p,t,true);
20975 if ( type(q)==mp_known ) {
20976 delta+=mp_take_scaled(mp, value(q),u);
20978 @<Ensure that |type(p)=mp_proto_dependent|@>;
20979 dep_list(p)=mp_p_plus_fq(mp, dep_list(p),u,dep_list(q),
20980 mp_proto_dependent,type(q));
20983 if ( type(p)==mp_known ) {
20987 while ( info(r)!=null ) r=mp_link(r);
20989 if ( r!=dep_list(p) ) value(r)=delta;
20990 else { mp_recycle_value(mp, p); type(p)=mp_known; value(p)=delta; };
20992 if ( mp->fix_needed ) mp_fix_dependencies(mp);
20995 @ @<Ensure that |type(p)=mp_proto_dependent|@>=
20996 if ( type(p)!=mp_proto_dependent ) {
20997 if ( type(p)==mp_known )
20998 mp_new_dep(mp, p,mp_const_dependency(mp, value(p)));
21000 dep_list(p)=mp_p_times_v(mp, dep_list(p),unity,mp_dependent,
21001 mp_proto_dependent,true);
21002 type(p)=mp_proto_dependent;
21005 @ @<Transform a known big node@>=
21006 mp_set_up_trans(mp, c);
21007 if ( mp->cur_type==mp_known ) {
21008 @<Transform known by known@>;
21010 pp=mp_stash_cur_exp(mp); qq=value(pp);
21011 mp_make_exp_copy(mp, p); r=value(mp->cur_exp);
21012 if ( mp->cur_type==mp_transform_type ) {
21013 mp_bilin2(mp, yy_part_loc(r),yy_part_loc(qq),
21014 value(xy_part_loc(q)),yx_part_loc(qq),null);
21015 mp_bilin2(mp, yx_part_loc(r),yy_part_loc(qq),
21016 value(xx_part_loc(q)),yx_part_loc(qq),null);
21017 mp_bilin2(mp, xy_part_loc(r),xx_part_loc(qq),
21018 value(yy_part_loc(q)),xy_part_loc(qq),null);
21019 mp_bilin2(mp, xx_part_loc(r),xx_part_loc(qq),
21020 value(yx_part_loc(q)),xy_part_loc(qq),null);
21022 mp_bilin2(mp, y_part_loc(r),yy_part_loc(qq),
21023 value(x_part_loc(q)),yx_part_loc(qq),y_part_loc(qq));
21024 mp_bilin2(mp, x_part_loc(r),xx_part_loc(qq),
21025 value(y_part_loc(q)),xy_part_loc(qq),x_part_loc(qq));
21026 mp_recycle_value(mp, pp); mp_free_node(mp, pp,value_node_size);
21029 @ Let |p| be a |mp_proto_dependent| value whose dependency list ends
21030 at |dep_final|. The following procedure adds |v| times another
21031 numeric quantity to~|p|.
21033 @<Declare subroutines needed by |big_trans|@>=
21034 static void mp_add_mult_dep (MP mp,pointer p, scaled v, pointer r) {
21035 if ( type(r)==mp_known ) {
21036 value(mp->dep_final)+=mp_take_scaled(mp, value(r),v);
21038 dep_list(p)=mp_p_plus_fq(mp, dep_list(p),v,dep_list(r),
21039 mp_proto_dependent,type(r));
21040 if ( mp->fix_needed ) mp_fix_dependencies(mp);
21044 @ The |bilin2| procedure is something like |bilin1|, but with known
21045 and unknown quantities reversed. Parameter |p| points to a value field
21046 within the big node for |cur_exp|; and |type(p)=mp_known|. Parameters
21047 |t| and~|u| point to value fields elsewhere; so does parameter~|q|,
21048 unless it is |null| (which stands for zero). Location~|p| will be
21049 replaced by $p\cdot t+v\cdot u+q$.
21051 @<Declare subroutines needed by |big_trans|@>=
21052 static void mp_bilin2 (MP mp,pointer p, pointer t, scaled v,
21053 pointer u, pointer q) {
21054 scaled vv; /* temporary storage for |value(p)| */
21055 vv=value(p); type(p)=mp_proto_dependent;
21056 mp_new_dep(mp, p,mp_const_dependency(mp, 0)); /* this sets |dep_final| */
21058 mp_add_mult_dep(mp, p,vv,t); /* |dep_final| doesn't change */
21059 if ( v!=0 ) mp_add_mult_dep(mp, p,v,u);
21060 if ( q!=null ) mp_add_mult_dep(mp, p,unity,q);
21061 if ( dep_list(p)==mp->dep_final ) {
21062 vv=value(mp->dep_final); mp_recycle_value(mp, p);
21063 type(p)=mp_known; value(p)=vv;
21067 @ @<Transform known by known@>=
21069 mp_make_exp_copy(mp, p); r=value(mp->cur_exp);
21070 if ( mp->cur_type==mp_transform_type ) {
21071 mp_bilin3(mp, yy_part_loc(r),mp->tyy,value(xy_part_loc(q)),mp->tyx,0);
21072 mp_bilin3(mp, yx_part_loc(r),mp->tyy,value(xx_part_loc(q)),mp->tyx,0);
21073 mp_bilin3(mp, xy_part_loc(r),mp->txx,value(yy_part_loc(q)),mp->txy,0);
21074 mp_bilin3(mp, xx_part_loc(r),mp->txx,value(yx_part_loc(q)),mp->txy,0);
21076 mp_bilin3(mp, y_part_loc(r),mp->tyy,value(x_part_loc(q)),mp->tyx,mp->ty);
21077 mp_bilin3(mp, x_part_loc(r),mp->txx,value(y_part_loc(q)),mp->txy,mp->tx);
21080 @ Finally, in |bilin3| everything is |known|.
21082 @<Declare subroutines needed by |big_trans|@>=
21083 static void mp_bilin3 (MP mp,pointer p, scaled t,
21084 scaled v, scaled u, scaled delta) {
21086 delta+=mp_take_scaled(mp, value(p),t);
21089 if ( u!=0 ) value(p)=delta+mp_take_scaled(mp, v,u);
21090 else value(p)=delta;
21093 @ @<Additional cases of binary operators@>=
21095 if ( (mp->cur_type==mp_string_type)&&(type(p)==mp_string_type) ) mp_cat(mp, p);
21096 else mp_bad_binary(mp, p,concatenate);
21099 if ( mp_nice_pair(mp, p,type(p))&&(mp->cur_type==mp_string_type) )
21100 mp_chop_string(mp, value(p));
21101 else mp_bad_binary(mp, p,substring_of);
21104 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
21105 if ( mp_nice_pair(mp, p,type(p))&&(mp->cur_type==mp_path_type) )
21106 mp_chop_path(mp, value(p));
21107 else mp_bad_binary(mp, p,subpath_of);
21110 @ @<Declare binary action...@>=
21111 static void mp_cat (MP mp,pointer p) {
21112 str_number a,b; /* the strings being concatenated */
21113 pool_pointer k; /* index into |str_pool| */
21114 a=value(p); b=mp->cur_exp; str_room(length(a)+length(b));
21115 for (k=mp->str_start[a];k<=str_stop(a)-1;k++) {
21116 append_char(mp->str_pool[k]);
21118 for (k=mp->str_start[b];k<=str_stop(b)-1;k++) {
21119 append_char(mp->str_pool[k]);
21121 mp->cur_exp=mp_make_string(mp); delete_str_ref(b);
21124 @ @<Declare binary action...@>=
21125 static void mp_chop_string (MP mp,pointer p) {
21126 integer a, b; /* start and stop points */
21127 integer l; /* length of the original string */
21128 integer k; /* runs from |a| to |b| */
21129 str_number s; /* the original string */
21130 boolean reversed; /* was |a>b|? */
21131 a=mp_round_unscaled(mp, value(x_part_loc(p)));
21132 b=mp_round_unscaled(mp, value(y_part_loc(p)));
21133 if ( a<=b ) reversed=false;
21134 else { reversed=true; k=a; a=b; b=k; };
21135 s=mp->cur_exp; l=length(s);
21146 for (k=mp->str_start[s]+b-1;k>=mp->str_start[s]+a;k--) {
21147 append_char(mp->str_pool[k]);
21150 for (k=mp->str_start[s]+a;k<=mp->str_start[s]+b-1;k++) {
21151 append_char(mp->str_pool[k]);
21154 mp->cur_exp=mp_make_string(mp); delete_str_ref(s);
21157 @ @<Declare binary action...@>=
21158 static void mp_chop_path (MP mp,pointer p) {
21159 pointer q; /* a knot in the original path */
21160 pointer pp,qq,rr,ss; /* link variables for copies of path nodes */
21161 scaled a,b,k,l; /* indices for chopping */
21162 boolean reversed; /* was |a>b|? */
21163 l=mp_path_length(mp); a=value(x_part_loc(p)); b=value(y_part_loc(p));
21164 if ( a<=b ) reversed=false;
21165 else { reversed=true; k=a; a=b; b=k; };
21166 @<Dispense with the cases |a<0| and/or |b>l|@>;
21168 while ( a>=unity ) {
21169 q=mp_link(q); a=a-unity; b=b-unity;
21172 @<Construct a path from |pp| to |qq| of length zero@>;
21174 @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>;
21176 left_type(pp)=mp_endpoint; right_type(qq)=mp_endpoint; mp_link(qq)=pp;
21177 mp_toss_knot_list(mp, mp->cur_exp);
21179 mp->cur_exp=mp_link(mp_htap_ypoc(mp, pp)); mp_toss_knot_list(mp, pp);
21185 @ @<Dispense with the cases |a<0| and/or |b>l|@>=
21187 if ( left_type(mp->cur_exp)==mp_endpoint ) {
21188 a=0; if ( b<0 ) b=0;
21190 do { a=a+l; b=b+l; } while (a<0); /* a cycle always has length |l>0| */
21194 if ( left_type(mp->cur_exp)==mp_endpoint ) {
21195 b=l; if ( a>l ) a=l;
21203 @ @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>=
21205 pp=mp_copy_knot(mp, q); qq=pp;
21207 q=mp_link(q); rr=qq; qq=mp_copy_knot(mp, q); mp_link(rr)=qq; b=b-unity;
21210 ss=pp; pp=mp_link(pp);
21211 mp_split_cubic(mp, ss,a*010000); pp=mp_link(ss);
21212 mp_free_node(mp, ss,knot_node_size);
21214 b=mp_make_scaled(mp, b,unity-a); rr=pp;
21218 mp_split_cubic(mp, rr,(b+unity)*010000);
21219 mp_free_node(mp, qq,knot_node_size);
21224 @ @<Construct a path from |pp| to |qq| of length zero@>=
21226 if ( a>0 ) { mp_split_cubic(mp, q,a*010000); q=mp_link(q); };
21227 pp=mp_copy_knot(mp, q); qq=pp;
21230 @ @<Additional cases of binary operators@>=
21231 case point_of: case precontrol_of: case postcontrol_of:
21232 if ( mp->cur_type==mp_pair_type )
21233 mp_pair_to_path(mp);
21234 if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_known) )
21235 mp_find_point(mp, value(p),c);
21237 mp_bad_binary(mp, p,c);
21239 case pen_offset_of:
21240 if ( (mp->cur_type==mp_pen_type)&& mp_nice_pair(mp, p,type(p)) )
21241 mp_set_up_offset(mp, value(p));
21243 mp_bad_binary(mp, p,pen_offset_of);
21245 case direction_time_of:
21246 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
21247 if ( (mp->cur_type==mp_path_type)&& mp_nice_pair(mp, p,type(p)) )
21248 mp_set_up_direction_time(mp, value(p));
21250 mp_bad_binary(mp, p,direction_time_of);
21253 if ( (type(p) != mp_pen_type) || (mp->cur_type != mp_path_type) )
21254 mp_bad_binary(mp, p,envelope_of);
21256 mp_set_up_envelope(mp, p);
21259 @ @<Declare binary action...@>=
21260 static void mp_set_up_offset (MP mp,pointer p) {
21261 mp_find_offset(mp, value(x_part_loc(p)),value(y_part_loc(p)),mp->cur_exp);
21262 mp_pair_value(mp, mp->cur_x,mp->cur_y);
21264 static void mp_set_up_direction_time (MP mp,pointer p) {
21265 mp_flush_cur_exp(mp, mp_find_direction_time(mp, value(x_part_loc(p)),
21266 value(y_part_loc(p)),mp->cur_exp));
21268 static void mp_set_up_envelope (MP mp,pointer p) {
21269 quarterword ljoin, lcap;
21271 pointer q = mp_copy_path(mp, mp->cur_exp); /* the original path */
21272 /* TODO: accept elliptical pens for straight paths */
21273 if (pen_is_elliptical(value(p))) {
21274 mp_bad_envelope_pen(mp);
21276 mp->cur_type = mp_path_type;
21279 if ( mp->internal[mp_linejoin]>unity ) ljoin=2;
21280 else if ( mp->internal[mp_linejoin]>0 ) ljoin=1;
21282 if ( mp->internal[mp_linecap]>unity ) lcap=2;
21283 else if ( mp->internal[mp_linecap]>0 ) lcap=1;
21285 if ( mp->internal[mp_miterlimit]<unity )
21288 miterlim=mp->internal[mp_miterlimit];
21289 mp->cur_exp = mp_make_envelope(mp, q, value(p), ljoin,lcap,miterlim);
21290 mp->cur_type = mp_path_type;
21293 @ @<Declare binary action...@>=
21294 static void mp_find_point (MP mp,scaled v, quarterword c) {
21295 pointer p; /* the path */
21296 scaled n; /* its length */
21298 if ( left_type(p)==mp_endpoint ) n=-unity; else n=0;
21299 do { p=mp_link(p); n=n+unity; } while (p!=mp->cur_exp);
21302 } else if ( v<0 ) {
21303 if ( left_type(p)==mp_endpoint ) v=0;
21304 else v=n-1-((-v-1) % n);
21305 } else if ( v>n ) {
21306 if ( left_type(p)==mp_endpoint ) v=n;
21310 while ( v>=unity ) { p=mp_link(p); v=v-unity; };
21312 @<Insert a fractional node by splitting the cubic@>;
21314 @<Set the current expression to the desired path coordinates@>;
21317 @ @<Insert a fractional node...@>=
21318 { mp_split_cubic(mp, p,v*010000); p=mp_link(p); }
21320 @ @<Set the current expression to the desired path coordinates...@>=
21323 mp_pair_value(mp, x_coord(p),y_coord(p));
21325 case precontrol_of:
21326 if ( left_type(p)==mp_endpoint ) mp_pair_value(mp, x_coord(p),y_coord(p));
21327 else mp_pair_value(mp, left_x(p),left_y(p));
21329 case postcontrol_of:
21330 if ( right_type(p)==mp_endpoint ) mp_pair_value(mp, x_coord(p),y_coord(p));
21331 else mp_pair_value(mp, right_x(p),right_y(p));
21333 } /* there are no other cases */
21335 @ @<Additional cases of binary operators@>=
21337 if ( mp->cur_type==mp_pair_type )
21338 mp_pair_to_path(mp);
21339 if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_known) )
21340 mp_flush_cur_exp(mp, mp_get_arc_time(mp, mp->cur_exp,value(p)));
21342 mp_bad_binary(mp, p,c);
21345 @ @<Additional cases of bin...@>=
21347 if ( type(p)==mp_pair_type ) {
21348 q=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, p);
21349 mp_pair_to_path(mp); p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q);
21351 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
21352 if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_path_type) ) {
21353 mp_path_intersection(mp, value(p),mp->cur_exp);
21354 mp_pair_value(mp, mp->cur_t,mp->cur_tt);
21356 mp_bad_binary(mp, p,intersect);
21360 @ @<Additional cases of bin...@>=
21362 if ( (mp->cur_type!=mp_string_type)||(type(p)!=mp_string_type))
21363 mp_bad_binary(mp, p,in_font);
21364 else { mp_do_infont(mp, p); binary_return; }
21367 @ Function |new_text_node| owns the reference count for its second argument
21368 (the text string) but not its first (the font name).
21370 @<Declare binary action...@>=
21371 static void mp_do_infont (MP mp,pointer p) {
21373 q=mp_get_node(mp, edge_header_size);
21374 mp_init_edges(mp, q);
21375 mp_link(obj_tail(q))=mp_new_text_node(mp,str(mp->cur_exp),value(p));
21376 obj_tail(q)=mp_link(obj_tail(q));
21377 mp_free_node(mp, p,value_node_size);
21378 mp_flush_cur_exp(mp, q);
21379 mp->cur_type=mp_picture_type;
21382 @* \[40] Statements and commands.
21383 The chief executive of \MP\ is the |do_statement| routine, which
21384 contains the master switch that causes all the various pieces of \MP\
21385 to do their things, in the right order.
21387 In a sense, this is the grand climax of the program: It applies all the
21388 tools that we have worked so hard to construct. In another sense, this is
21389 the messiest part of the program: It necessarily refers to other pieces
21390 of code all over the place, so that a person can't fully understand what is
21391 going on without paging back and forth to be reminded of conventions that
21392 are defined elsewhere. We are now at the hub of the web.
21394 The structure of |do_statement| itself is quite simple. The first token
21395 of the statement is fetched using |get_x_next|. If it can be the first
21396 token of an expression, we look for an equation, an assignment, or a
21397 title. Otherwise we use a \&{case} construction to branch at high speed to
21398 the appropriate routine for various and sundry other types of commands,
21399 each of which has an ``action procedure'' that does the necessary work.
21401 The program uses the fact that
21402 $$\hbox{|min_primary_command=max_statement_command=type_name|}$$
21403 to interpret a statement that starts with, e.g., `\&{string}',
21404 as a type declaration rather than a boolean expression.
21406 @c void mp_do_statement (MP mp) { /* governs \MP's activities */
21407 mp->cur_type=mp_vacuous; mp_get_x_next(mp);
21408 if ( mp->cur_cmd>max_primary_command ) {
21409 @<Worry about bad statement@>;
21410 } else if ( mp->cur_cmd>max_statement_command ) {
21411 @<Do an equation, assignment, title, or
21412 `$\langle\,$expression$\,\rangle\,$\&{endgroup}'@>;
21414 @<Do a statement that doesn't begin with an expression@>;
21416 if ( mp->cur_cmd<semicolon )
21417 @<Flush unparsable junk that was found after the statement@>;
21421 @ @<Declarations@>=
21422 @<Declare action procedures for use by |do_statement|@>
21424 @ The only command codes |>max_primary_command| that can be present
21425 at the beginning of a statement are |semicolon| and higher; these
21426 occur when the statement is null.
21428 @<Worry about bad statement@>=
21430 if ( mp->cur_cmd<semicolon ) {
21431 print_err("A statement can't begin with `");
21432 @.A statement can't begin with x@>
21433 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod); mp_print_char(mp, xord('\''));
21434 help5("I was looking for the beginning of a new statement.",
21435 "If you just proceed without changing anything, I'll ignore",
21436 "everything up to the next `;'. Please insert a semicolon",
21437 "now in front of anything that you don't want me to delete.",
21438 "(See Chapter 27 of The METAFONTbook for an example.)");
21439 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
21440 mp_back_error(mp); mp_get_x_next(mp);
21444 @ The help message printed here says that everything is flushed up to
21445 a semicolon, but actually the commands |end_group| and |stop| will
21446 also terminate a statement.
21448 @<Flush unparsable junk that was found after the statement@>=
21450 print_err("Extra tokens will be flushed");
21451 @.Extra tokens will be flushed@>
21452 help6("I've just read as much of that statement as I could fathom,",
21453 "so a semicolon should have been next. It's very puzzling...",
21454 "but I'll try to get myself back together, by ignoring",
21455 "everything up to the next `;'. Please insert a semicolon",
21456 "now in front of anything that you don't want me to delete.",
21457 "(See Chapter 27 of The METAFONTbook for an example.)");
21458 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
21459 mp_back_error(mp); mp->scanner_status=flushing;
21462 @<Decrease the string reference count...@>;
21463 } while (! end_of_statement); /* |cur_cmd=semicolon|, |end_group|, or |stop| */
21464 mp->scanner_status=normal;
21467 @ If |do_statement| ends with |cur_cmd=end_group|, we should have
21468 |cur_type=mp_vacuous| unless the statement was simply an expression;
21469 in the latter case, |cur_type| and |cur_exp| should represent that
21472 @<Do a statement that doesn't...@>=
21474 if ( mp->internal[mp_tracing_commands]>0 )
21476 switch (mp->cur_cmd ) {
21477 case type_name:mp_do_type_declaration(mp); break;
21479 if ( mp->cur_mod>var_def ) mp_make_op_def(mp);
21480 else if ( mp->cur_mod>end_def ) mp_scan_def(mp);
21482 @<Cases of |do_statement| that invoke particular commands@>;
21483 } /* there are no other cases */
21484 mp->cur_type=mp_vacuous;
21487 @ The most important statements begin with expressions.
21489 @<Do an equation, assignment, title, or...@>=
21491 mp->var_flag=assignment; mp_scan_expression(mp);
21492 if ( mp->cur_cmd<end_group ) {
21493 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21494 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21495 else if ( mp->cur_type==mp_string_type ) {@<Do a title@> ; }
21496 else if ( mp->cur_type!=mp_vacuous ){
21497 exp_err("Isolated expression");
21498 @.Isolated expression@>
21499 help3("I couldn't find an `=' or `:=' after the",
21500 "expression that is shown above this error message,",
21501 "so I guess I'll just ignore it and carry on.");
21502 mp_put_get_error(mp);
21504 mp_flush_cur_exp(mp, 0); mp->cur_type=mp_vacuous;
21510 if ( mp->internal[mp_tracing_titles]>0 ) {
21511 mp_print_nl(mp, ""); mp_print_str(mp, mp->cur_exp); update_terminal;
21515 @ Equations and assignments are performed by the pair of mutually recursive
21517 routines |do_equation| and |do_assignment|. These routines are called when
21518 |cur_cmd=equals| and when |cur_cmd=assignment|, respectively; the left-hand
21519 side is in |cur_type| and |cur_exp|, while the right-hand side is yet
21520 to be scanned. After the routines are finished, |cur_type| and |cur_exp|
21521 will be equal to the right-hand side (which will normally be equal
21522 to the left-hand side).
21525 @<Declare the procedure called |make_eq|@>
21526 static void mp_do_equation (MP mp) ;
21529 void mp_do_equation (MP mp) {
21530 pointer lhs; /* capsule for the left-hand side */
21531 pointer p; /* temporary register */
21532 lhs=mp_stash_cur_exp(mp); mp_get_x_next(mp);
21533 mp->var_flag=assignment; mp_scan_expression(mp);
21534 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21535 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21536 if ( mp->internal[mp_tracing_commands]>two )
21537 @<Trace the current equation@>;
21538 if ( mp->cur_type==mp_unknown_path ) if ( type(lhs)==mp_pair_type ) {
21539 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, lhs); lhs=p;
21540 }; /* in this case |make_eq| will change the pair to a path */
21541 mp_make_eq(mp, lhs); /* equate |lhs| to |(cur_type,cur_exp)| */
21544 @ And |do_assignment| is similar to |do_equation|:
21547 static void mp_do_assignment (MP mp);
21550 void mp_do_assignment (MP mp) {
21551 pointer lhs; /* token list for the left-hand side */
21552 pointer p; /* where the left-hand value is stored */
21553 pointer q; /* temporary capsule for the right-hand value */
21554 if ( mp->cur_type!=mp_token_list ) {
21555 exp_err("Improper `:=' will be changed to `='");
21557 help2("I didn't find a variable name at the left of the `:=',",
21558 "so I'm going to pretend that you said `=' instead.");
21559 mp_error(mp); mp_do_equation(mp);
21561 lhs=mp->cur_exp; mp->cur_type=mp_vacuous;
21562 mp_get_x_next(mp); mp->var_flag=assignment; mp_scan_expression(mp);
21563 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21564 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21565 if ( mp->internal[mp_tracing_commands]>two )
21566 @<Trace the current assignment@>;
21567 if ( info(lhs)>hash_end ) {
21568 @<Assign the current expression to an internal variable@>;
21570 @<Assign the current expression to the variable |lhs|@>;
21572 mp_flush_node_list(mp, lhs);
21576 @ @<Trace the current equation@>=
21578 mp_begin_diagnostic(mp); mp_print_nl(mp, "{("); mp_print_exp(mp,lhs,0);
21579 mp_print(mp,")=("); mp_print_exp(mp,null,0);
21580 mp_print(mp,")}"); mp_end_diagnostic(mp, false);
21583 @ @<Trace the current assignment@>=
21585 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
21586 if ( info(lhs)>hash_end )
21587 mp_print(mp, mp->int_name[info(lhs)-(hash_end)]);
21589 mp_show_token_list(mp, lhs,null,1000,0);
21590 mp_print(mp, ":="); mp_print_exp(mp, null,0);
21591 mp_print_char(mp, xord('}')); mp_end_diagnostic(mp, false);
21594 @ @<Assign the current expression to an internal variable@>=
21595 if ( mp->cur_type==mp_known ) {
21596 mp->internal[info(lhs)-(hash_end)]=mp->cur_exp;
21598 exp_err("Internal quantity `");
21599 @.Internal quantity...@>
21600 mp_print(mp, mp->int_name[info(lhs)-(hash_end)]);
21601 mp_print(mp, "' must receive a known value");
21602 help2("I can\'t set an internal quantity to anything but a known",
21603 "numeric value, so I'll have to ignore this assignment.");
21604 mp_put_get_error(mp);
21607 @ @<Assign the current expression to the variable |lhs|@>=
21609 p=mp_find_variable(mp, lhs);
21611 q=mp_stash_cur_exp(mp); mp->cur_type=mp_und_type(mp, p);
21612 mp_recycle_value(mp, p);
21613 type(p)=mp->cur_type; value(p)=null; mp_make_exp_copy(mp, p);
21614 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q); mp_make_eq(mp, p);
21616 mp_obliterated(mp, lhs); mp_put_get_error(mp);
21621 @ And now we get to the nitty-gritty. The |make_eq| procedure is given
21622 a pointer to a capsule that is to be equated to the current expression.
21624 @<Declare the procedure called |make_eq|@>=
21625 static void mp_make_eq (MP mp,pointer lhs) ;
21629 @c void mp_make_eq (MP mp,pointer lhs) {
21630 quarterword t; /* type of the left-hand side */
21631 pointer p,q; /* pointers inside of big nodes */
21632 integer v=0; /* value of the left-hand side */
21635 if ( t<=mp_pair_type ) v=value(lhs);
21637 @<For each type |t|, make an equation and |goto done| unless |cur_type|
21638 is incompatible with~|t|@>;
21639 } /* all cases have been listed */
21640 @<Announce that the equation cannot be performed@>;
21642 check_arith; mp_recycle_value(mp, lhs);
21643 mp_free_node(mp, lhs,value_node_size);
21646 @ @<Announce that the equation cannot be performed@>=
21647 mp_disp_err(mp, lhs,"");
21648 exp_err("Equation cannot be performed (");
21649 @.Equation cannot be performed@>
21650 if ( type(lhs)<=mp_pair_type ) mp_print_type(mp, type(lhs));
21651 else mp_print(mp, "numeric");
21652 mp_print_char(mp, xord('='));
21653 if ( mp->cur_type<=mp_pair_type ) mp_print_type(mp, mp->cur_type);
21654 else mp_print(mp, "numeric");
21655 mp_print_char(mp, xord(')'));
21656 help2("I'm sorry, but I don't know how to make such things equal.",
21657 "(See the two expressions just above the error message.)");
21658 mp_put_get_error(mp)
21660 @ @<For each type |t|, make an equation and |goto done| unless...@>=
21661 case mp_boolean_type: case mp_string_type: case mp_pen_type:
21662 case mp_path_type: case mp_picture_type:
21663 if ( mp->cur_type==t+unknown_tag ) {
21664 mp_nonlinear_eq(mp, v,mp->cur_exp,false);
21665 mp_unstash_cur_exp(mp, mp->cur_exp); goto DONE;
21666 } else if ( mp->cur_type==t ) {
21667 @<Report redundant or inconsistent equation and |goto done|@>;
21670 case unknown_types:
21671 if ( mp->cur_type==t-unknown_tag ) {
21672 mp_nonlinear_eq(mp, mp->cur_exp,lhs,true); goto DONE;
21673 } else if ( mp->cur_type==t ) {
21674 mp_ring_merge(mp, lhs,mp->cur_exp); goto DONE;
21675 } else if ( mp->cur_type==mp_pair_type ) {
21676 if ( t==mp_unknown_path ) {
21677 mp_pair_to_path(mp); goto RESTART;
21681 case mp_transform_type: case mp_color_type:
21682 case mp_cmykcolor_type: case mp_pair_type:
21683 if ( mp->cur_type==t ) {
21684 @<Do multiple equations and |goto done|@>;
21687 case mp_known: case mp_dependent:
21688 case mp_proto_dependent: case mp_independent:
21689 if ( mp->cur_type>=mp_known ) {
21690 mp_try_eq(mp, lhs,null); goto DONE;
21696 @ @<Report redundant or inconsistent equation and |goto done|@>=
21698 if ( mp->cur_type<=mp_string_type ) {
21699 if ( mp->cur_type==mp_string_type ) {
21700 if ( mp_str_vs_str(mp, v,mp->cur_exp)!=0 ) {
21703 } else if ( v!=mp->cur_exp ) {
21706 @<Exclaim about a redundant equation@>; goto DONE;
21708 print_err("Redundant or inconsistent equation");
21709 @.Redundant or inconsistent equation@>
21710 help2("An equation between already-known quantities can't help.",
21711 "But don't worry; continue and I'll just ignore it.");
21712 mp_put_get_error(mp); goto DONE;
21714 print_err("Inconsistent equation");
21715 @.Inconsistent equation@>
21716 help2("The equation I just read contradicts what was said before.",
21717 "But don't worry; continue and I'll just ignore it.");
21718 mp_put_get_error(mp); goto DONE;
21721 @ @<Do multiple equations and |goto done|@>=
21723 p=v+mp->big_node_size[t];
21724 q=value(mp->cur_exp)+mp->big_node_size[t];
21726 p=p-2; q=q-2; mp_try_eq(mp, p,q);
21731 @ The first argument to |try_eq| is the location of a value node
21732 in a capsule that will soon be recycled. The second argument is
21733 either a location within a pair or transform node pointed to by
21734 |cur_exp|, or it is |null| (which means that |cur_exp| itself
21735 serves as the second argument). The idea is to leave |cur_exp| unchanged,
21736 but to equate the two operands.
21739 static void mp_try_eq (MP mp,pointer l, pointer r) ;
21742 @c void mp_try_eq (MP mp,pointer l, pointer r) {
21743 pointer p; /* dependency list for right operand minus left operand */
21744 int t; /* the type of list |p| */
21745 pointer q; /* the constant term of |p| is here */
21746 pointer pp; /* dependency list for right operand */
21747 int tt; /* the type of list |pp| */
21748 boolean copied; /* have we copied a list that ought to be recycled? */
21749 @<Remove the left operand from its container, negate it, and
21750 put it into dependency list~|p| with constant term~|q|@>;
21751 @<Add the right operand to list |p|@>;
21752 if ( info(p)==null ) {
21753 @<Deal with redundant or inconsistent equation@>;
21755 mp_linear_eq(mp, p,t);
21756 if ( r==null ) if ( mp->cur_type!=mp_known ) {
21757 if ( type(mp->cur_exp)==mp_known ) {
21758 pp=mp->cur_exp; mp->cur_exp=value(mp->cur_exp); mp->cur_type=mp_known;
21759 mp_free_node(mp, pp,value_node_size);
21765 @ @<Remove the left operand from its container, negate it, and...@>=
21767 if ( t==mp_known ) {
21768 t=mp_dependent; p=mp_const_dependency(mp, -value(l)); q=p;
21769 } else if ( t==mp_independent ) {
21770 t=mp_dependent; p=mp_single_dependency(mp, l); negate(value(p));
21773 p=dep_list(l); q=p;
21776 if ( info(q)==null ) break;
21779 mp_link(prev_dep(l))=mp_link(q); prev_dep(mp_link(q))=prev_dep(l);
21783 @ @<Deal with redundant or inconsistent equation@>=
21785 if ( abs(value(p))>64 ) { /* off by .001 or more */
21786 print_err("Inconsistent equation");
21787 @.Inconsistent equation@>
21788 mp_print(mp, " (off by "); mp_print_scaled(mp, value(p));
21789 mp_print_char(mp, xord(')'));
21790 help2("The equation I just read contradicts what was said before.",
21791 "But don't worry; continue and I'll just ignore it.");
21792 mp_put_get_error(mp);
21793 } else if ( r==null ) {
21794 @<Exclaim about a redundant equation@>;
21796 mp_free_node(mp, p,dep_node_size);
21799 @ @<Add the right operand to list |p|@>=
21801 if ( mp->cur_type==mp_known ) {
21802 value(q)=value(q)+mp->cur_exp; goto DONE1;
21805 if ( tt==mp_independent ) pp=mp_single_dependency(mp, mp->cur_exp);
21806 else pp=dep_list(mp->cur_exp);
21809 if ( type(r)==mp_known ) {
21810 value(q)=value(q)+value(r); goto DONE1;
21813 if ( tt==mp_independent ) pp=mp_single_dependency(mp, r);
21814 else pp=dep_list(r);
21817 if ( tt!=mp_independent ) copied=false;
21818 else { copied=true; tt=mp_dependent; };
21819 @<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>;
21820 if ( copied ) mp_flush_node_list(mp, pp);
21823 @ @<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>=
21824 mp->watch_coefs=false;
21826 p=mp_p_plus_q(mp, p,pp,t);
21827 } else if ( t==mp_proto_dependent ) {
21828 p=mp_p_plus_fq(mp, p,unity,pp,mp_proto_dependent,mp_dependent);
21831 while ( info(q)!=null ) {
21832 value(q)=mp_round_fraction(mp, value(q)); q=mp_link(q);
21834 t=mp_proto_dependent; p=mp_p_plus_q(mp, p,pp,t);
21836 mp->watch_coefs=true;
21838 @ Our next goal is to process type declarations. For this purpose it's
21839 convenient to have a procedure that scans a $\langle\,$declared
21840 variable$\,\rangle$ and returns the corresponding token list. After the
21841 following procedure has acted, the token after the declared variable
21842 will have been scanned, so it will appear in |cur_cmd|, |cur_mod|,
21846 static pointer mp_scan_declared_variable (MP mp) ;
21849 pointer mp_scan_declared_variable (MP mp) {
21850 pointer x; /* hash address of the variable's root */
21851 pointer h,t; /* head and tail of the token list to be returned */
21852 pointer l; /* hash address of left bracket */
21853 mp_get_symbol(mp); x=mp->cur_sym;
21854 if ( mp->cur_cmd!=tag_token ) mp_clear_symbol(mp, x,false);
21855 h=mp_get_avail(mp); info(h)=x; t=h;
21858 if ( mp->cur_sym==0 ) break;
21859 if ( mp->cur_cmd!=tag_token ) if ( mp->cur_cmd!=internal_quantity) {
21860 if ( mp->cur_cmd==left_bracket ) {
21861 @<Descend past a collective subscript@>;
21866 mp_link(t)=mp_get_avail(mp); t=mp_link(t); info(t)=mp->cur_sym;
21868 if ( (eq_type(x)%outer_tag)!=tag_token ) mp_clear_symbol(mp, x,false);
21869 if ( equiv(x)==null ) mp_new_root(mp, x);
21873 @ If the subscript isn't collective, we don't accept it as part of the
21876 @<Descend past a collective subscript@>=
21878 l=mp->cur_sym; mp_get_x_next(mp);
21879 if ( mp->cur_cmd!=right_bracket ) {
21880 mp_back_input(mp); mp->cur_sym=l; mp->cur_cmd=left_bracket; break;
21882 mp->cur_sym=collective_subscript;
21886 @ Type declarations are introduced by the following primitive operations.
21889 mp_primitive(mp, "numeric",type_name,mp_numeric_type);
21890 @:numeric_}{\&{numeric} primitive@>
21891 mp_primitive(mp, "string",type_name,mp_string_type);
21892 @:string_}{\&{string} primitive@>
21893 mp_primitive(mp, "boolean",type_name,mp_boolean_type);
21894 @:boolean_}{\&{boolean} primitive@>
21895 mp_primitive(mp, "path",type_name,mp_path_type);
21896 @:path_}{\&{path} primitive@>
21897 mp_primitive(mp, "pen",type_name,mp_pen_type);
21898 @:pen_}{\&{pen} primitive@>
21899 mp_primitive(mp, "picture",type_name,mp_picture_type);
21900 @:picture_}{\&{picture} primitive@>
21901 mp_primitive(mp, "transform",type_name,mp_transform_type);
21902 @:transform_}{\&{transform} primitive@>
21903 mp_primitive(mp, "color",type_name,mp_color_type);
21904 @:color_}{\&{color} primitive@>
21905 mp_primitive(mp, "rgbcolor",type_name,mp_color_type);
21906 @:color_}{\&{rgbcolor} primitive@>
21907 mp_primitive(mp, "cmykcolor",type_name,mp_cmykcolor_type);
21908 @:color_}{\&{cmykcolor} primitive@>
21909 mp_primitive(mp, "pair",type_name,mp_pair_type);
21910 @:pair_}{\&{pair} primitive@>
21912 @ @<Cases of |print_cmd...@>=
21913 case type_name: mp_print_type(mp, m); break;
21915 @ Now we are ready to handle type declarations, assuming that a
21916 |type_name| has just been scanned.
21918 @<Declare action procedures for use by |do_statement|@>=
21919 static void mp_do_type_declaration (MP mp) ;
21922 void mp_do_type_declaration (MP mp) {
21923 quarterword t; /* the type being declared */
21924 pointer p; /* token list for a declared variable */
21925 pointer q; /* value node for the variable */
21926 if ( mp->cur_mod>=mp_transform_type )
21929 t=mp->cur_mod+unknown_tag;
21931 p=mp_scan_declared_variable(mp);
21932 mp_flush_variable(mp, equiv(info(p)),mp_link(p),false);
21933 q=mp_find_variable(mp, p);
21935 type(q)=t; value(q)=null;
21937 print_err("Declared variable conflicts with previous vardef");
21938 @.Declared variable conflicts...@>
21939 help2("You can't use, e.g., `numeric foo[]' after `vardef foo'.",
21940 "Proceed, and I'll ignore the illegal redeclaration.");
21941 mp_put_get_error(mp);
21943 mp_flush_list(mp, p);
21944 if ( mp->cur_cmd<comma ) {
21945 @<Flush spurious symbols after the declared variable@>;
21947 } while (! end_of_statement);
21950 @ @<Flush spurious symbols after the declared variable@>=
21952 print_err("Illegal suffix of declared variable will be flushed");
21953 @.Illegal suffix...flushed@>
21954 help5("Variables in declarations must consist entirely of",
21955 "names and collective subscripts, e.g., `x[]a'.",
21956 "Are you trying to use a reserved word in a variable name?",
21957 "I'm going to discard the junk I found here,",
21958 "up to the next comma or the end of the declaration.");
21959 if ( mp->cur_cmd==numeric_token )
21960 mp->help_line[2]="Explicit subscripts like `x15a' aren't permitted.";
21961 mp_put_get_error(mp); mp->scanner_status=flushing;
21964 @<Decrease the string reference count...@>;
21965 } while (mp->cur_cmd<comma); /* either |end_of_statement| or |cur_cmd=comma| */
21966 mp->scanner_status=normal;
21969 @ \MP's |main_control| procedure just calls |do_statement| repeatedly
21970 until coming to the end of the user's program.
21971 Each execution of |do_statement| concludes with
21972 |cur_cmd=semicolon|, |end_group|, or |stop|.
21975 static void mp_main_control (MP mp) {
21977 mp_do_statement(mp);
21978 if ( mp->cur_cmd==end_group ) {
21979 print_err("Extra `endgroup'");
21980 @.Extra `endgroup'@>
21981 help2("I'm not currently working on a `begingroup',",
21982 "so I had better not try to end anything.");
21983 mp_flush_error(mp, 0);
21985 } while (mp->cur_cmd!=stop);
21987 int mp_run (MP mp) {
21988 if (mp->history < mp_fatal_error_stop ) {
21989 xfree(mp->jump_buf);
21990 mp->jump_buf = malloc(sizeof(jmp_buf));
21991 if (mp->jump_buf == NULL || setjmp(*(mp->jump_buf)) != 0)
21992 return mp->history;
21993 mp_main_control(mp); /* come to life */
21994 mp_final_cleanup(mp); /* prepare for death */
21995 mp_close_files_and_terminate(mp);
21997 return mp->history;
22000 @ For |mp_execute|, we need to define a structure to store the
22001 redirected input and output. This structure holds the five relevant
22002 streams: the three informational output streams, the PostScript
22003 generation stream, and the input stream. These streams have many
22004 things in common, so it makes sense to give them their own structure
22007 \item{fptr} is a virtual file pointer
22008 \item{data} is the data this stream holds
22009 \item{cur} is a cursor pointing into |data|
22010 \item{size} is the allocated length of the data stream
22011 \item{used} is the actual length of the data stream
22013 There are small differences between input and output: |term_in| never
22014 uses |used|, whereas the other four never use |cur|.
22016 @<Exported types@>=
22026 mp_stream term_out;
22027 mp_stream error_out;
22031 struct mp_edge_object *edges;
22034 @ We need a function to clear an output stream, this is called at the
22035 beginning of |mp_execute|. We also need one for destroying an output
22036 stream, this is called just before a stream is (re)opened.
22039 static void mp_reset_stream(mp_stream *str) {
22045 static void mp_free_stream(mp_stream *str) {
22047 mp_reset_stream(str);
22050 @ @<Declarations@>=
22051 static void mp_reset_stream(mp_stream *str);
22052 static void mp_free_stream(mp_stream *str);
22054 @ The global instance contains a pointer instead of the actual structure
22055 even though it is essentially static, because that makes it is easier to move
22059 mp_run_data run_data;
22061 @ Another type is needed: the indirection will overload some of the
22062 file pointer objects in the instance (but not all). For clarity, an
22063 indirect object is used that wraps a |FILE *|.
22066 typedef struct File {
22070 @ Here are all of the functions that need to be overloaded for |mp_execute|.
22073 static void *mplib_open_file(MP mp, const char *fname, const char *fmode, int ftype);
22074 static int mplib_get_char(void *f, mp_run_data * mplib_data);
22075 static void mplib_unget_char(void *f, mp_run_data * mplib_data, int c);
22076 static char *mplib_read_ascii_file(MP mp, void *ff, size_t * size);
22077 static void mplib_write_ascii_file(MP mp, void *ff, const char *s);
22078 static void mplib_read_binary_file(MP mp, void *ff, void **data, size_t * size);
22079 static void mplib_write_binary_file(MP mp, void *ff, void *s, size_t size);
22080 static void mplib_close_file(MP mp, void *ff);
22081 static int mplib_eof_file(MP mp, void *ff);
22082 static void mplib_flush_file(MP mp, void *ff);
22083 static void mplib_shipout_backend(MP mp, int h);
22085 @ The |xmalloc(1,1)| calls make sure the stored indirection values are unique.
22087 @d reset_stream(a) do {
22088 mp_reset_stream(&(a));
22090 ff->f = xmalloc(1,1);
22096 static void *mplib_open_file(MP mp, const char *fname, const char *fmode, int ftype)
22098 File *ff = xmalloc(1, sizeof(File));
22099 mp_run_data *run = mp_rundata(mp);
22101 if (ftype == mp_filetype_terminal) {
22102 if (fmode[0] == 'r') {
22104 ff->f = xmalloc(1,1);
22105 run->term_in.fptr = ff->f;
22108 reset_stream(run->term_out);
22110 } else if (ftype == mp_filetype_error) {
22111 reset_stream(run->error_out);
22112 } else if (ftype == mp_filetype_log) {
22113 reset_stream(run->log_out);
22114 } else if (ftype == mp_filetype_postscript) {
22115 mp_free_stream(&(run->ps_out));
22116 ff->f = xmalloc(1,1);
22117 run->ps_out.fptr = ff->f;
22120 char *f = (mp->find_file)(mp, fname, fmode, ftype);
22123 realmode[0] = *fmode;
22126 ff->f = fopen(f, realmode);
22128 if ((fmode[0] == 'r') && (ff->f == NULL)) {
22136 static int mplib_get_char(void *f, mp_run_data * run)
22139 if (f == run->term_in.fptr && run->term_in.data != NULL) {
22140 if (run->term_in.size == 0) {
22141 if (run->term_in.cur != NULL) {
22142 run->term_in.cur = NULL;
22144 xfree(run->term_in.data);
22148 run->term_in.size--;
22149 c = *(run->term_in.cur)++;
22157 static void mplib_unget_char(void *f, mp_run_data * run, int c)
22159 if (f == run->term_in.fptr && run->term_in.cur != NULL) {
22160 run->term_in.size++;
22161 run->term_in.cur--;
22168 static char *mplib_read_ascii_file(MP mp, void *ff, size_t * size)
22173 size_t len = 0, lim = 128;
22174 mp_run_data *run = mp_rundata(mp);
22175 FILE *f = ((File *) ff)->f;
22179 c = mplib_get_char(f, run);
22185 while (c != EOF && c != '\n' && c != '\r') {
22187 s = xrealloc(s, (lim + (lim >> 2)),1);
22193 c = mplib_get_char(f, run);
22196 c = mplib_get_char(f, run);
22197 if (c != EOF && c != '\n')
22198 mplib_unget_char(f, run, c);
22206 static void mp_append_string (MP mp, mp_stream *a,const char *b) {
22207 size_t l = strlen(b);
22208 if ((a->used+l)>=a->size) {
22209 a->size += 256+(a->size)/5+l;
22210 a->data = xrealloc(a->data,a->size,1);
22212 (void)strcpy(a->data+a->used,b);
22217 static void mplib_write_ascii_file(MP mp, void *ff, const char *s)
22220 void *f = ((File *) ff)->f;
22221 mp_run_data *run = mp_rundata(mp);
22223 if (f == run->term_out.fptr) {
22224 mp_append_string(mp,&(run->term_out), s);
22225 } else if (f == run->error_out.fptr) {
22226 mp_append_string(mp,&(run->error_out), s);
22227 } else if (f == run->log_out.fptr) {
22228 mp_append_string(mp,&(run->log_out), s);
22229 } else if (f == run->ps_out.fptr) {
22230 mp_append_string(mp,&(run->ps_out), s);
22232 fprintf((FILE *) f, "%s", s);
22238 static void mplib_read_binary_file(MP mp, void *ff, void **data, size_t * size)
22243 FILE *f = ((File *) ff)->f;
22245 len = fread(*data, 1, *size, f);
22250 static void mplib_write_binary_file(MP mp, void *ff, void *s, size_t size)
22254 FILE *f = ((File *) ff)->f;
22256 (void)fwrite(s, size, 1, f);
22260 static void mplib_close_file(MP mp, void *ff)
22263 mp_run_data *run = mp_rundata(mp);
22264 void *f = ((File *) ff)->f;
22266 if (f != run->term_out.fptr
22267 && f != run->error_out.fptr
22268 && f != run->log_out.fptr
22269 && f != run->ps_out.fptr
22270 && f != run->term_in.fptr) {
22278 static int mplib_eof_file(MP mp, void *ff)
22281 mp_run_data *run = mp_rundata(mp);
22282 FILE *f = ((File *) ff)->f;
22285 if (f == run->term_in.fptr && run->term_in.data != NULL) {
22286 return (run->term_in.size == 0);
22293 static void mplib_flush_file(MP mp, void *ff)
22300 static void mplib_shipout_backend(MP mp, int h)
22302 mp_edge_object *hh = mp_gr_export(mp, h);
22304 mp_run_data *run = mp_rundata(mp);
22305 if (run->edges==NULL) {
22308 mp_edge_object *p = run->edges;
22309 while (p->_next!=NULL) { p = p->_next; }
22316 @ This is where we fill them all in.
22317 @<Prepare function pointers for non-interactive use@>=
22319 mp->open_file = mplib_open_file;
22320 mp->close_file = mplib_close_file;
22321 mp->eof_file = mplib_eof_file;
22322 mp->flush_file = mplib_flush_file;
22323 mp->write_ascii_file = mplib_write_ascii_file;
22324 mp->read_ascii_file = mplib_read_ascii_file;
22325 mp->write_binary_file = mplib_write_binary_file;
22326 mp->read_binary_file = mplib_read_binary_file;
22327 mp->shipout_backend = mplib_shipout_backend;
22330 @ Perhaps this is the most important API function in the library.
22332 @<Exported function ...@>=
22333 extern mp_run_data *mp_rundata (MP mp) ;
22336 mp_run_data *mp_rundata (MP mp) {
22337 return &(mp->run_data);
22341 mp_free_stream(&(mp->run_data.term_in));
22342 mp_free_stream(&(mp->run_data.term_out));
22343 mp_free_stream(&(mp->run_data.log_out));
22344 mp_free_stream(&(mp->run_data.error_out));
22345 mp_free_stream(&(mp->run_data.ps_out));
22347 @ @<Finish non-interactive use@>=
22348 xfree(mp->term_out);
22349 xfree(mp->term_in);
22350 xfree(mp->err_out);
22352 @ @<Start non-interactive work@>=
22353 @<Initialize the output routines@>;
22354 mp->input_ptr=0; mp->max_in_stack=0;
22355 mp->in_open=0; mp->open_parens=0; mp->max_buf_stack=0;
22356 mp->param_ptr=0; mp->max_param_stack=0;
22357 start = loc = iindex = 0; mp->first = 0;
22358 line=0; name=is_term;
22359 mp->mpx_name[0]=absent;
22360 mp->force_eof=false;
22362 mp->scanner_status=normal;
22363 if (mp->mem_ident==NULL) {
22364 if ( ! mp_load_mem_file(mp) ) {
22365 (mp->close_file)(mp, mp->mem_file);
22366 mp->history = mp_fatal_error_stop;
22367 return mp->history;
22369 (mp->close_file)(mp, mp->mem_file);
22371 mp_fix_date_and_time(mp);
22372 if (mp->random_seed==0)
22373 mp->random_seed = (mp->internal[mp_time] / unity)+mp->internal[mp_day];
22374 mp_init_randoms(mp, mp->random_seed);
22375 @<Initialize the print |selector|...@>;
22376 mp_open_log_file(mp);
22378 mp_init_map_file(mp, mp->troff_mode);
22379 mp->history=mp_spotless; /* ready to go! */
22380 if (mp->troff_mode) {
22381 mp->internal[mp_gtroffmode]=unity;
22382 mp->internal[mp_prologues]=unity;
22384 if ( mp->start_sym>0 ) { /* insert the `\&{everyjob}' symbol */
22385 mp->cur_sym=mp->start_sym; mp_back_input(mp);
22389 int mp_execute (MP mp, char *s, size_t l) {
22390 mp_reset_stream(&(mp->run_data.term_out));
22391 mp_reset_stream(&(mp->run_data.log_out));
22392 mp_reset_stream(&(mp->run_data.error_out));
22393 mp_reset_stream(&(mp->run_data.ps_out));
22394 if (mp->finished) {
22395 return mp->history;
22396 } else if (!mp->noninteractive) {
22397 mp->history = mp_fatal_error_stop ;
22398 return mp->history;
22400 if (mp->history < mp_fatal_error_stop ) {
22401 xfree(mp->jump_buf);
22402 mp->jump_buf = malloc(sizeof(jmp_buf));
22403 if (mp->jump_buf == NULL || setjmp(*(mp->jump_buf)) != 0) {
22404 return mp->history;
22406 if (s==NULL) { /* this signals EOF */
22407 mp_final_cleanup(mp); /* prepare for death */
22408 mp_close_files_and_terminate(mp);
22409 return mp->history;
22412 mp->term_offset=0; mp->file_offset=0;
22413 /* Perhaps some sort of warning here when |data| is not
22414 * yet exhausted would be nice ... this happens after errors
22416 if (mp->run_data.term_in.data)
22417 xfree(mp->run_data.term_in.data);
22418 mp->run_data.term_in.data = xstrdup(s);
22419 mp->run_data.term_in.cur = mp->run_data.term_in.data;
22420 mp->run_data.term_in.size = l;
22421 if (mp->run_state == 0) {
22422 mp->selector=term_only;
22423 @<Start non-interactive work@>;
22426 (void)mp_input_ln(mp,mp->term_in);
22427 mp_firm_up_the_line(mp);
22428 mp->buffer[limit]=xord('%');
22429 mp->first=(size_t)(limit+1);
22432 mp_do_statement(mp);
22433 } while (mp->cur_cmd!=stop);
22434 mp_final_cleanup(mp);
22435 mp_close_files_and_terminate(mp);
22437 return mp->history;
22440 @ This function cleans up
22442 int mp_finish (MP mp) {
22444 if (mp->finished || mp->history >= mp_fatal_error_stop) {
22445 history = mp->history;
22449 xfree(mp->jump_buf);
22450 mp->jump_buf = malloc(sizeof(jmp_buf));
22451 if (mp->jump_buf == NULL || setjmp(*(mp->jump_buf)) != 0) {
22452 history = mp->history;
22454 history = mp->history;
22455 mp_final_cleanup(mp); /* prepare for death */
22457 mp_close_files_and_terminate(mp);
22462 @ People may want to know the library version
22464 char * mp_metapost_version (void) {
22465 return mp_strdup(metapost_version);
22468 @ @<Exported function headers@>=
22469 int mp_run (MP mp);
22470 int mp_execute (MP mp, char *s, size_t l);
22471 int mp_finish (MP mp);
22472 char * mp_metapost_version (void);
22475 mp_primitive(mp, "end",stop,0);
22476 @:end_}{\&{end} primitive@>
22477 mp_primitive(mp, "dump",stop,1);
22478 @:dump_}{\&{dump} primitive@>
22480 @ @<Cases of |print_cmd...@>=
22482 if ( m==0 ) mp_print(mp, "end");
22483 else mp_print(mp, "dump");
22487 Let's turn now to statements that are classified as ``commands'' because
22488 of their imperative nature. We'll begin with simple ones, so that it
22489 will be clear how to hook command processing into the |do_statement| routine;
22490 then we'll tackle the tougher commands.
22492 Here's one of the simplest:
22494 @<Cases of |do_statement|...@>=
22495 case mp_random_seed: mp_do_random_seed(mp); break;
22497 @ @<Declare action procedures for use by |do_statement|@>=
22498 static void mp_do_random_seed (MP mp) ;
22500 @ @c void mp_do_random_seed (MP mp) {
22502 if ( mp->cur_cmd!=assignment ) {
22503 mp_missing_err(mp, ":=");
22505 help1("Always say `randomseed:=<numeric expression>'.");
22508 mp_get_x_next(mp); mp_scan_expression(mp);
22509 if ( mp->cur_type!=mp_known ) {
22510 exp_err("Unknown value will be ignored");
22511 @.Unknown value...ignored@>
22512 help2("Your expression was too random for me to handle,",
22513 "so I won't change the random seed just now.");
22514 mp_put_get_flush_error(mp, 0);
22516 @<Initialize the random seed to |cur_exp|@>;
22520 @ @<Initialize the random seed to |cur_exp|@>=
22522 mp_init_randoms(mp, mp->cur_exp);
22523 if ( mp->selector>=log_only && mp->selector<write_file) {
22524 mp->old_setting=mp->selector; mp->selector=log_only;
22525 mp_print_nl(mp, "{randomseed:=");
22526 mp_print_scaled(mp, mp->cur_exp);
22527 mp_print_char(mp, xord('}'));
22528 mp_print_nl(mp, ""); mp->selector=mp->old_setting;
22532 @ And here's another simple one (somewhat different in flavor):
22534 @<Cases of |do_statement|...@>=
22536 mp_print_ln(mp); mp->interaction=mp->cur_mod;
22537 @<Initialize the print |selector| based on |interaction|@>;
22538 if ( mp->log_opened ) mp->selector=mp->selector+2;
22543 mp_primitive(mp, "batchmode",mode_command,mp_batch_mode);
22544 @:mp_batch_mode_}{\&{batchmode} primitive@>
22545 mp_primitive(mp, "nonstopmode",mode_command,mp_nonstop_mode);
22546 @:mp_nonstop_mode_}{\&{nonstopmode} primitive@>
22547 mp_primitive(mp, "scrollmode",mode_command,mp_scroll_mode);
22548 @:mp_scroll_mode_}{\&{scrollmode} primitive@>
22549 mp_primitive(mp, "errorstopmode",mode_command,mp_error_stop_mode);
22550 @:mp_error_stop_mode_}{\&{errorstopmode} primitive@>
22552 @ @<Cases of |print_cmd_mod|...@>=
22555 case mp_batch_mode: mp_print(mp, "batchmode"); break;
22556 case mp_nonstop_mode: mp_print(mp, "nonstopmode"); break;
22557 case mp_scroll_mode: mp_print(mp, "scrollmode"); break;
22558 default: mp_print(mp, "errorstopmode"); break;
22562 @ The `\&{inner}' and `\&{outer}' commands are only slightly harder.
22564 @<Cases of |do_statement|...@>=
22565 case protection_command: mp_do_protection(mp); break;
22568 mp_primitive(mp, "inner",protection_command,0);
22569 @:inner_}{\&{inner} primitive@>
22570 mp_primitive(mp, "outer",protection_command,1);
22571 @:outer_}{\&{outer} primitive@>
22573 @ @<Cases of |print_cmd...@>=
22574 case protection_command:
22575 if ( m==0 ) mp_print(mp, "inner");
22576 else mp_print(mp, "outer");
22579 @ @<Declare action procedures for use by |do_statement|@>=
22580 static void mp_do_protection (MP mp) ;
22582 @ @c void mp_do_protection (MP mp) {
22583 int m; /* 0 to unprotect, 1 to protect */
22584 halfword t; /* the |eq_type| before we change it */
22587 mp_get_symbol(mp); t=eq_type(mp->cur_sym);
22589 if ( t>=outer_tag )
22590 eq_type(mp->cur_sym)=t-outer_tag;
22591 } else if ( t<outer_tag ) {
22592 eq_type(mp->cur_sym)=t+outer_tag;
22595 } while (mp->cur_cmd==comma);
22598 @ \MP\ never defines the tokens `\.(' and `\.)' to be primitives, but
22599 plain \MP\ begins with the declaration `\&{delimiters} \.{()}'. Such a
22600 declaration assigns the command code |left_delimiter| to `\.{(}' and
22601 |right_delimiter| to `\.{)}'; the |equiv| of each delimiter is the
22602 hash address of its mate.
22604 @<Cases of |do_statement|...@>=
22605 case delimiters: mp_def_delims(mp); break;
22607 @ @<Declare action procedures for use by |do_statement|@>=
22608 static void mp_def_delims (MP mp) ;
22610 @ @c void mp_def_delims (MP mp) {
22611 pointer l_delim,r_delim; /* the new delimiter pair */
22612 mp_get_clear_symbol(mp); l_delim=mp->cur_sym;
22613 mp_get_clear_symbol(mp); r_delim=mp->cur_sym;
22614 eq_type(l_delim)=left_delimiter; equiv(l_delim)=r_delim;
22615 eq_type(r_delim)=right_delimiter; equiv(r_delim)=l_delim;
22619 @ Here is a procedure that is called when \MP\ has reached a point
22620 where some right delimiter is mandatory.
22623 static void mp_check_delimiter (MP mp,pointer l_delim, pointer r_delim);
22626 void mp_check_delimiter (MP mp,pointer l_delim, pointer r_delim) {
22627 if ( mp->cur_cmd==right_delimiter )
22628 if ( mp->cur_mod==l_delim )
22630 if ( mp->cur_sym!=r_delim ) {
22631 mp_missing_err(mp, str(text(r_delim)));
22633 help2("I found no right delimiter to match a left one. So I've",
22634 "put one in, behind the scenes; this may fix the problem.");
22637 print_err("The token `"); mp_print_text(r_delim);
22638 @.The token...delimiter@>
22639 mp_print(mp, "' is no longer a right delimiter");
22640 help3("Strange: This token has lost its former meaning!",
22641 "I'll read it as a right delimiter this time;",
22642 "but watch out, I'll probably miss it later.");
22647 @ The next four commands save or change the values associated with tokens.
22649 @<Cases of |do_statement|...@>=
22652 mp_get_symbol(mp); mp_save_variable(mp, mp->cur_sym); mp_get_x_next(mp);
22653 } while (mp->cur_cmd==comma);
22655 case interim_command: mp_do_interim(mp); break;
22656 case let_command: mp_do_let(mp); break;
22657 case new_internal: mp_do_new_internal(mp); break;
22659 @ @<Declare action procedures for use by |do_statement|@>=
22660 static void mp_do_statement (MP mp);
22661 static void mp_do_interim (MP mp);
22663 @ @c void mp_do_interim (MP mp) {
22665 if ( mp->cur_cmd!=internal_quantity ) {
22666 print_err("The token `");
22667 @.The token...quantity@>
22668 if ( mp->cur_sym==0 ) mp_print(mp, "(%CAPSULE)");
22669 else mp_print_text(mp->cur_sym);
22670 mp_print(mp, "' isn't an internal quantity");
22671 help1("Something like `tracingonline' should follow `interim'.");
22674 mp_save_internal(mp, mp->cur_mod); mp_back_input(mp);
22676 mp_do_statement(mp);
22679 @ The following procedure is careful not to undefine the left-hand symbol
22680 too soon, lest commands like `{\tt let x=x}' have a surprising effect.
22682 @<Declare action procedures for use by |do_statement|@>=
22683 static void mp_do_let (MP mp) ;
22685 @ @c void mp_do_let (MP mp) {
22686 pointer l; /* hash location of the left-hand symbol */
22687 mp_get_symbol(mp); l=mp->cur_sym; mp_get_x_next(mp);
22688 if ( mp->cur_cmd!=equals ) if ( mp->cur_cmd!=assignment ) {
22689 mp_missing_err(mp, "=");
22691 help3("You should have said `let symbol = something'.",
22692 "But don't worry; I'll pretend that an equals sign",
22693 "was present. The next token I read will be `something'.");
22697 switch (mp->cur_cmd) {
22698 case defined_macro: case secondary_primary_macro:
22699 case tertiary_secondary_macro: case expression_tertiary_macro:
22700 add_mac_ref(mp->cur_mod);
22705 mp_clear_symbol(mp, l,false); eq_type(l)=mp->cur_cmd;
22706 if ( mp->cur_cmd==tag_token ) equiv(l)=null;
22707 else equiv(l)=mp->cur_mod;
22711 @ @<Declarations@>=
22712 static void mp_grow_internals (MP mp, int l);
22713 static void mp_do_new_internal (MP mp) ;
22716 void mp_grow_internals (MP mp, int l) {
22720 if ( hash_end+l>max_halfword ) {
22721 mp_confusion(mp, "out of memory space"); /* can't be reached */
22723 int_name = xmalloc ((l+1),sizeof(char *));
22724 internal = xmalloc ((l+1),sizeof(scaled));
22725 for (k=0;k<=l; k++ ) {
22726 if (k<=mp->max_internal) {
22727 internal[k]=mp->internal[k];
22728 int_name[k]=mp->int_name[k];
22734 xfree(mp->internal); xfree(mp->int_name);
22735 mp->int_name = int_name;
22736 mp->internal = internal;
22737 mp->max_internal = l;
22740 void mp_do_new_internal (MP mp) {
22742 if ( mp->int_ptr==mp->max_internal ) {
22743 mp_grow_internals(mp, (mp->max_internal + (mp->max_internal/4)));
22745 mp_get_clear_symbol(mp); incr(mp->int_ptr);
22746 eq_type(mp->cur_sym)=internal_quantity;
22747 equiv(mp->cur_sym)=mp->int_ptr;
22748 if(mp->int_name[mp->int_ptr]!=NULL)
22749 xfree(mp->int_name[mp->int_ptr]);
22750 mp->int_name[mp->int_ptr]=str(text(mp->cur_sym));
22751 mp->internal[mp->int_ptr]=0;
22753 } while (mp->cur_cmd==comma);
22756 @ @<Dealloc variables@>=
22757 for (k=0;k<=mp->max_internal;k++) {
22758 xfree(mp->int_name[k]);
22760 xfree(mp->internal);
22761 xfree(mp->int_name);
22764 @ The various `\&{show}' commands are distinguished by modifier fields
22767 @d show_token_code 0 /* show the meaning of a single token */
22768 @d show_stats_code 1 /* show current memory and string usage */
22769 @d show_code 2 /* show a list of expressions */
22770 @d show_var_code 3 /* show a variable and its descendents */
22771 @d show_dependencies_code 4 /* show dependent variables in terms of independents */
22774 mp_primitive(mp, "showtoken",show_command,show_token_code);
22775 @:show_token_}{\&{showtoken} primitive@>
22776 mp_primitive(mp, "showstats",show_command,show_stats_code);
22777 @:show_stats_}{\&{showstats} primitive@>
22778 mp_primitive(mp, "show",show_command,show_code);
22779 @:show_}{\&{show} primitive@>
22780 mp_primitive(mp, "showvariable",show_command,show_var_code);
22781 @:show_var_}{\&{showvariable} primitive@>
22782 mp_primitive(mp, "showdependencies",show_command,show_dependencies_code);
22783 @:show_dependencies_}{\&{showdependencies} primitive@>
22785 @ @<Cases of |print_cmd...@>=
22788 case show_token_code:mp_print(mp, "showtoken"); break;
22789 case show_stats_code:mp_print(mp, "showstats"); break;
22790 case show_code:mp_print(mp, "show"); break;
22791 case show_var_code:mp_print(mp, "showvariable"); break;
22792 default: mp_print(mp, "showdependencies"); break;
22796 @ @<Cases of |do_statement|...@>=
22797 case show_command:mp_do_show_whatever(mp); break;
22799 @ The value of |cur_mod| controls the |verbosity| in the |print_exp| routine:
22800 if it's |show_code|, complicated structures are abbreviated, otherwise
22803 @<Declare action procedures for use by |do_statement|@>=
22804 static void mp_do_show (MP mp) ;
22806 @ @c void mp_do_show (MP mp) {
22808 mp_get_x_next(mp); mp_scan_expression(mp);
22809 mp_print_nl(mp, ">> ");
22811 mp_print_exp(mp, null,2); mp_flush_cur_exp(mp, 0);
22812 } while (mp->cur_cmd==comma);
22815 @ @<Declare action procedures for use by |do_statement|@>=
22816 static void mp_disp_token (MP mp) ;
22818 @ @c void mp_disp_token (MP mp) {
22819 mp_print_nl(mp, "> ");
22821 if ( mp->cur_sym==0 ) {
22822 @<Show a numeric or string or capsule token@>;
22824 mp_print_text(mp->cur_sym); mp_print_char(mp, xord('='));
22825 if ( eq_type(mp->cur_sym)>=outer_tag ) mp_print(mp, "(outer) ");
22826 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod);
22827 if ( mp->cur_cmd==defined_macro ) {
22828 mp_print_ln(mp); mp_show_macro(mp, mp->cur_mod,null,100000);
22829 } /* this avoids recursion between |show_macro| and |print_cmd_mod| */
22834 @ @<Show a numeric or string or capsule token@>=
22836 if ( mp->cur_cmd==numeric_token ) {
22837 mp_print_scaled(mp, mp->cur_mod);
22838 } else if ( mp->cur_cmd==capsule_token ) {
22839 mp_print_capsule(mp,mp->cur_mod);
22841 mp_print_char(mp, xord('"'));
22842 mp_print_str(mp, mp->cur_mod); mp_print_char(mp, xord('"'));
22843 delete_str_ref(mp->cur_mod);
22847 @ The following cases of |print_cmd_mod| might arise in connection
22848 with |disp_token|, although they don't necessarily correspond to
22851 @<Cases of |print_cmd_...@>=
22852 case left_delimiter:
22853 case right_delimiter:
22854 if ( c==left_delimiter ) mp_print(mp, "left");
22855 else mp_print(mp, "right");
22856 mp_print(mp, " delimiter that matches ");
22860 if ( m==null ) mp_print(mp, "tag");
22861 else mp_print(mp, "variable");
22863 case defined_macro:
22864 mp_print(mp, "macro:");
22866 case secondary_primary_macro:
22867 case tertiary_secondary_macro:
22868 case expression_tertiary_macro:
22869 mp_print_cmd_mod(mp, macro_def,c);
22870 mp_print(mp, "'d macro:");
22871 mp_print_ln(mp); mp_show_token_list(mp, mp_link(mp_link(m)),null,1000,0);
22874 mp_print(mp, "[repeat the loop]");
22876 case internal_quantity:
22877 mp_print(mp, mp->int_name[m]);
22880 @ @<Declare action procedures for use by |do_statement|@>=
22881 static void mp_do_show_token (MP mp) ;
22883 @ @c void mp_do_show_token (MP mp) {
22885 get_t_next; mp_disp_token(mp);
22887 } while (mp->cur_cmd==comma);
22890 @ @<Declare action procedures for use by |do_statement|@>=
22891 static void mp_do_show_stats (MP mp) ;
22893 @ @c void mp_do_show_stats (MP mp) {
22894 mp_print_nl(mp, "Memory usage ");
22895 @.Memory usage...@>
22896 mp_print_int(mp, mp->var_used); mp_print_char(mp, xord('&')); mp_print_int(mp, mp->dyn_used);
22897 mp_print(mp, " ("); mp_print_int(mp, mp->hi_mem_min-mp->lo_mem_max-1);
22898 mp_print(mp, " still untouched)"); mp_print_ln(mp);
22899 mp_print_nl(mp, "String usage ");
22900 mp_print_int(mp, mp->strs_in_use-mp->init_str_use);
22901 mp_print_char(mp, xord('&')); mp_print_int(mp, mp->pool_in_use-mp->init_pool_ptr);
22902 mp_print(mp, " (");
22903 mp_print_int(mp, mp->max_strings-1-mp->strs_used_up); mp_print_char(mp, xord('&'));
22904 mp_print_int(mp, mp->pool_size-mp->pool_ptr);
22905 mp_print(mp, " now untouched)"); mp_print_ln(mp);
22909 @ Here's a recursive procedure that gives an abbreviated account
22910 of a variable, for use by |do_show_var|.
22912 @<Declare action procedures for use by |do_statement|@>=
22913 static void mp_disp_var (MP mp,pointer p) ;
22915 @ @c void mp_disp_var (MP mp,pointer p) {
22916 pointer q; /* traverses attributes and subscripts */
22917 int n; /* amount of macro text to show */
22918 if ( type(p)==mp_structured ) {
22919 @<Descend the structure@>;
22920 } else if ( type(p)>=mp_unsuffixed_macro ) {
22921 @<Display a variable macro@>;
22922 } else if ( type(p)!=undefined ){
22923 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22924 mp_print_char(mp, xord('='));
22925 mp_print_exp(mp, p,0);
22929 @ @<Descend the structure@>=
22932 do { mp_disp_var(mp, q); q=mp_link(q); } while (q!=end_attr);
22934 while ( name_type(q)==mp_subscr ) {
22935 mp_disp_var(mp, q); q=mp_link(q);
22939 @ @<Display a variable macro@>=
22941 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22942 if ( type(p)>mp_unsuffixed_macro )
22943 mp_print(mp, "@@#"); /* |suffixed_macro| */
22944 mp_print(mp, "=macro:");
22945 if ( (int)mp->file_offset>=mp->max_print_line-20 ) n=5;
22946 else n=mp->max_print_line-mp->file_offset-15;
22947 mp_show_macro(mp, value(p),null,n);
22950 @ @<Declare action procedures for use by |do_statement|@>=
22951 static void mp_do_show_var (MP mp) ;
22953 @ @c void mp_do_show_var (MP mp) {
22956 if ( mp->cur_sym>0 ) if ( mp->cur_sym<=hash_end )
22957 if ( mp->cur_cmd==tag_token ) if ( mp->cur_mod!=null ) {
22958 mp_disp_var(mp, mp->cur_mod); goto DONE;
22963 } while (mp->cur_cmd==comma);
22966 @ @<Declare action procedures for use by |do_statement|@>=
22967 static void mp_do_show_dependencies (MP mp) ;
22969 @ @c void mp_do_show_dependencies (MP mp) {
22970 pointer p; /* link that runs through all dependencies */
22971 p=mp_link(dep_head);
22972 while ( p!=dep_head ) {
22973 if ( mp_interesting(mp, p) ) {
22974 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22975 if ( type(p)==mp_dependent ) mp_print_char(mp, xord('='));
22976 else mp_print(mp, " = "); /* extra spaces imply proto-dependency */
22977 mp_print_dependency(mp, dep_list(p),type(p));
22980 while ( info(p)!=null ) p=mp_link(p);
22986 @ Finally we are ready for the procedure that governs all of the
22989 @<Declare action procedures for use by |do_statement|@>=
22990 static void mp_do_show_whatever (MP mp) ;
22992 @ @c void mp_do_show_whatever (MP mp) {
22993 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
22994 switch (mp->cur_mod) {
22995 case show_token_code:mp_do_show_token(mp); break;
22996 case show_stats_code:mp_do_show_stats(mp); break;
22997 case show_code:mp_do_show(mp); break;
22998 case show_var_code:mp_do_show_var(mp); break;
22999 case show_dependencies_code:mp_do_show_dependencies(mp); break;
23000 } /* there are no other cases */
23001 if ( mp->internal[mp_showstopping]>0 ){
23004 if ( mp->interaction<mp_error_stop_mode ) {
23005 help0; decr(mp->error_count);
23007 help1("This isn't an error message; I'm just showing something.");
23009 if ( mp->cur_cmd==semicolon ) mp_error(mp);
23010 else mp_put_get_error(mp);
23014 @ The `\&{addto}' command needs the following additional primitives:
23016 @d double_path_code 0 /* command modifier for `\&{doublepath}' */
23017 @d contour_code 1 /* command modifier for `\&{contour}' */
23018 @d also_code 2 /* command modifier for `\&{also}' */
23020 @ Pre and postscripts need two new identifiers:
23022 @d with_pre_script 11
23023 @d with_post_script 13
23026 mp_primitive(mp, "doublepath",thing_to_add,double_path_code);
23027 @:double_path_}{\&{doublepath} primitive@>
23028 mp_primitive(mp, "contour",thing_to_add,contour_code);
23029 @:contour_}{\&{contour} primitive@>
23030 mp_primitive(mp, "also",thing_to_add,also_code);
23031 @:also_}{\&{also} primitive@>
23032 mp_primitive(mp, "withpen",with_option,mp_pen_type);
23033 @:with_pen_}{\&{withpen} primitive@>
23034 mp_primitive(mp, "dashed",with_option,mp_picture_type);
23035 @:dashed_}{\&{dashed} primitive@>
23036 mp_primitive(mp, "withprescript",with_option,with_pre_script);
23037 @:with_pre_script_}{\&{withprescript} primitive@>
23038 mp_primitive(mp, "withpostscript",with_option,with_post_script);
23039 @:with_post_script_}{\&{withpostscript} primitive@>
23040 mp_primitive(mp, "withoutcolor",with_option,mp_no_model);
23041 @:with_color_}{\&{withoutcolor} primitive@>
23042 mp_primitive(mp, "withgreyscale",with_option,mp_grey_model);
23043 @:with_color_}{\&{withgreyscale} primitive@>
23044 mp_primitive(mp, "withcolor",with_option,mp_uninitialized_model);
23045 @:with_color_}{\&{withcolor} primitive@>
23046 /* \&{withrgbcolor} is an alias for \&{withcolor} */
23047 mp_primitive(mp, "withrgbcolor",with_option,mp_rgb_model);
23048 @:with_color_}{\&{withrgbcolor} primitive@>
23049 mp_primitive(mp, "withcmykcolor",with_option,mp_cmyk_model);
23050 @:with_color_}{\&{withcmykcolor} primitive@>
23052 @ @<Cases of |print_cmd...@>=
23054 if ( m==contour_code ) mp_print(mp, "contour");
23055 else if ( m==double_path_code ) mp_print(mp, "doublepath");
23056 else mp_print(mp, "also");
23059 if ( m==mp_pen_type ) mp_print(mp, "withpen");
23060 else if ( m==with_pre_script ) mp_print(mp, "withprescript");
23061 else if ( m==with_post_script ) mp_print(mp, "withpostscript");
23062 else if ( m==mp_no_model ) mp_print(mp, "withoutcolor");
23063 else if ( m==mp_rgb_model ) mp_print(mp, "withrgbcolor");
23064 else if ( m==mp_uninitialized_model ) mp_print(mp, "withcolor");
23065 else if ( m==mp_cmyk_model ) mp_print(mp, "withcmykcolor");
23066 else if ( m==mp_grey_model ) mp_print(mp, "withgreyscale");
23067 else mp_print(mp, "dashed");
23070 @ The |scan_with_list| procedure parses a $\langle$with list$\rangle$ and
23071 updates the list of graphical objects starting at |p|. Each $\langle$with
23072 clause$\rangle$ updates all graphical objects whose |type| is compatible.
23073 Other objects are ignored.
23075 @<Declare action procedures for use by |do_statement|@>=
23076 static void mp_scan_with_list (MP mp,pointer p) ;
23078 @ @c void mp_scan_with_list (MP mp,pointer p) {
23079 quarterword t; /* |cur_mod| of the |with_option| (should match |cur_type|) */
23080 pointer q; /* for list manipulation */
23081 unsigned old_setting; /* saved |selector| setting */
23082 pointer k; /* for finding the near-last item in a list */
23083 str_number s; /* for string cleanup after combining */
23084 pointer cp,pp,dp,ap,bp;
23085 /* objects being updated; |void| initially; |null| to suppress update */
23086 cp=mp_void; pp=mp_void; dp=mp_void; ap=mp_void; bp=mp_void;
23088 while ( mp->cur_cmd==with_option ){
23091 if ( t!=mp_no_model ) mp_scan_expression(mp);
23092 if (((t==with_pre_script)&&(mp->cur_type!=mp_string_type))||
23093 ((t==with_post_script)&&(mp->cur_type!=mp_string_type))||
23094 ((t==mp_uninitialized_model)&&
23095 ((mp->cur_type!=mp_cmykcolor_type)&&(mp->cur_type!=mp_color_type)
23096 &&(mp->cur_type!=mp_known)&&(mp->cur_type!=mp_boolean_type)))||
23097 ((t==mp_cmyk_model)&&(mp->cur_type!=mp_cmykcolor_type))||
23098 ((t==mp_rgb_model)&&(mp->cur_type!=mp_color_type))||
23099 ((t==mp_grey_model)&&(mp->cur_type!=mp_known))||
23100 ((t==mp_pen_type)&&(mp->cur_type!=t))||
23101 ((t==mp_picture_type)&&(mp->cur_type!=t)) ) {
23102 @<Complain about improper type@>;
23103 } else if ( t==mp_uninitialized_model ) {
23104 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
23106 @<Transfer a color from the current expression to object~|cp|@>;
23107 mp_flush_cur_exp(mp, 0);
23108 } else if ( t==mp_rgb_model ) {
23109 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
23111 @<Transfer a rgbcolor from the current expression to object~|cp|@>;
23112 mp_flush_cur_exp(mp, 0);
23113 } else if ( t==mp_cmyk_model ) {
23114 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
23116 @<Transfer a cmykcolor from the current expression to object~|cp|@>;
23117 mp_flush_cur_exp(mp, 0);
23118 } else if ( t==mp_grey_model ) {
23119 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
23121 @<Transfer a greyscale from the current expression to object~|cp|@>;
23122 mp_flush_cur_exp(mp, 0);
23123 } else if ( t==mp_no_model ) {
23124 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
23126 @<Transfer a noncolor from the current expression to object~|cp|@>;
23127 } else if ( t==mp_pen_type ) {
23128 if ( pp==mp_void ) @<Make |pp| an object in list~|p| that needs a pen@>;
23130 if ( pen_p(pp)!=null ) mp_toss_knot_list(mp, pen_p(pp));
23131 pen_p(pp)=mp->cur_exp; mp->cur_type=mp_vacuous;
23133 } else if ( t==with_pre_script ) {
23136 while ( (ap!=null)&&(! has_color(ap)) )
23139 if ( pre_script(ap)!=null ) { /* build a new,combined string */
23141 old_setting=mp->selector;
23142 mp->selector=new_string;
23143 str_room(length(pre_script(ap))+length(mp->cur_exp)+2);
23144 mp_print_str(mp, mp->cur_exp);
23145 append_char(13); /* a forced \ps\ newline */
23146 mp_print_str(mp, pre_script(ap));
23147 pre_script(ap)=mp_make_string(mp);
23149 mp->selector=old_setting;
23151 pre_script(ap)=mp->cur_exp;
23153 mp->cur_type=mp_vacuous;
23155 } else if ( t==with_post_script ) {
23159 while ( mp_link(k)!=null ) {
23161 if ( has_color(k) ) bp=k;
23164 if ( post_script(bp)!=null ) {
23166 old_setting=mp->selector;
23167 mp->selector=new_string;
23168 str_room(length(post_script(bp))+length(mp->cur_exp)+2);
23169 mp_print_str(mp, post_script(bp));
23170 append_char(13); /* a forced \ps\ newline */
23171 mp_print_str(mp, mp->cur_exp);
23172 post_script(bp)=mp_make_string(mp);
23174 mp->selector=old_setting;
23176 post_script(bp)=mp->cur_exp;
23178 mp->cur_type=mp_vacuous;
23181 if ( dp==mp_void ) {
23182 @<Make |dp| a stroked node in list~|p|@>;
23185 if ( dash_p(dp)!=null ) delete_edge_ref(dash_p(dp));
23186 dash_p(dp)=mp_make_dashes(mp, mp->cur_exp);
23187 dash_scale(dp)=unity;
23188 mp->cur_type=mp_vacuous;
23192 @<Copy the information from objects |cp|, |pp|, and |dp| into the rest
23196 @ @<Complain about improper type@>=
23197 { exp_err("Improper type");
23199 help2("Next time say `withpen <known pen expression>';",
23200 "I'll ignore the bad `with' clause and look for another.");
23201 if ( t==with_pre_script )
23202 mp->help_line[1]="Next time say `withprescript <known string expression>';";
23203 else if ( t==with_post_script )
23204 mp->help_line[1]="Next time say `withpostscript <known string expression>';";
23205 else if ( t==mp_picture_type )
23206 mp->help_line[1]="Next time say `dashed <known picture expression>';";
23207 else if ( t==mp_uninitialized_model )
23208 mp->help_line[1]="Next time say `withcolor <known color expression>';";
23209 else if ( t==mp_rgb_model )
23210 mp->help_line[1]="Next time say `withrgbcolor <known color expression>';";
23211 else if ( t==mp_cmyk_model )
23212 mp->help_line[1]="Next time say `withcmykcolor <known cmykcolor expression>';";
23213 else if ( t==mp_grey_model )
23214 mp->help_line[1]="Next time say `withgreyscale <known numeric expression>';";;
23215 mp_put_get_flush_error(mp, 0);
23218 @ Forcing the color to be between |0| and |unity| here guarantees that no
23219 picture will ever contain a color outside the legal range for \ps\ graphics.
23221 @<Transfer a color from the current expression to object~|cp|@>=
23222 { if ( mp->cur_type==mp_color_type )
23223 @<Transfer a rgbcolor from the current expression to object~|cp|@>
23224 else if ( mp->cur_type==mp_cmykcolor_type )
23225 @<Transfer a cmykcolor from the current expression to object~|cp|@>
23226 else if ( mp->cur_type==mp_known )
23227 @<Transfer a greyscale from the current expression to object~|cp|@>
23228 else if ( mp->cur_exp==false_code )
23229 @<Transfer a noncolor from the current expression to object~|cp|@>;
23232 @ @<Transfer a rgbcolor from the current expression to object~|cp|@>=
23233 { q=value(mp->cur_exp);
23238 red_val(cp)=value(red_part_loc(q));
23239 green_val(cp)=value(green_part_loc(q));
23240 blue_val(cp)=value(blue_part_loc(q));
23241 color_model(cp)=mp_rgb_model;
23242 if ( red_val(cp)<0 ) red_val(cp)=0;
23243 if ( green_val(cp)<0 ) green_val(cp)=0;
23244 if ( blue_val(cp)<0 ) blue_val(cp)=0;
23245 if ( red_val(cp)>unity ) red_val(cp)=unity;
23246 if ( green_val(cp)>unity ) green_val(cp)=unity;
23247 if ( blue_val(cp)>unity ) blue_val(cp)=unity;
23250 @ @<Transfer a cmykcolor from the current expression to object~|cp|@>=
23251 { q=value(mp->cur_exp);
23252 cyan_val(cp)=value(cyan_part_loc(q));
23253 magenta_val(cp)=value(magenta_part_loc(q));
23254 yellow_val(cp)=value(yellow_part_loc(q));
23255 black_val(cp)=value(black_part_loc(q));
23256 color_model(cp)=mp_cmyk_model;
23257 if ( cyan_val(cp)<0 ) cyan_val(cp)=0;
23258 if ( magenta_val(cp)<0 ) magenta_val(cp)=0;
23259 if ( yellow_val(cp)<0 ) yellow_val(cp)=0;
23260 if ( black_val(cp)<0 ) black_val(cp)=0;
23261 if ( cyan_val(cp)>unity ) cyan_val(cp)=unity;
23262 if ( magenta_val(cp)>unity ) magenta_val(cp)=unity;
23263 if ( yellow_val(cp)>unity ) yellow_val(cp)=unity;
23264 if ( black_val(cp)>unity ) black_val(cp)=unity;
23267 @ @<Transfer a greyscale from the current expression to object~|cp|@>=
23274 color_model(cp)=mp_grey_model;
23275 if ( grey_val(cp)<0 ) grey_val(cp)=0;
23276 if ( grey_val(cp)>unity ) grey_val(cp)=unity;
23279 @ @<Transfer a noncolor from the current expression to object~|cp|@>=
23286 color_model(cp)=mp_no_model;
23289 @ @<Make |cp| a colored object in object list~|p|@>=
23291 while ( cp!=null ){
23292 if ( has_color(cp) ) break;
23297 @ @<Make |pp| an object in list~|p| that needs a pen@>=
23299 while ( pp!=null ) {
23300 if ( has_pen(pp) ) break;
23305 @ @<Make |dp| a stroked node in list~|p|@>=
23307 while ( dp!=null ) {
23308 if ( type(dp)==mp_stroked_code ) break;
23313 @ @<Copy the information from objects |cp|, |pp|, and |dp| into...@>=
23314 @<Copy |cp|'s color into the colored objects linked to~|cp|@>;
23315 if ( pp>mp_void ) {
23316 @<Copy |pen_p(pp)| into stroked and filled nodes linked to |pp|@>;
23318 if ( dp>mp_void ) {
23319 @<Make stroked nodes linked to |dp| refer to |dash_p(dp)|@>;
23323 @ @<Copy |cp|'s color into the colored objects linked to~|cp|@>=
23325 while ( q!=null ) {
23326 if ( has_color(q) ) {
23327 red_val(q)=red_val(cp);
23328 green_val(q)=green_val(cp);
23329 blue_val(q)=blue_val(cp);
23330 black_val(q)=black_val(cp);
23331 color_model(q)=color_model(cp);
23337 @ @<Copy |pen_p(pp)| into stroked and filled nodes linked to |pp|@>=
23339 while ( q!=null ) {
23340 if ( has_pen(q) ) {
23341 if ( pen_p(q)!=null ) mp_toss_knot_list(mp, pen_p(q));
23342 pen_p(q)=copy_pen(pen_p(pp));
23348 @ @<Make stroked nodes linked to |dp| refer to |dash_p(dp)|@>=
23350 while ( q!=null ) {
23351 if ( type(q)==mp_stroked_code ) {
23352 if ( dash_p(q)!=null ) delete_edge_ref(dash_p(q));
23353 dash_p(q)=dash_p(dp);
23354 dash_scale(q)=unity;
23355 if ( dash_p(q)!=null ) add_edge_ref(dash_p(q));
23361 @ One of the things we need to do when we've parsed an \&{addto} or
23362 similar command is find the header of a supposed \&{picture} variable, given
23363 a token list for that variable. Since the edge structure is about to be
23364 updated, we use |private_edges| to make sure that this is possible.
23366 @<Declare action procedures for use by |do_statement|@>=
23367 static pointer mp_find_edges_var (MP mp, pointer t) ;
23369 @ @c pointer mp_find_edges_var (MP mp, pointer t) {
23371 pointer cur_edges; /* the return value */
23372 p=mp_find_variable(mp, t); cur_edges=null;
23374 mp_obliterated(mp, t); mp_put_get_error(mp);
23375 } else if ( type(p)!=mp_picture_type ) {
23376 print_err("Variable "); mp_show_token_list(mp, t,null,1000,0);
23377 @.Variable x is the wrong type@>
23378 mp_print(mp, " is the wrong type (");
23379 mp_print_type(mp, type(p)); mp_print_char(mp, xord(')'));
23380 help2("I was looking for a \"known\" picture variable.",
23381 "So I'll not change anything just now.");
23382 mp_put_get_error(mp);
23384 value(p)=mp_private_edges(mp, value(p));
23385 cur_edges=value(p);
23387 mp_flush_node_list(mp, t);
23391 @ @<Cases of |do_statement|...@>=
23392 case add_to_command: mp_do_add_to(mp); break;
23393 case bounds_command:mp_do_bounds(mp); break;
23396 mp_primitive(mp, "clip",bounds_command,mp_start_clip_code);
23397 @:clip_}{\&{clip} primitive@>
23398 mp_primitive(mp, "setbounds",bounds_command,mp_start_bounds_code);
23399 @:set_bounds_}{\&{setbounds} primitive@>
23401 @ @<Cases of |print_cmd...@>=
23402 case bounds_command:
23403 if ( m==mp_start_clip_code ) mp_print(mp, "clip");
23404 else mp_print(mp, "setbounds");
23407 @ The following function parses the beginning of an \&{addto} or \&{clip}
23408 command: it expects a variable name followed by a token with |cur_cmd=sep|
23409 and then an expression. The function returns the token list for the variable
23410 and stores the command modifier for the separator token in the global variable
23411 |last_add_type|. We must be careful because this variable might get overwritten
23412 any time we call |get_x_next|.
23415 quarterword last_add_type;
23416 /* command modifier that identifies the last \&{addto} command */
23418 @ @<Declare action procedures for use by |do_statement|@>=
23419 static pointer mp_start_draw_cmd (MP mp,quarterword sep) ;
23421 @ @c pointer mp_start_draw_cmd (MP mp,quarterword sep) {
23422 pointer lhv; /* variable to add to left */
23423 quarterword add_type=0; /* value to be returned in |last_add_type| */
23425 mp_get_x_next(mp); mp->var_flag=sep; mp_scan_primary(mp);
23426 if ( mp->cur_type!=mp_token_list ) {
23427 @<Abandon edges command because there's no variable@>;
23429 lhv=mp->cur_exp; add_type=mp->cur_mod;
23430 mp->cur_type=mp_vacuous; mp_get_x_next(mp); mp_scan_expression(mp);
23432 mp->last_add_type=add_type;
23436 @ @<Abandon edges command because there's no variable@>=
23437 { exp_err("Not a suitable variable");
23438 @.Not a suitable variable@>
23439 help4("At this point I needed to see the name of a picture variable.",
23440 "(Or perhaps you have indeed presented me with one; I might",
23441 "have missed it, if it wasn't followed by the proper token.)",
23442 "So I'll not change anything just now.");
23443 mp_put_get_flush_error(mp, 0);
23446 @ Here is an example of how to use |start_draw_cmd|.
23448 @<Declare action procedures for use by |do_statement|@>=
23449 static void mp_do_bounds (MP mp) ;
23451 @ @c void mp_do_bounds (MP mp) {
23452 pointer lhv,lhe; /* variable on left, the corresponding edge structure */
23453 pointer p; /* for list manipulation */
23454 integer m; /* initial value of |cur_mod| */
23456 lhv=mp_start_draw_cmd(mp, to_token);
23458 lhe=mp_find_edges_var(mp, lhv);
23460 mp_flush_cur_exp(mp, 0);
23461 } else if ( mp->cur_type!=mp_path_type ) {
23462 exp_err("Improper `clip'");
23463 @.Improper `addto'@>
23464 help2("This expression should have specified a known path.",
23465 "So I'll not change anything just now.");
23466 mp_put_get_flush_error(mp, 0);
23467 } else if ( left_type(mp->cur_exp)==mp_endpoint ) {
23468 @<Complain about a non-cycle@>;
23470 @<Make |cur_exp| into a \&{setbounds} or clipping path and add it to |lhe|@>;
23475 @ @<Complain about a non-cycle@>=
23476 { print_err("Not a cycle");
23478 help2("That contour should have ended with `..cycle' or `&cycle'.",
23479 "So I'll not change anything just now."); mp_put_get_error(mp);
23482 @ @<Make |cur_exp| into a \&{setbounds} or clipping path and add...@>=
23483 { p=mp_new_bounds_node(mp, mp->cur_exp,m);
23484 mp_link(p)=mp_link(dummy_loc(lhe));
23485 mp_link(dummy_loc(lhe))=p;
23486 if ( obj_tail(lhe)==dummy_loc(lhe) ) obj_tail(lhe)=p;
23487 p=mp_get_node(mp, mp->gr_object_size[stop_type(m)]);
23488 type(p)=stop_type(m);
23489 mp_link(obj_tail(lhe))=p;
23491 mp_init_bbox(mp, lhe);
23494 @ The |do_add_to| procedure is a little like |do_clip| but there are a lot more
23495 cases to deal with.
23497 @<Declare action procedures for use by |do_statement|@>=
23498 static void mp_do_add_to (MP mp) ;
23500 @ @c void mp_do_add_to (MP mp) {
23501 pointer lhv,lhe; /* variable on left, the corresponding edge structure */
23502 pointer p; /* the graphical object or list for |scan_with_list| to update */
23503 pointer e; /* an edge structure to be merged */
23504 quarterword add_type; /* |also_code|, |contour_code|, or |double_path_code| */
23505 lhv=mp_start_draw_cmd(mp, thing_to_add); add_type=mp->last_add_type;
23507 if ( add_type==also_code ) {
23508 @<Make sure the current expression is a suitable picture and set |e| and |p|
23511 @<Create a graphical object |p| based on |add_type| and the current
23514 mp_scan_with_list(mp, p);
23515 @<Use |p|, |e|, and |add_type| to augment |lhv| as requested@>;
23519 @ Setting |p:=null| causes the $\langle$with list$\rangle$ to be ignored;
23520 setting |e:=null| prevents anything from being added to |lhe|.
23522 @ @<Make sure the current expression is a suitable picture and set |e|...@>=
23525 if ( mp->cur_type!=mp_picture_type ) {
23526 exp_err("Improper `addto'");
23527 @.Improper `addto'@>
23528 help2("This expression should have specified a known picture.",
23529 "So I'll not change anything just now.");
23530 mp_put_get_flush_error(mp, 0);
23532 e=mp_private_edges(mp, mp->cur_exp); mp->cur_type=mp_vacuous;
23533 p=mp_link(dummy_loc(e));
23537 @ In this case |add_type<>also_code| so setting |p:=null| suppresses future
23538 attempts to add to the edge structure.
23540 @<Create a graphical object |p| based on |add_type| and the current...@>=
23542 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
23543 if ( mp->cur_type!=mp_path_type ) {
23544 exp_err("Improper `addto'");
23545 @.Improper `addto'@>
23546 help2("This expression should have specified a known path.",
23547 "So I'll not change anything just now.");
23548 mp_put_get_flush_error(mp, 0);
23549 } else if ( add_type==contour_code ) {
23550 if ( left_type(mp->cur_exp)==mp_endpoint ) {
23551 @<Complain about a non-cycle@>;
23553 p=mp_new_fill_node(mp, mp->cur_exp);
23554 mp->cur_type=mp_vacuous;
23557 p=mp_new_stroked_node(mp, mp->cur_exp);
23558 mp->cur_type=mp_vacuous;
23562 @ @<Use |p|, |e|, and |add_type| to augment |lhv| as requested@>=
23563 lhe=mp_find_edges_var(mp, lhv);
23565 if ( (e==null)&&(p!=null) ) e=mp_toss_gr_object(mp, p);
23566 if ( e!=null ) delete_edge_ref(e);
23567 } else if ( add_type==also_code ) {
23569 @<Merge |e| into |lhe| and delete |e|@>;
23573 } else if ( p!=null ) {
23574 mp_link(obj_tail(lhe))=p;
23576 if ( add_type==double_path_code )
23577 if ( pen_p(p)==null )
23578 pen_p(p)=mp_get_pen_circle(mp, 0);
23581 @ @<Merge |e| into |lhe| and delete |e|@>=
23582 { if ( mp_link(dummy_loc(e))!=null ) {
23583 mp_link(obj_tail(lhe))=mp_link(dummy_loc(e));
23584 obj_tail(lhe)=obj_tail(e);
23585 obj_tail(e)=dummy_loc(e);
23586 mp_link(dummy_loc(e))=null;
23587 mp_flush_dash_list(mp, lhe);
23589 mp_toss_edges(mp, e);
23592 @ @<Cases of |do_statement|...@>=
23593 case ship_out_command: mp_do_ship_out(mp); break;
23595 @ @<Declare action procedures for use by |do_statement|@>=
23596 @<Declare the \ps\ output procedures@>
23597 static void mp_do_ship_out (MP mp) ;
23599 @ @c void mp_do_ship_out (MP mp) {
23600 integer c; /* the character code */
23601 mp_get_x_next(mp); mp_scan_expression(mp);
23602 if ( mp->cur_type!=mp_picture_type ) {
23603 @<Complain that it's not a known picture@>;
23605 c=mp_round_unscaled(mp, mp->internal[mp_char_code]) % 256;
23606 if ( c<0 ) c=c+256;
23607 @<Store the width information for character code~|c|@>;
23608 mp_ship_out(mp, mp->cur_exp);
23609 mp_flush_cur_exp(mp, 0);
23613 @ @<Complain that it's not a known picture@>=
23615 exp_err("Not a known picture");
23616 help1("I can only output known pictures.");
23617 mp_put_get_flush_error(mp, 0);
23620 @ The \&{everyjob} command simply assigns a nonzero value to the global variable
23623 @<Cases of |do_statement|...@>=
23624 case every_job_command:
23625 mp_get_symbol(mp); mp->start_sym=mp->cur_sym; mp_get_x_next(mp);
23629 halfword start_sym; /* a symbolic token to insert at beginning of job */
23634 @ Finally, we have only the ``message'' commands remaining.
23637 @d err_message_code 1
23639 @d filename_template_code 3
23640 @d print_with_leading_zeroes(A) g = mp->pool_ptr;
23641 mp_print_int(mp, (A)); g = mp->pool_ptr-g;
23643 mp->pool_ptr = mp->pool_ptr - g;
23645 mp_print_char(mp, xord('0'));
23648 mp_print_int(mp, (A));
23653 mp_primitive(mp, "message",message_command,message_code);
23654 @:message_}{\&{message} primitive@>
23655 mp_primitive(mp, "errmessage",message_command,err_message_code);
23656 @:err_message_}{\&{errmessage} primitive@>
23657 mp_primitive(mp, "errhelp",message_command,err_help_code);
23658 @:err_help_}{\&{errhelp} primitive@>
23659 mp_primitive(mp, "filenametemplate",message_command,filename_template_code);
23660 @:filename_template_}{\&{filenametemplate} primitive@>
23662 @ @<Cases of |print_cmd...@>=
23663 case message_command:
23664 if ( m<err_message_code ) mp_print(mp, "message");
23665 else if ( m==err_message_code ) mp_print(mp, "errmessage");
23666 else if ( m==filename_template_code ) mp_print(mp, "filenametemplate");
23667 else mp_print(mp, "errhelp");
23670 @ @<Cases of |do_statement|...@>=
23671 case message_command: mp_do_message(mp); break;
23673 @ @<Declare action procedures for use by |do_statement|@>=
23674 @<Declare a procedure called |no_string_err|@>
23675 static void mp_do_message (MP mp) ;
23678 @c void mp_do_message (MP mp) {
23679 int m; /* the type of message */
23680 m=mp->cur_mod; mp_get_x_next(mp); mp_scan_expression(mp);
23681 if ( mp->cur_type!=mp_string_type )
23682 mp_no_string_err(mp, "A message should be a known string expression.");
23686 mp_print_nl(mp, ""); mp_print_str(mp, mp->cur_exp);
23688 case err_message_code:
23689 @<Print string |cur_exp| as an error message@>;
23691 case err_help_code:
23692 @<Save string |cur_exp| as the |err_help|@>;
23694 case filename_template_code:
23695 @<Save the filename template@>;
23697 } /* there are no other cases */
23699 mp_flush_cur_exp(mp, 0);
23702 @ @<Declare a procedure called |no_string_err|@>=
23703 static void mp_no_string_err (MP mp, const char *s) {
23704 exp_err("Not a string");
23707 mp_put_get_error(mp);
23710 @ The global variable |err_help| is zero when the user has most recently
23711 given an empty help string, or if none has ever been given.
23713 @<Save string |cur_exp| as the |err_help|@>=
23715 if ( mp->err_help!=0 ) delete_str_ref(mp->err_help);
23716 if ( length(mp->cur_exp)==0 ) mp->err_help=0;
23717 else { mp->err_help=mp->cur_exp; add_str_ref(mp->err_help); }
23720 @ If \&{errmessage} occurs often in |mp_scroll_mode|, without user-defined
23721 \&{errhelp}, we don't want to give a long help message each time. So we
23722 give a verbose explanation only once.
23725 boolean long_help_seen; /* has the long \.{\\errmessage} help been used? */
23727 @ @<Set init...@>=mp->long_help_seen=false;
23729 @ @<Print string |cur_exp| as an error message@>=
23731 print_err(""); mp_print_str(mp, mp->cur_exp);
23732 if ( mp->err_help!=0 ) {
23733 mp->use_err_help=true;
23734 } else if ( mp->long_help_seen ) {
23735 help1("(That was another `errmessage'.)") ;
23737 if ( mp->interaction<mp_error_stop_mode ) mp->long_help_seen=true;
23738 help4("This error message was generated by an `errmessage'",
23739 "command, so I can\'t give any explicit help.",
23740 "Pretend that you're Miss Marple: Examine all clues,",
23742 "and deduce the truth by inspired guesses.");
23744 mp_put_get_error(mp); mp->use_err_help=false;
23747 @ @<Cases of |do_statement|...@>=
23748 case write_command: mp_do_write(mp); break;
23750 @ @<Declare action procedures for use by |do_statement|@>=
23751 static void mp_do_write (MP mp) ;
23753 @ @c void mp_do_write (MP mp) {
23754 str_number t; /* the line of text to be written */
23755 write_index n,n0; /* for searching |wr_fname| and |wr_file| arrays */
23756 unsigned old_setting; /* for saving |selector| during output */
23758 mp_scan_expression(mp);
23759 if ( mp->cur_type!=mp_string_type ) {
23760 mp_no_string_err(mp, "The text to be written should be a known string expression");
23761 } else if ( mp->cur_cmd!=to_token ) {
23762 print_err("Missing `to' clause");
23763 help1("A write command should end with `to <filename>'");
23764 mp_put_get_error(mp);
23766 t=mp->cur_exp; mp->cur_type=mp_vacuous;
23768 mp_scan_expression(mp);
23769 if ( mp->cur_type!=mp_string_type )
23770 mp_no_string_err(mp, "I can\'t write to that file name. It isn't a known string");
23772 @<Write |t| to the file named by |cur_exp|@>;
23776 mp_flush_cur_exp(mp, 0);
23779 @ @<Write |t| to the file named by |cur_exp|@>=
23781 @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if
23782 |cur_exp| must be inserted@>;
23783 if ( mp_str_vs_str(mp, t,mp->eof_line)==0 ) {
23784 @<Record the end of file on |wr_file[n]|@>;
23786 old_setting=mp->selector;
23787 mp->selector=n+write_file;
23788 mp_print_str(mp, t); mp_print_ln(mp);
23789 mp->selector = old_setting;
23793 @ @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if...@>=
23795 char *fn = str(mp->cur_exp);
23797 n0=mp->write_files;
23798 while (mp_xstrcmp(fn,mp->wr_fname[n])!=0) {
23799 if ( n==0 ) { /* bottom reached */
23800 if ( n0==mp->write_files ) {
23801 if ( mp->write_files<mp->max_write_files ) {
23802 incr(mp->write_files);
23807 l = mp->max_write_files + (mp->max_write_files/4);
23808 wr_file = xmalloc((l+1),sizeof(void *));
23809 wr_fname = xmalloc((l+1),sizeof(char *));
23810 for (k=0;k<=l;k++) {
23811 if (k<=mp->max_write_files) {
23812 wr_file[k]=mp->wr_file[k];
23813 wr_fname[k]=mp->wr_fname[k];
23819 xfree(mp->wr_file); xfree(mp->wr_fname);
23820 mp->max_write_files = l;
23821 mp->wr_file = wr_file;
23822 mp->wr_fname = wr_fname;
23826 mp_open_write_file(mp, fn ,n);
23829 if ( mp->wr_fname[n]==NULL ) n0=n;
23834 @ @<Record the end of file on |wr_file[n]|@>=
23835 { (mp->close_file)(mp,mp->wr_file[n]);
23836 xfree(mp->wr_fname[n]);
23837 if ( n==mp->write_files-1 ) mp->write_files=n;
23841 @* \[42] Writing font metric data.
23842 \TeX\ gets its knowledge about fonts from font metric files, also called
23843 \.{TFM} files; the `\.T' in `\.{TFM}' stands for \TeX,
23844 but other programs know about them too. One of \MP's duties is to
23845 write \.{TFM} files so that the user's fonts can readily be
23846 applied to typesetting.
23847 @:TFM files}{\.{TFM} files@>
23848 @^font metric files@>
23850 The information in a \.{TFM} file appears in a sequence of 8-bit bytes.
23851 Since the number of bytes is always a multiple of~4, we could
23852 also regard the file as a sequence of 32-bit words, but \MP\ uses the
23853 byte interpretation. The format of \.{TFM} files was designed by
23854 Lyle Ramshaw in 1980. The intent is to convey a lot of different kinds
23855 @^Ramshaw, Lyle Harold@>
23856 of information in a compact but useful form.
23859 void * tfm_file; /* the font metric output goes here */
23860 char * metric_file_name; /* full name of the font metric file */
23862 @ The first 24 bytes (6 words) of a \.{TFM} file contain twelve 16-bit
23863 integers that give the lengths of the various subsequent portions
23864 of the file. These twelve integers are, in order:
23865 $$\vbox{\halign{\hfil#&$\null=\null$#\hfil\cr
23866 |lf|&length of the entire file, in words;\cr
23867 |lh|&length of the header data, in words;\cr
23868 |bc|&smallest character code in the font;\cr
23869 |ec|&largest character code in the font;\cr
23870 |nw|&number of words in the width table;\cr
23871 |nh|&number of words in the height table;\cr
23872 |nd|&number of words in the depth table;\cr
23873 |ni|&number of words in the italic correction table;\cr
23874 |nl|&number of words in the lig/kern table;\cr
23875 |nk|&number of words in the kern table;\cr
23876 |ne|&number of words in the extensible character table;\cr
23877 |np|&number of font parameter words.\cr}}$$
23878 They are all nonnegative and less than $2^{15}$. We must have |bc-1<=ec<=255|,
23880 $$\hbox{|lf=6+lh+(ec-bc+1)+nw+nh+nd+ni+nl+nk+ne+np|.}$$
23881 Note that a font may contain as many as 256 characters (if |bc=0| and |ec=255|),
23882 and as few as 0 characters (if |bc=ec+1|).
23884 Incidentally, when two or more 8-bit bytes are combined to form an integer of
23885 16 or more bits, the most significant bytes appear first in the file.
23886 This is called BigEndian order.
23887 @^BigEndian order@>
23889 @ The rest of the \.{TFM} file may be regarded as a sequence of ten data
23892 The most important data type used here is a |fix_word|, which is
23893 a 32-bit representation of a binary fraction. A |fix_word| is a signed
23894 quantity, with the two's complement of the entire word used to represent
23895 negation. Of the 32 bits in a |fix_word|, exactly 12 are to the left of the
23896 binary point; thus, the largest |fix_word| value is $2048-2^{-20}$, and
23897 the smallest is $-2048$. We will see below, however, that all but two of
23898 the |fix_word| values must lie between $-16$ and $+16$.
23900 @ The first data array is a block of header information, which contains
23901 general facts about the font. The header must contain at least two words,
23902 |header[0]| and |header[1]|, whose meaning is explained below. Additional
23903 header information of use to other software routines might also be
23904 included, and \MP\ will generate it if the \.{headerbyte} command occurs.
23905 For example, 16 more words of header information are in use at the Xerox
23906 Palo Alto Research Center; the first ten specify the character coding
23907 scheme used (e.g., `\.{XEROX TEXT}' or `\.{TEX MATHSY}'), the next five
23908 give the font family name (e.g., `\.{HELVETICA}' or `\.{CMSY}'), and the
23909 last gives the ``face byte.''
23911 \yskip\hang|header[0]| is a 32-bit check sum that \MP\ will copy into
23912 the \.{GF} output file. This helps ensure consistency between files,
23913 since \TeX\ records the check sums from the \.{TFM}'s it reads, and these
23914 should match the check sums on actual fonts that are used. The actual
23915 relation between this check sum and the rest of the \.{TFM} file is not
23916 important; the check sum is simply an identification number with the
23917 property that incompatible fonts almost always have distinct check sums.
23920 \yskip\hang|header[1]| is a |fix_word| containing the design size of the
23921 font, in units of \TeX\ points. This number must be at least 1.0; it is
23922 fairly arbitrary, but usually the design size is 10.0 for a ``10 point''
23923 font, i.e., a font that was designed to look best at a 10-point size,
23924 whatever that really means. When a \TeX\ user asks for a font `\.{at}
23925 $\delta$ \.{pt}', the effect is to override the design size and replace it
23926 by $\delta$, and to multiply the $x$ and~$y$ coordinates of the points in
23927 the font image by a factor of $\delta$ divided by the design size. {\sl
23928 All other dimensions in the\/ \.{TFM} file are |fix_word|\kern-1pt\
23929 numbers in design-size units.} Thus, for example, the value of |param[6]|,
23930 which defines the \.{em} unit, is often the |fix_word| value $2^{20}=1.0$,
23931 since many fonts have a design size equal to one em. The other dimensions
23932 must be less than 16 design-size units in absolute value; thus,
23933 |header[1]| and |param[1]| are the only |fix_word| entries in the whole
23934 \.{TFM} file whose first byte might be something besides 0 or 255.
23937 @ Next comes the |char_info| array, which contains one |char_info_word|
23938 per character. Each word in this part of the file contains six fields
23939 packed into four bytes as follows.
23941 \yskip\hang first byte: |width_index| (8 bits)\par
23942 \hang second byte: |height_index| (4 bits) times 16, plus |depth_index|
23944 \hang third byte: |italic_index| (6 bits) times 4, plus |tag|
23946 \hang fourth byte: |remainder| (8 bits)\par
23948 The actual width of a character is \\{width}|[width_index]|, in design-size
23949 units; this is a device for compressing information, since many characters
23950 have the same width. Since it is quite common for many characters
23951 to have the same height, depth, or italic correction, the \.{TFM} format
23952 imposes a limit of 16 different heights, 16 different depths, and
23953 64 different italic corrections.
23955 Incidentally, the relation $\\{width}[0]=\\{height}[0]=\\{depth}[0]=
23956 \\{italic}[0]=0$ should always hold, so that an index of zero implies a
23957 value of zero. The |width_index| should never be zero unless the
23958 character does not exist in the font, since a character is valid if and
23959 only if it lies between |bc| and |ec| and has a nonzero |width_index|.
23961 @ The |tag| field in a |char_info_word| has four values that explain how to
23962 interpret the |remainder| field.
23964 \yskip\hang|tag=0| (|no_tag|) means that |remainder| is unused.\par
23965 \hang|tag=1| (|lig_tag|) means that this character has a ligature/kerning
23966 program starting at location |remainder| in the |lig_kern| array.\par
23967 \hang|tag=2| (|list_tag|) means that this character is part of a chain of
23968 characters of ascending sizes, and not the largest in the chain. The
23969 |remainder| field gives the character code of the next larger character.\par
23970 \hang|tag=3| (|ext_tag|) means that this character code represents an
23971 extensible character, i.e., a character that is built up of smaller pieces
23972 so that it can be made arbitrarily large. The pieces are specified in
23973 |exten[remainder]|.\par
23975 Characters with |tag=2| and |tag=3| are treated as characters with |tag=0|
23976 unless they are used in special circumstances in math formulas. For example,
23977 \TeX's \.{\\sum} operation looks for a |list_tag|, and the \.{\\left}
23978 operation looks for both |list_tag| and |ext_tag|.
23980 @d no_tag 0 /* vanilla character */
23981 @d lig_tag 1 /* character has a ligature/kerning program */
23982 @d list_tag 2 /* character has a successor in a charlist */
23983 @d ext_tag 3 /* character is extensible */
23985 @ The |lig_kern| array contains instructions in a simple programming language
23986 that explains what to do for special letter pairs. Each word in this array is a
23987 |lig_kern_command| of four bytes.
23989 \yskip\hang first byte: |skip_byte|, indicates that this is the final program
23990 step if the byte is 128 or more, otherwise the next step is obtained by
23991 skipping this number of intervening steps.\par
23992 \hang second byte: |next_char|, ``if |next_char| follows the current character,
23993 then perform the operation and stop, otherwise continue.''\par
23994 \hang third byte: |op_byte|, indicates a ligature step if less than~128,
23995 a kern step otherwise.\par
23996 \hang fourth byte: |remainder|.\par
23999 additional space equal to |kern[256*(op_byte-128)+remainder]| is inserted
24000 between the current character and |next_char|. This amount is
24001 often negative, so that the characters are brought closer together
24002 by kerning; but it might be positive.
24004 There are eight kinds of ligature steps, having |op_byte| codes $4a+2b+c$ where
24005 $0\le a\le b+c$ and $0\le b,c\le1$. The character whose code is
24006 |remainder| is inserted between the current character and |next_char|;
24007 then the current character is deleted if $b=0$, and |next_char| is
24008 deleted if $c=0$; then we pass over $a$~characters to reach the next
24009 current character (which may have a ligature/kerning program of its own).
24011 If the very first instruction of the |lig_kern| array has |skip_byte=255|,
24012 the |next_char| byte is the so-called right boundary character of this font;
24013 the value of |next_char| need not lie between |bc| and~|ec|.
24014 If the very last instruction of the |lig_kern| array has |skip_byte=255|,
24015 there is a special ligature/kerning program for a left boundary character,
24016 beginning at location |256*op_byte+remainder|.
24017 The interpretation is that \TeX\ puts implicit boundary characters
24018 before and after each consecutive string of characters from the same font.
24019 These implicit characters do not appear in the output, but they can affect
24020 ligatures and kerning.
24022 If the very first instruction of a character's |lig_kern| program has
24023 |skip_byte>128|, the program actually begins in location
24024 |256*op_byte+remainder|. This feature allows access to large |lig_kern|
24025 arrays, because the first instruction must otherwise
24026 appear in a location |<=255|.
24028 Any instruction with |skip_byte>128| in the |lig_kern| array must satisfy
24030 $$\hbox{|256*op_byte+remainder<nl|.}$$
24031 If such an instruction is encountered during
24032 normal program execution, it denotes an unconditional halt; no ligature
24033 command is performed.
24036 /* value indicating `\.{STOP}' in a lig/kern program */
24037 @d kern_flag (128) /* op code for a kern step */
24038 @d skip_byte(A) mp->lig_kern[(A)].b0
24039 @d next_char(A) mp->lig_kern[(A)].b1
24040 @d op_byte(A) mp->lig_kern[(A)].b2
24041 @d rem_byte(A) mp->lig_kern[(A)].b3
24043 @ Extensible characters are specified by an |extensible_recipe|, which
24044 consists of four bytes called |top|, |mid|, |bot|, and |rep| (in this
24045 order). These bytes are the character codes of individual pieces used to
24046 build up a large symbol. If |top|, |mid|, or |bot| are zero, they are not
24047 present in the built-up result. For example, an extensible vertical line is
24048 like an extensible bracket, except that the top and bottom pieces are missing.
24050 Let $T$, $M$, $B$, and $R$ denote the respective pieces, or an empty box
24051 if the piece isn't present. Then the extensible characters have the form
24052 $TR^kMR^kB$ from top to bottom, for some |k>=0|, unless $M$ is absent;
24053 in the latter case we can have $TR^kB$ for both even and odd values of~|k|.
24054 The width of the extensible character is the width of $R$; and the
24055 height-plus-depth is the sum of the individual height-plus-depths of the
24056 components used, since the pieces are butted together in a vertical list.
24058 @d ext_top(A) mp->exten[(A)].b0 /* |top| piece in a recipe */
24059 @d ext_mid(A) mp->exten[(A)].b1 /* |mid| piece in a recipe */
24060 @d ext_bot(A) mp->exten[(A)].b2 /* |bot| piece in a recipe */
24061 @d ext_rep(A) mp->exten[(A)].b3 /* |rep| piece in a recipe */
24063 @ The final portion of a \.{TFM} file is the |param| array, which is another
24064 sequence of |fix_word| values.
24066 \yskip\hang|param[1]=slant| is the amount of italic slant, which is used
24067 to help position accents. For example, |slant=.25| means that when you go
24068 up one unit, you also go .25 units to the right. The |slant| is a pure
24069 number; it is the only |fix_word| other than the design size itself that is
24070 not scaled by the design size.
24073 \hang|param[2]=space| is the normal spacing between words in text.
24074 Note that character 040 in the font need not have anything to do with
24077 \hang|param[3]=space_stretch| is the amount of glue stretching between words.
24079 \hang|param[4]=space_shrink| is the amount of glue shrinking between words.
24081 \hang|param[5]=x_height| is the size of one ex in the font; it is also
24082 the height of letters for which accents don't have to be raised or lowered.
24084 \hang|param[6]=quad| is the size of one em in the font.
24086 \hang|param[7]=extra_space| is the amount added to |param[2]| at the
24090 If fewer than seven parameters are present, \TeX\ sets the missing parameters
24095 @d space_stretch_code 3
24096 @d space_shrink_code 4
24099 @d extra_space_code 7
24101 @ So that is what \.{TFM} files hold. One of \MP's duties is to output such
24102 information, and it does this all at once at the end of a job.
24103 In order to prepare for such frenetic activity, it squirrels away the
24104 necessary facts in various arrays as information becomes available.
24106 Character dimensions (\&{charwd}, \&{charht}, \&{chardp}, and \&{charic})
24107 are stored respectively in |tfm_width|, |tfm_height|, |tfm_depth|, and
24108 |tfm_ital_corr|. Other information about a character (e.g., about
24109 its ligatures or successors) is accessible via the |char_tag| and
24110 |char_remainder| arrays. Other information about the font as a whole
24111 is kept in additional arrays called |header_byte|, |lig_kern|,
24112 |kern|, |exten|, and |param|.
24114 @d max_tfm_int 32510
24115 @d undefined_label max_tfm_int /* an undefined local label */
24118 #define TFM_ITEMS 257
24120 eight_bits ec; /* smallest and largest character codes shipped out */
24121 scaled tfm_width[TFM_ITEMS]; /* \&{charwd} values */
24122 scaled tfm_height[TFM_ITEMS]; /* \&{charht} values */
24123 scaled tfm_depth[TFM_ITEMS]; /* \&{chardp} values */
24124 scaled tfm_ital_corr[TFM_ITEMS]; /* \&{charic} values */
24125 boolean char_exists[TFM_ITEMS]; /* has this code been shipped out? */
24126 int char_tag[TFM_ITEMS]; /* |remainder| category */
24127 int char_remainder[TFM_ITEMS]; /* the |remainder| byte */
24128 char *header_byte; /* bytes of the \.{TFM} header */
24129 int header_last; /* last initialized \.{TFM} header byte */
24130 int header_size; /* size of the \.{TFM} header */
24131 four_quarters *lig_kern; /* the ligature/kern table */
24132 short nl; /* the number of ligature/kern steps so far */
24133 scaled *kern; /* distinct kerning amounts */
24134 short nk; /* the number of distinct kerns so far */
24135 four_quarters exten[TFM_ITEMS]; /* extensible character recipes */
24136 short ne; /* the number of extensible characters so far */
24137 scaled *param; /* \&{fontinfo} parameters */
24138 short np; /* the largest \&{fontinfo} parameter specified so far */
24139 short nw;short nh;short nd;short ni; /* sizes of \.{TFM} subtables */
24140 short skip_table[TFM_ITEMS]; /* local label status */
24141 boolean lk_started; /* has there been a lig/kern step in this command yet? */
24142 integer bchar; /* right boundary character */
24143 short bch_label; /* left boundary starting location */
24144 short ll;short lll; /* registers used for lig/kern processing */
24145 short label_loc[257]; /* lig/kern starting addresses */
24146 eight_bits label_char[257]; /* characters for |label_loc| */
24147 short label_ptr; /* highest position occupied in |label_loc| */
24149 @ @<Allocate or initialize ...@>=
24150 mp->header_size = 128; /* just for init */
24151 mp->header_byte = xmalloc(mp->header_size, sizeof(char));
24153 @ @<Dealloc variables@>=
24154 xfree(mp->header_byte);
24155 xfree(mp->lig_kern);
24160 for (k=0;k<= 255;k++ ) {
24161 mp->tfm_width[k]=0; mp->tfm_height[k]=0; mp->tfm_depth[k]=0; mp->tfm_ital_corr[k]=0;
24162 mp->char_exists[k]=false; mp->char_tag[k]=no_tag; mp->char_remainder[k]=0;
24163 mp->skip_table[k]=undefined_label;
24165 memset(mp->header_byte,0,(size_t)mp->header_size);
24166 mp->bc=255; mp->ec=0; mp->nl=0; mp->nk=0; mp->ne=0; mp->np=0;
24167 mp->internal[mp_boundary_char]=-unity;
24168 mp->bch_label=undefined_label;
24169 mp->label_loc[0]=-1; mp->label_ptr=0;
24171 @ @<Declarations@>=
24172 static scaled mp_tfm_check (MP mp,quarterword m) ;
24175 static scaled mp_tfm_check (MP mp,quarterword m) {
24176 if ( abs(mp->internal[m])>=fraction_half ) {
24177 print_err("Enormous "); mp_print(mp, mp->int_name[m]);
24178 @.Enormous charwd...@>
24179 @.Enormous chardp...@>
24180 @.Enormous charht...@>
24181 @.Enormous charic...@>
24182 @.Enormous designsize...@>
24183 mp_print(mp, " has been reduced");
24184 help1("Font metric dimensions must be less than 2048pt.");
24185 mp_put_get_error(mp);
24186 if ( mp->internal[m]>0 ) return (fraction_half-1);
24187 else return (1-fraction_half);
24189 return mp->internal[m];
24193 @ @<Store the width information for character code~|c|@>=
24194 if ( c<mp->bc ) mp->bc=(eight_bits)c;
24195 if ( c>mp->ec ) mp->ec=(eight_bits)c;
24196 mp->char_exists[c]=true;
24197 mp->tfm_width[c]=mp_tfm_check(mp,mp_char_wd);
24198 mp->tfm_height[c]=mp_tfm_check(mp, mp_char_ht);
24199 mp->tfm_depth[c]=mp_tfm_check(mp, mp_char_dp);
24200 mp->tfm_ital_corr[c]=mp_tfm_check(mp, mp_char_ic)
24202 @ Now let's consider \MP's special \.{TFM}-oriented commands.
24204 @<Cases of |do_statement|...@>=
24205 case tfm_command: mp_do_tfm_command(mp); break;
24207 @ @d char_list_code 0
24208 @d lig_table_code 1
24209 @d extensible_code 2
24210 @d header_byte_code 3
24211 @d font_dimen_code 4
24214 mp_primitive(mp, "charlist",tfm_command,char_list_code);
24215 @:char_list_}{\&{charlist} primitive@>
24216 mp_primitive(mp, "ligtable",tfm_command,lig_table_code);
24217 @:lig_table_}{\&{ligtable} primitive@>
24218 mp_primitive(mp, "extensible",tfm_command,extensible_code);
24219 @:extensible_}{\&{extensible} primitive@>
24220 mp_primitive(mp, "headerbyte",tfm_command,header_byte_code);
24221 @:header_byte_}{\&{headerbyte} primitive@>
24222 mp_primitive(mp, "fontdimen",tfm_command,font_dimen_code);
24223 @:font_dimen_}{\&{fontdimen} primitive@>
24225 @ @<Cases of |print_cmd...@>=
24228 case char_list_code:mp_print(mp, "charlist"); break;
24229 case lig_table_code:mp_print(mp, "ligtable"); break;
24230 case extensible_code:mp_print(mp, "extensible"); break;
24231 case header_byte_code:mp_print(mp, "headerbyte"); break;
24232 default: mp_print(mp, "fontdimen"); break;
24236 @ @<Declare action procedures for use by |do_statement|@>=
24237 static eight_bits mp_get_code (MP mp) ;
24239 @ @c eight_bits mp_get_code (MP mp) { /* scans a character code value */
24240 integer c; /* the code value found */
24241 mp_get_x_next(mp); mp_scan_expression(mp);
24242 if ( mp->cur_type==mp_known ) {
24243 c=mp_round_unscaled(mp, mp->cur_exp);
24244 if ( c>=0 ) if ( c<256 ) return (eight_bits)c;
24245 } else if ( mp->cur_type==mp_string_type ) {
24246 if ( length(mp->cur_exp)==1 ) {
24247 c=mp->str_pool[mp->str_start[mp->cur_exp]];
24248 return (eight_bits)c;
24251 exp_err("Invalid code has been replaced by 0");
24252 @.Invalid code...@>
24253 help2("I was looking for a number between 0 and 255, or for a",
24254 "string of length 1. Didn't find it; will use 0 instead.");
24255 mp_put_get_flush_error(mp, 0); c=0;
24256 return (eight_bits)c;
24259 @ @<Declare action procedures for use by |do_statement|@>=
24260 static void mp_set_tag (MP mp,halfword c, quarterword t, halfword r) ;
24262 @ @c void mp_set_tag (MP mp,halfword c, quarterword t, halfword r) {
24263 if ( mp->char_tag[c]==no_tag ) {
24264 mp->char_tag[c]=t; mp->char_remainder[c]=r;
24266 incr(mp->label_ptr); mp->label_loc[mp->label_ptr]=r;
24267 mp->label_char[mp->label_ptr]=(eight_bits)c;
24270 @<Complain about a character tag conflict@>;
24274 @ @<Complain about a character tag conflict@>=
24276 print_err("Character ");
24277 if ( (c>' ')&&(c<127) ) mp_print_char(mp,xord(c));
24278 else if ( c==256 ) mp_print(mp, "||");
24279 else { mp_print(mp, "code "); mp_print_int(mp, c); };
24280 mp_print(mp, " is already ");
24281 @.Character c is already...@>
24282 switch (mp->char_tag[c]) {
24283 case lig_tag: mp_print(mp, "in a ligtable"); break;
24284 case list_tag: mp_print(mp, "in a charlist"); break;
24285 case ext_tag: mp_print(mp, "extensible"); break;
24286 } /* there are no other cases */
24287 help2("It's not legal to label a character more than once.",
24288 "So I'll not change anything just now.");
24289 mp_put_get_error(mp);
24292 @ @<Declare action procedures for use by |do_statement|@>=
24293 static void mp_do_tfm_command (MP mp) ;
24295 @ @c void mp_do_tfm_command (MP mp) {
24296 int c,cc; /* character codes */
24297 int k; /* index into the |kern| array */
24298 int j; /* index into |header_byte| or |param| */
24299 switch (mp->cur_mod) {
24300 case char_list_code:
24302 /* we will store a list of character successors */
24303 while ( mp->cur_cmd==colon ) {
24304 cc=mp_get_code(mp); mp_set_tag(mp, c,list_tag,cc); c=cc;
24307 case lig_table_code:
24308 if (mp->lig_kern==NULL)
24309 mp->lig_kern = xmalloc((max_tfm_int+1),sizeof(four_quarters));
24310 if (mp->kern==NULL)
24311 mp->kern = xmalloc((max_tfm_int+1),sizeof(scaled));
24312 @<Store a list of ligature/kern steps@>;
24314 case extensible_code:
24315 @<Define an extensible recipe@>;
24317 case header_byte_code:
24318 case font_dimen_code:
24319 c=mp->cur_mod; mp_get_x_next(mp);
24320 mp_scan_expression(mp);
24321 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<half_unit) ) {
24322 exp_err("Improper location");
24323 @.Improper location@>
24324 help2("I was looking for a known, positive number.",
24325 "For safety's sake I'll ignore the present command.");
24326 mp_put_get_error(mp);
24328 j=mp_round_unscaled(mp, mp->cur_exp);
24329 if ( mp->cur_cmd!=colon ) {
24330 mp_missing_err(mp, ":");
24332 help1("A colon should follow a headerbyte or fontinfo location.");
24335 if ( c==header_byte_code ) {
24336 @<Store a list of header bytes@>;
24338 if (mp->param==NULL)
24339 mp->param = xmalloc((max_tfm_int+1),sizeof(scaled));
24340 @<Store a list of font dimensions@>;
24344 } /* there are no other cases */
24347 @ @<Store a list of ligature/kern steps@>=
24349 mp->lk_started=false;
24352 if ((mp->cur_cmd==skip_to)&& mp->lk_started )
24353 @<Process a |skip_to| command and |goto done|@>;
24354 if ( mp->cur_cmd==bchar_label ) { c=256; mp->cur_cmd=colon; }
24355 else { mp_back_input(mp); c=mp_get_code(mp); };
24356 if ((mp->cur_cmd==colon)||(mp->cur_cmd==double_colon)) {
24357 @<Record a label in a lig/kern subprogram and |goto continue|@>;
24359 if ( mp->cur_cmd==lig_kern_token ) {
24360 @<Compile a ligature/kern command@>;
24362 print_err("Illegal ligtable step");
24363 @.Illegal ligtable step@>
24364 help1("I was looking for `=:' or `kern' here.");
24365 mp_back_error(mp); next_char(mp->nl)=qi(0);
24366 op_byte(mp->nl)=qi(0); rem_byte(mp->nl)=qi(0);
24367 skip_byte(mp->nl)=stop_flag+1; /* this specifies an unconditional stop */
24369 if ( mp->nl==max_tfm_int) mp_fatal_error(mp, "ligtable too large");
24371 if ( mp->cur_cmd==comma ) goto CONTINUE;
24372 if ( skip_byte(mp->nl-1)<stop_flag ) skip_byte(mp->nl-1)=stop_flag;
24377 mp_primitive(mp, "=:",lig_kern_token,0);
24378 @:=:_}{\.{=:} primitive@>
24379 mp_primitive(mp, "=:|",lig_kern_token,1);
24380 @:=:/_}{\.{=:\char'174} primitive@>
24381 mp_primitive(mp, "=:|>",lig_kern_token,5);
24382 @:=:/>_}{\.{=:\char'174>} primitive@>
24383 mp_primitive(mp, "|=:",lig_kern_token,2);
24384 @:=:/_}{\.{\char'174=:} primitive@>
24385 mp_primitive(mp, "|=:>",lig_kern_token,6);
24386 @:=:/>_}{\.{\char'174=:>} primitive@>
24387 mp_primitive(mp, "|=:|",lig_kern_token,3);
24388 @:=:/_}{\.{\char'174=:\char'174} primitive@>
24389 mp_primitive(mp, "|=:|>",lig_kern_token,7);
24390 @:=:/>_}{\.{\char'174=:\char'174>} primitive@>
24391 mp_primitive(mp, "|=:|>>",lig_kern_token,11);
24392 @:=:/>_}{\.{\char'174=:\char'174>>} primitive@>
24393 mp_primitive(mp, "kern",lig_kern_token,128);
24394 @:kern_}{\&{kern} primitive@>
24396 @ @<Cases of |print_cmd...@>=
24397 case lig_kern_token:
24399 case 0:mp_print(mp, "=:"); break;
24400 case 1:mp_print(mp, "=:|"); break;
24401 case 2:mp_print(mp, "|=:"); break;
24402 case 3:mp_print(mp, "|=:|"); break;
24403 case 5:mp_print(mp, "=:|>"); break;
24404 case 6:mp_print(mp, "|=:>"); break;
24405 case 7:mp_print(mp, "|=:|>"); break;
24406 case 11:mp_print(mp, "|=:|>>"); break;
24407 default: mp_print(mp, "kern"); break;
24411 @ Local labels are implemented by maintaining the |skip_table| array,
24412 where |skip_table[c]| is either |undefined_label| or the address of the
24413 most recent lig/kern instruction that skips to local label~|c|. In the
24414 latter case, the |skip_byte| in that instruction will (temporarily)
24415 be zero if there were no prior skips to this label, or it will be the
24416 distance to the prior skip.
24418 We may need to cancel skips that span more than 127 lig/kern steps.
24420 @d cancel_skips(A) mp->ll=(A);
24422 mp->lll=qo(skip_byte(mp->ll));
24423 skip_byte(mp->ll)=stop_flag; mp->ll=mp->ll-mp->lll;
24424 } while (mp->lll!=0)
24425 @d skip_error(A) { print_err("Too far to skip");
24426 @.Too far to skip@>
24427 help1("At most 127 lig/kern steps can separate skipto1 from 1::.");
24428 mp_error(mp); cancel_skips((A));
24431 @<Process a |skip_to| command and |goto done|@>=
24434 if ( mp->nl-mp->skip_table[c]>128 ) {
24435 skip_error(mp->skip_table[c]); mp->skip_table[c]=undefined_label;
24437 if ( mp->skip_table[c]==undefined_label ) skip_byte(mp->nl-1)=qi(0);
24438 else skip_byte(mp->nl-1)=qi(mp->nl-mp->skip_table[c]-1);
24439 mp->skip_table[c]=mp->nl-1; goto DONE;
24442 @ @<Record a label in a lig/kern subprogram and |goto continue|@>=
24444 if ( mp->cur_cmd==colon ) {
24445 if ( c==256 ) mp->bch_label=mp->nl;
24446 else mp_set_tag(mp, c,lig_tag,mp->nl);
24447 } else if ( mp->skip_table[c]<undefined_label ) {
24448 mp->ll=mp->skip_table[c]; mp->skip_table[c]=undefined_label;
24450 mp->lll=qo(skip_byte(mp->ll));
24451 if ( mp->nl-mp->ll>128 ) {
24452 skip_error(mp->ll); goto CONTINUE;
24454 skip_byte(mp->ll)=qi(mp->nl-mp->ll-1); mp->ll=mp->ll-mp->lll;
24455 } while (mp->lll!=0);
24460 @ @<Compile a ligature/kern...@>=
24462 next_char(mp->nl)=qi(c); skip_byte(mp->nl)=qi(0);
24463 if ( mp->cur_mod<128 ) { /* ligature op */
24464 op_byte(mp->nl)=qi(mp->cur_mod); rem_byte(mp->nl)=qi(mp_get_code(mp));
24466 mp_get_x_next(mp); mp_scan_expression(mp);
24467 if ( mp->cur_type!=mp_known ) {
24468 exp_err("Improper kern");
24470 help2("The amount of kern should be a known numeric value.",
24471 "I'm zeroing this one. Proceed, with fingers crossed.");
24472 mp_put_get_flush_error(mp, 0);
24474 mp->kern[mp->nk]=mp->cur_exp;
24476 while ( mp->kern[k]!=mp->cur_exp ) incr(k);
24478 if ( mp->nk==max_tfm_int ) mp_fatal_error(mp, "too many TFM kerns");
24481 op_byte(mp->nl)=kern_flag+(k / 256);
24482 rem_byte(mp->nl)=qi((k % 256));
24484 mp->lk_started=true;
24487 @ @d missing_extensible_punctuation(A)
24488 { mp_missing_err(mp, (A));
24489 @.Missing `\char`\#'@>
24490 help1("I'm processing `extensible c: t,m,b,r'."); mp_back_error(mp);
24493 @<Define an extensible recipe@>=
24495 if ( mp->ne==256 ) mp_fatal_error(mp, "too many extensible recipies");
24496 c=mp_get_code(mp); mp_set_tag(mp, c,ext_tag,mp->ne);
24497 if ( mp->cur_cmd!=colon ) missing_extensible_punctuation(":");
24498 ext_top(mp->ne)=qi(mp_get_code(mp));
24499 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
24500 ext_mid(mp->ne)=qi(mp_get_code(mp));
24501 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
24502 ext_bot(mp->ne)=qi(mp_get_code(mp));
24503 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
24504 ext_rep(mp->ne)=qi(mp_get_code(mp));
24508 @ The header could contain ASCII zeroes, so can't use |strdup|.
24510 @<Store a list of header bytes@>=
24512 if ( j>=mp->header_size ) {
24513 size_t l = (size_t)(mp->header_size + (mp->header_size/4));
24514 char *t = xmalloc(l,1);
24516 memcpy(t,mp->header_byte,(size_t)mp->header_size);
24517 xfree (mp->header_byte);
24518 mp->header_byte = t;
24519 mp->header_size = (int)l;
24521 mp->header_byte[j]=(char)mp_get_code(mp);
24522 incr(j); incr(mp->header_last);
24523 } while (mp->cur_cmd==comma)
24525 @ @<Store a list of font dimensions@>=
24527 if ( j>max_tfm_int ) mp_fatal_error(mp, "too many fontdimens");
24528 while ( j>mp->np ) { incr(mp->np); mp->param[mp->np]=0; };
24529 mp_get_x_next(mp); mp_scan_expression(mp);
24530 if ( mp->cur_type!=mp_known ){
24531 exp_err("Improper font parameter");
24532 @.Improper font parameter@>
24533 help1("I'm zeroing this one. Proceed, with fingers crossed.");
24534 mp_put_get_flush_error(mp, 0);
24536 mp->param[j]=mp->cur_exp; incr(j);
24537 } while (mp->cur_cmd==comma)
24539 @ OK: We've stored all the data that is needed for the \.{TFM} file.
24540 All that remains is to output it in the correct format.
24542 An interesting problem needs to be solved in this connection, because
24543 the \.{TFM} format allows at most 256~widths, 16~heights, 16~depths,
24544 and 64~italic corrections. If the data has more distinct values than
24545 this, we want to meet the necessary restrictions by perturbing the
24546 given values as little as possible.
24548 \MP\ solves this problem in two steps. First the values of a given
24549 kind (widths, heights, depths, or italic corrections) are sorted;
24550 then the list of sorted values is perturbed, if necessary.
24552 The sorting operation is facilitated by having a special node of
24553 essentially infinite |value| at the end of the current list.
24555 @<Initialize table entries...@>=
24556 value(inf_val)=fraction_four;
24558 @ Straight linear insertion is good enough for sorting, since the lists
24559 are usually not terribly long. As we work on the data, the current list
24560 will start at |mp_link(temp_head)| and end at |inf_val|; the nodes in this
24561 list will be in increasing order of their |value| fields.
24563 Given such a list, the |sort_in| function takes a value and returns a pointer
24564 to where that value can be found in the list. The value is inserted in
24565 the proper place, if necessary.
24567 At the time we need to do these operations, most of \MP's work has been
24568 completed, so we will have plenty of memory to play with. The value nodes
24569 that are allocated for sorting will never be returned to free storage.
24571 @d clear_the_list mp_link(temp_head)=inf_val
24574 static pointer mp_sort_in (MP mp,scaled v) {
24575 pointer p,q,r; /* list manipulation registers */
24579 if ( v<=value(q) ) break;
24582 if ( v<value(q) ) {
24583 r=mp_get_node(mp, value_node_size); value(r)=v; mp_link(r)=q; mp_link(p)=r;
24588 @ Now we come to the interesting part, where we reduce the list if necessary
24589 until it has the required size. The |min_cover| routine is basic to this
24590 process; it computes the minimum number~|m| such that the values of the
24591 current sorted list can be covered by |m|~intervals of width~|d|. It
24592 also sets the global value |perturbation| to the smallest value $d'>d$
24593 such that the covering found by this algorithm would be different.
24595 In particular, |min_cover(0)| returns the number of distinct values in the
24596 current list and sets |perturbation| to the minimum distance between
24600 static integer mp_min_cover (MP mp,scaled d) {
24601 pointer p; /* runs through the current list */
24602 scaled l; /* the least element covered by the current interval */
24603 integer m; /* lower bound on the size of the minimum cover */
24604 m=0; p=mp_link(temp_head); mp->perturbation=el_gordo;
24605 while ( p!=inf_val ){
24606 incr(m); l=value(p);
24607 do { p=mp_link(p); } while (value(p)<=l+d);
24608 if ( value(p)-l<mp->perturbation )
24609 mp->perturbation=value(p)-l;
24615 scaled perturbation; /* quantity related to \.{TFM} rounding */
24616 integer excess; /* the list is this much too long */
24618 @ The smallest |d| such that a given list can be covered with |m| intervals
24619 is determined by the |threshold| routine, which is sort of an inverse
24620 to |min_cover|. The idea is to increase the interval size rapidly until
24621 finding the range, then to go sequentially until the exact borderline has
24625 static scaled mp_threshold (MP mp,integer m) {
24626 scaled d; /* lower bound on the smallest interval size */
24627 mp->excess=mp_min_cover(mp, 0)-m;
24628 if ( mp->excess<=0 ) {
24632 d=mp->perturbation;
24633 } while (mp_min_cover(mp, d+d)>m);
24634 while ( mp_min_cover(mp, d)>m )
24635 d=mp->perturbation;
24640 @ The |skimp| procedure reduces the current list to at most |m| entries,
24641 by changing values if necessary. It also sets |info(p):=k| if |value(p)|
24642 is the |k|th distinct value on the resulting list, and it sets
24643 |perturbation| to the maximum amount by which a |value| field has
24644 been changed. The size of the resulting list is returned as the
24648 static integer mp_skimp (MP mp,integer m) {
24649 scaled d; /* the size of intervals being coalesced */
24650 pointer p,q,r; /* list manipulation registers */
24651 scaled l; /* the least value in the current interval */
24652 scaled v; /* a compromise value */
24653 d=mp_threshold(mp, m); mp->perturbation=0;
24654 q=temp_head; m=0; p=mp_link(temp_head);
24655 while ( p!=inf_val ) {
24656 incr(m); l=value(p); info(p)=m;
24657 if ( value(mp_link(p))<=l+d ) {
24658 @<Replace an interval of values by its midpoint@>;
24665 @ @<Replace an interval...@>=
24668 p=mp_link(p); info(p)=m;
24669 decr(mp->excess); if ( mp->excess==0 ) d=0;
24670 } while (value(mp_link(p))<=l+d);
24671 v=l+halfp(value(p)-l);
24672 if ( value(p)-v>mp->perturbation )
24673 mp->perturbation=value(p)-v;
24676 r=mp_link(r); value(r)=v;
24678 mp_link(q)=p; /* remove duplicate values from the current list */
24681 @ A warning message is issued whenever something is perturbed by
24682 more than 1/16\thinspace pt.
24685 static void mp_tfm_warning (MP mp,quarterword m) {
24686 mp_print_nl(mp, "(some ");
24687 mp_print(mp, mp->int_name[m]);
24688 @.some charwds...@>
24689 @.some chardps...@>
24690 @.some charhts...@>
24691 @.some charics...@>
24692 mp_print(mp, " values had to be adjusted by as much as ");
24693 mp_print_scaled(mp, mp->perturbation); mp_print(mp, "pt)");
24696 @ Here's an example of how we use these routines.
24697 The width data needs to be perturbed only if there are 256 distinct
24698 widths, but \MP\ must check for this case even though it is
24701 An integer variable |k| will be defined when we use this code.
24702 The |dimen_head| array will contain pointers to the sorted
24703 lists of dimensions.
24705 @<Massage the \.{TFM} widths@>=
24707 for (k=mp->bc;k<=mp->ec;k++) {
24708 if ( mp->char_exists[k] )
24709 mp->tfm_width[k]=mp_sort_in(mp, mp->tfm_width[k]);
24711 mp->nw=mp_skimp(mp, 255)+1; mp->dimen_head[1]=mp_link(temp_head);
24712 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_wd)
24715 pointer dimen_head[5]; /* lists of \.{TFM} dimensions */
24717 @ Heights, depths, and italic corrections are different from widths
24718 not only because their list length is more severely restricted, but
24719 also because zero values do not need to be put into the lists.
24721 @<Massage the \.{TFM} heights, depths, and italic corrections@>=
24723 for (k=mp->bc;k<=mp->ec;k++) {
24724 if ( mp->char_exists[k] ) {
24725 if ( mp->tfm_height[k]==0 ) mp->tfm_height[k]=zero_val;
24726 else mp->tfm_height[k]=mp_sort_in(mp, mp->tfm_height[k]);
24729 mp->nh=mp_skimp(mp, 15)+1; mp->dimen_head[2]=mp_link(temp_head);
24730 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_ht);
24732 for (k=mp->bc;k<=mp->ec;k++) {
24733 if ( mp->char_exists[k] ) {
24734 if ( mp->tfm_depth[k]==0 ) mp->tfm_depth[k]=zero_val;
24735 else mp->tfm_depth[k]=mp_sort_in(mp, mp->tfm_depth[k]);
24738 mp->nd=mp_skimp(mp, 15)+1; mp->dimen_head[3]=mp_link(temp_head);
24739 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_dp);
24741 for (k=mp->bc;k<=mp->ec;k++) {
24742 if ( mp->char_exists[k] ) {
24743 if ( mp->tfm_ital_corr[k]==0 ) mp->tfm_ital_corr[k]=zero_val;
24744 else mp->tfm_ital_corr[k]=mp_sort_in(mp, mp->tfm_ital_corr[k]);
24747 mp->ni=mp_skimp(mp, 63)+1; mp->dimen_head[4]=mp_link(temp_head);
24748 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_ic)
24750 @ @<Initialize table entries...@>=
24751 value(zero_val)=0; info(zero_val)=0;
24753 @ Bytes 5--8 of the header are set to the design size, unless the user has
24754 some crazy reason for specifying them differently.
24757 Error messages are not allowed at the time this procedure is called,
24758 so a warning is printed instead.
24760 The value of |max_tfm_dimen| is calculated so that
24761 $$\hbox{|make_scaled(16*max_tfm_dimen,internal[mp_design_size])|}
24762 < \\{three\_bytes}.$$
24764 @d three_bytes 0100000000 /* $2^{24}$ */
24767 static void mp_fix_design_size (MP mp) {
24768 scaled d; /* the design size */
24769 d=mp->internal[mp_design_size];
24770 if ( (d<unity)||(d>=fraction_half) ) {
24772 mp_print_nl(mp, "(illegal design size has been changed to 128pt)");
24773 @.illegal design size...@>
24774 d=040000000; mp->internal[mp_design_size]=d;
24776 if ( mp->header_byte[4]<0 ) if ( mp->header_byte[5]<0 )
24777 if ( mp->header_byte[6]<0 ) if ( mp->header_byte[7]<0 ) {
24778 mp->header_byte[4]=d / 04000000;
24779 mp->header_byte[5]=(d / 4096) % 256;
24780 mp->header_byte[6]=(d / 16) % 256;
24781 mp->header_byte[7]=(d % 16)*16;
24783 mp->max_tfm_dimen=16*mp->internal[mp_design_size]-1-mp->internal[mp_design_size] / 010000000;
24784 if ( mp->max_tfm_dimen>=fraction_half ) mp->max_tfm_dimen=fraction_half-1;
24787 @ The |dimen_out| procedure computes a |fix_word| relative to the
24788 design size. If the data was out of range, it is corrected and the
24789 global variable |tfm_changed| is increased by~one.
24792 static integer mp_dimen_out (MP mp,scaled x) {
24793 if ( abs(x)>mp->max_tfm_dimen ) {
24794 incr(mp->tfm_changed);
24795 if ( x>0 ) x=mp->max_tfm_dimen; else x=-mp->max_tfm_dimen;
24797 x=mp_make_scaled(mp, x*16,mp->internal[mp_design_size]);
24802 scaled max_tfm_dimen; /* bound on widths, heights, kerns, etc. */
24803 integer tfm_changed; /* the number of data entries that were out of bounds */
24805 @ If the user has not specified any of the first four header bytes,
24806 the |fix_check_sum| procedure replaces them by a ``check sum'' computed
24807 from the |tfm_width| data relative to the design size.
24811 static void mp_fix_check_sum (MP mp) {
24812 eight_bits k; /* runs through character codes */
24813 eight_bits B1,B2,B3,B4; /* bytes of the check sum */
24814 integer x; /* hash value used in check sum computation */
24815 if ( mp->header_byte[0]==0 && mp->header_byte[1]==0 &&
24816 mp->header_byte[2]==0 && mp->header_byte[3]==0 ) {
24817 @<Compute a check sum in |(b1,b2,b3,b4)|@>;
24818 mp->header_byte[0]=(char)B1; mp->header_byte[1]=(char)B2;
24819 mp->header_byte[2]=(char)B3; mp->header_byte[3]=(char)B4;
24824 @ @<Compute a check sum in |(b1,b2,b3,b4)|@>=
24825 B1=mp->bc; B2=mp->ec; B3=mp->bc; B4=mp->ec; mp->tfm_changed=0;
24826 for (k=mp->bc;k<=mp->ec;k++) {
24827 if ( mp->char_exists[k] ) {
24828 x=mp_dimen_out(mp, value(mp->tfm_width[k]))+(k+4)*020000000; /* this is positive */
24829 B1=(eight_bits)((B1+B1+x) % 255);
24830 B2=(eight_bits)((B2+B2+x) % 253);
24831 B3=(eight_bits)((B3+B3+x) % 251);
24832 B4=(eight_bits)((B4+B4+x) % 247);
24836 @ Finally we're ready to actually write the \.{TFM} information.
24837 Here are some utility routines for this purpose.
24839 @d tfm_out(A) do { /* output one byte to |tfm_file| */
24840 unsigned char s=(unsigned char)(A);
24841 (mp->write_binary_file)(mp,mp->tfm_file,(void *)&s,1);
24845 static void mp_tfm_two (MP mp,integer x) { /* output two bytes to |tfm_file| */
24846 tfm_out(x / 256); tfm_out(x % 256);
24848 static void mp_tfm_four (MP mp,integer x) { /* output four bytes to |tfm_file| */
24849 if ( x>=0 ) tfm_out(x / three_bytes);
24851 x=x+010000000000; /* use two's complement for negative values */
24853 tfm_out((x / three_bytes) + 128);
24855 x=x % three_bytes; tfm_out(x / unity);
24856 x=x % unity; tfm_out(x / 0400);
24859 static void mp_tfm_qqqq (MP mp,four_quarters x) { /* output four quarterwords to |tfm_file| */
24860 tfm_out(qo(x.b0)); tfm_out(qo(x.b1));
24861 tfm_out(qo(x.b2)); tfm_out(qo(x.b3));
24864 @ @<Finish the \.{TFM} file@>=
24865 if ( mp->job_name==NULL ) mp_open_log_file(mp);
24866 mp_pack_job_name(mp, ".tfm");
24867 while ( ! mp_b_open_out(mp, &mp->tfm_file, mp_filetype_metrics) )
24868 mp_prompt_file_name(mp, "file name for font metrics",".tfm");
24869 mp->metric_file_name=xstrdup(mp->name_of_file);
24870 @<Output the subfile sizes and header bytes@>;
24871 @<Output the character information bytes, then
24872 output the dimensions themselves@>;
24873 @<Output the ligature/kern program@>;
24874 @<Output the extensible character recipes and the font metric parameters@>;
24875 if ( mp->internal[mp_tracing_stats]>0 )
24876 @<Log the subfile sizes of the \.{TFM} file@>;
24877 mp_print_nl(mp, "Font metrics written on ");
24878 mp_print(mp, mp->metric_file_name); mp_print_char(mp, xord('.'));
24879 @.Font metrics written...@>
24880 (mp->close_file)(mp,mp->tfm_file)
24882 @ Integer variables |lh|, |k|, and |lk_offset| will be defined when we use
24885 @<Output the subfile sizes and header bytes@>=
24887 LH=(k+3) / 4; /* this is the number of header words */
24888 if ( mp->bc>mp->ec ) mp->bc=1; /* if there are no characters, |ec=0| and |bc=1| */
24889 @<Compute the ligature/kern program offset and implant the
24890 left boundary label@>;
24891 mp_tfm_two(mp,6+LH+(mp->ec-mp->bc+1)+mp->nw+mp->nh+mp->nd+mp->ni+mp->nl
24892 +lk_offset+mp->nk+mp->ne+mp->np);
24893 /* this is the total number of file words that will be output */
24894 mp_tfm_two(mp, LH); mp_tfm_two(mp, mp->bc); mp_tfm_two(mp, mp->ec);
24895 mp_tfm_two(mp, mp->nw); mp_tfm_two(mp, mp->nh);
24896 mp_tfm_two(mp, mp->nd); mp_tfm_two(mp, mp->ni); mp_tfm_two(mp, mp->nl+lk_offset);
24897 mp_tfm_two(mp, mp->nk); mp_tfm_two(mp, mp->ne);
24898 mp_tfm_two(mp, mp->np);
24899 for (k=0;k< 4*LH;k++) {
24900 tfm_out(mp->header_byte[k]);
24903 @ @<Output the character information bytes...@>=
24904 for (k=mp->bc;k<=mp->ec;k++) {
24905 if ( ! mp->char_exists[k] ) {
24906 mp_tfm_four(mp, 0);
24908 tfm_out(info(mp->tfm_width[k])); /* the width index */
24909 tfm_out((info(mp->tfm_height[k]))*16+info(mp->tfm_depth[k]));
24910 tfm_out((info(mp->tfm_ital_corr[k]))*4+mp->char_tag[k]);
24911 tfm_out(mp->char_remainder[k]);
24915 for (k=1;k<=4;k++) {
24916 mp_tfm_four(mp, 0); p=mp->dimen_head[k];
24917 while ( p!=inf_val ) {
24918 mp_tfm_four(mp, mp_dimen_out(mp, value(p))); p=mp_link(p);
24923 @ We need to output special instructions at the beginning of the
24924 |lig_kern| array in order to specify the right boundary character
24925 and/or to handle starting addresses that exceed 255. The |label_loc|
24926 and |label_char| arrays have been set up to record all the
24927 starting addresses; we have $-1=|label_loc|[0]<|label_loc|[1]\le\cdots
24928 \le|label_loc|[|label_ptr]|$.
24930 @<Compute the ligature/kern program offset...@>=
24931 mp->bchar=mp_round_unscaled(mp, mp->internal[mp_boundary_char]);
24932 if ((mp->bchar<0)||(mp->bchar>255))
24933 { mp->bchar=-1; mp->lk_started=false; lk_offset=0; }
24934 else { mp->lk_started=true; lk_offset=1; };
24935 @<Find the minimum |lk_offset| and adjust all remainders@>;
24936 if ( mp->bch_label<undefined_label )
24937 { skip_byte(mp->nl)=qi(255); next_char(mp->nl)=qi(0);
24938 op_byte(mp->nl)=qi(((mp->bch_label+lk_offset)/ 256));
24939 rem_byte(mp->nl)=qi(((mp->bch_label+lk_offset)% 256));
24940 incr(mp->nl); /* possibly |nl=lig_table_size+1| */
24943 @ @<Find the minimum |lk_offset|...@>=
24944 k=mp->label_ptr; /* pointer to the largest unallocated label */
24945 if ( mp->label_loc[k]+lk_offset>255 ) {
24946 lk_offset=0; mp->lk_started=false; /* location 0 can do double duty */
24948 mp->char_remainder[mp->label_char[k]]=lk_offset;
24949 while ( mp->label_loc[k-1]==mp->label_loc[k] ) {
24950 decr(k); mp->char_remainder[mp->label_char[k]]=lk_offset;
24952 incr(lk_offset); decr(k);
24953 } while (! (lk_offset+mp->label_loc[k]<256));
24954 /* N.B.: |lk_offset=256| satisfies this when |k=0| */
24956 if ( lk_offset>0 ) {
24958 mp->char_remainder[mp->label_char[k]]
24959 =mp->char_remainder[mp->label_char[k]]+lk_offset;
24964 @ @<Output the ligature/kern program@>=
24965 for (k=0;k<= 255;k++ ) {
24966 if ( mp->skip_table[k]<undefined_label ) {
24967 mp_print_nl(mp, "(local label "); mp_print_int(mp, k); mp_print(mp, ":: was missing)");
24968 @.local label l:: was missing@>
24969 cancel_skips(mp->skip_table[k]);
24972 if ( mp->lk_started ) { /* |lk_offset=1| for the special |bchar| */
24973 tfm_out(255); tfm_out(mp->bchar); mp_tfm_two(mp, 0);
24975 for (k=1;k<=lk_offset;k++) {/* output the redirection specs */
24976 mp->ll=mp->label_loc[mp->label_ptr];
24977 if ( mp->bchar<0 ) { tfm_out(254); tfm_out(0); }
24978 else { tfm_out(255); tfm_out(mp->bchar); };
24979 mp_tfm_two(mp, mp->ll+lk_offset);
24981 decr(mp->label_ptr);
24982 } while (! (mp->label_loc[mp->label_ptr]<mp->ll));
24985 for (k=0;k<=mp->nl-1;k++) mp_tfm_qqqq(mp, mp->lig_kern[k]);
24986 for (k=0;k<=mp->nk-1;k++) mp_tfm_four(mp, mp_dimen_out(mp, mp->kern[k]))
24988 @ @<Output the extensible character recipes...@>=
24989 for (k=0;k<=mp->ne-1;k++)
24990 mp_tfm_qqqq(mp, mp->exten[k]);
24991 for (k=1;k<=mp->np;k++) {
24993 if ( abs(mp->param[1])<fraction_half ) {
24994 mp_tfm_four(mp, mp->param[1]*16);
24996 incr(mp->tfm_changed);
24997 if ( mp->param[1]>0 ) mp_tfm_four(mp, el_gordo);
24998 else mp_tfm_four(mp, -el_gordo);
25001 mp_tfm_four(mp, mp_dimen_out(mp, mp->param[k]));
25004 if ( mp->tfm_changed>0 ) {
25005 if ( mp->tfm_changed==1 ) mp_print_nl(mp, "(a font metric dimension");
25006 @.a font metric dimension...@>
25008 mp_print_nl(mp, "("); mp_print_int(mp, mp->tfm_changed);
25009 @.font metric dimensions...@>
25010 mp_print(mp, " font metric dimensions");
25012 mp_print(mp, " had to be decreased)");
25015 @ @<Log the subfile sizes of the \.{TFM} file@>=
25019 if ( mp->bch_label<undefined_label ) decr(mp->nl);
25020 mp_snprintf(s,128,"(You used %iw,%ih,%id,%ii,%il,%ik,%ie,%ip metric file positions)",
25021 mp->nw, mp->nh, mp->nd, mp->ni, mp->nl, mp->nk, mp->ne,mp->np);
25025 @* \[43] Reading font metric data.
25027 \MP\ isn't a typesetting program but it does need to find the bounding box
25028 of a sequence of typeset characters. Thus it needs to read \.{TFM} files as
25029 well as write them.
25034 @ All the width, height, and depth information is stored in an array called
25035 |font_info|. This array is allocated sequentially and each font is stored
25036 as a series of |char_info| words followed by the width, height, and depth
25037 tables. Since |font_name| entries are permanent, their |str_ref| values are
25038 set to |max_str_ref|.
25041 typedef unsigned int font_number; /* |0..font_max| */
25043 @ The |font_info| array is indexed via a group directory arrays.
25044 For example, the |char_info| data for character~|c| in font~|f| will be
25045 in |font_info[char_base[f]+c].qqqq|.
25048 font_number font_max; /* maximum font number for included text fonts */
25049 size_t font_mem_size; /* number of words for \.{TFM} information for text fonts */
25050 memory_word *font_info; /* height, width, and depth data */
25051 char **font_enc_name; /* encoding names, if any */
25052 boolean *font_ps_name_fixed; /* are the postscript names fixed already? */
25053 size_t next_fmem; /* next unused entry in |font_info| */
25054 font_number last_fnum; /* last font number used so far */
25055 scaled *font_dsize; /* 16 times the ``design'' size in \ps\ points */
25056 char **font_name; /* name as specified in the \&{infont} command */
25057 char **font_ps_name; /* PostScript name for use when |internal[mp_prologues]>0| */
25058 font_number last_ps_fnum; /* last valid |font_ps_name| index */
25059 eight_bits *font_bc;
25060 eight_bits *font_ec; /* first and last character code */
25061 int *char_base; /* base address for |char_info| */
25062 int *width_base; /* index for zeroth character width */
25063 int *height_base; /* index for zeroth character height */
25064 int *depth_base; /* index for zeroth character depth */
25065 pointer *font_sizes;
25067 @ @<Allocate or initialize ...@>=
25068 mp->font_mem_size = 10000;
25069 mp->font_info = xmalloc ((mp->font_mem_size+1),sizeof(memory_word));
25070 memset (mp->font_info,0,sizeof(memory_word)*(mp->font_mem_size+1));
25071 mp->last_fnum = null_font;
25073 @ @<Dealloc variables@>=
25074 for (k=1;k<=(int)mp->last_fnum;k++) {
25075 xfree(mp->font_enc_name[k]);
25076 xfree(mp->font_name[k]);
25077 xfree(mp->font_ps_name[k]);
25079 xfree(mp->font_info);
25080 xfree(mp->font_enc_name);
25081 xfree(mp->font_ps_name_fixed);
25082 xfree(mp->font_dsize);
25083 xfree(mp->font_name);
25084 xfree(mp->font_ps_name);
25085 xfree(mp->font_bc);
25086 xfree(mp->font_ec);
25087 xfree(mp->char_base);
25088 xfree(mp->width_base);
25089 xfree(mp->height_base);
25090 xfree(mp->depth_base);
25091 xfree(mp->font_sizes);
25095 void mp_reallocate_fonts (MP mp, font_number l) {
25097 XREALLOC(mp->font_enc_name, l, char *);
25098 XREALLOC(mp->font_ps_name_fixed, l, boolean);
25099 XREALLOC(mp->font_dsize, l, scaled);
25100 XREALLOC(mp->font_name, l, char *);
25101 XREALLOC(mp->font_ps_name, l, char *);
25102 XREALLOC(mp->font_bc, l, eight_bits);
25103 XREALLOC(mp->font_ec, l, eight_bits);
25104 XREALLOC(mp->char_base, l, int);
25105 XREALLOC(mp->width_base, l, int);
25106 XREALLOC(mp->height_base, l, int);
25107 XREALLOC(mp->depth_base, l, int);
25108 XREALLOC(mp->font_sizes, l, pointer);
25109 for (f=(mp->last_fnum+1);f<=l;f++) {
25110 mp->font_enc_name[f]=NULL;
25111 mp->font_ps_name_fixed[f] = false;
25112 mp->font_name[f]=NULL;
25113 mp->font_ps_name[f]=NULL;
25114 mp->font_sizes[f]=null;
25119 @ @<Internal library declarations@>=
25120 void mp_reallocate_fonts (MP mp, font_number l);
25123 @ A |null_font| containing no characters is useful for error recovery. Its
25124 |font_name| entry starts out empty but is reset each time an erroneous font is
25125 found. This helps to cut down on the number of duplicate error messages without
25126 wasting a lot of space.
25128 @d null_font 0 /* the |font_number| for an empty font */
25130 @<Set initial...@>=
25131 mp->font_dsize[null_font]=0;
25132 mp->font_bc[null_font]=1;
25133 mp->font_ec[null_font]=0;
25134 mp->char_base[null_font]=0;
25135 mp->width_base[null_font]=0;
25136 mp->height_base[null_font]=0;
25137 mp->depth_base[null_font]=0;
25139 mp->last_fnum=null_font;
25140 mp->last_ps_fnum=null_font;
25141 mp->font_name[null_font]=(char *)"nullfont";
25142 mp->font_ps_name[null_font]=(char *)"";
25143 mp->font_ps_name_fixed[null_font] = false;
25144 mp->font_enc_name[null_font]=NULL;
25145 mp->font_sizes[null_font]=null;
25147 @ Each |char_info| word is of type |four_quarters|. The |b0| field contains
25148 the |width index|; the |b1| field contains the height
25149 index; the |b2| fields contains the depth index, and the |b3| field used only
25150 for temporary storage. (It is used to keep track of which characters occur in
25151 an edge structure that is being shipped out.)
25152 The corresponding words in the width, height, and depth tables are stored as
25153 |scaled| values in units of \ps\ points.
25155 With the macros below, the |char_info| word for character~|c| in font~|f| is
25156 |char_info(f,c)| and the width is
25157 $$\hbox{|char_width(f,char_info(f,c)).sc|.}$$
25159 @d char_info(A,B) mp->font_info[mp->char_base[(A)]+(B)].qqqq
25160 @d char_width(A,B) mp->font_info[mp->width_base[(A)]+(B).b0].sc
25161 @d char_height(A,B) mp->font_info[mp->height_base[(A)]+(B).b1].sc
25162 @d char_depth(A,B) mp->font_info[mp->depth_base[(A)]+(B).b2].sc
25163 @d ichar_exists(A) ((A).b0>0)
25165 @ When we have a font name and we don't know whether it has been loaded yet,
25166 we scan the |font_name| array before calling |read_font_info|.
25169 static font_number mp_find_font (MP mp, char *f) ;
25172 font_number mp_find_font (MP mp, char *f) {
25174 for (n=0;n<=mp->last_fnum;n++) {
25175 if (mp_xstrcmp(f,mp->font_name[n])==0 ) {
25180 n = mp_read_font_info(mp, f);
25185 @ This is an interface function for getting the width of character,
25186 as a double in ps units
25188 @c double mp_get_char_dimension (MP mp, char *fname, int c, int t) {
25193 for (n=0;n<=mp->last_fnum;n++) {
25194 if (mp_xstrcmp(fname,mp->font_name[n])==0 ) {
25201 cc = char_info(f,c);
25202 if (! ichar_exists(cc) )
25205 w = (double)char_width(f,cc);
25207 w = (double)char_height(f,cc);
25209 w = (double)char_depth(f,cc);
25210 return w/655.35*(72.27/72);
25213 @ @<Exported function ...@>=
25214 double mp_get_char_dimension (MP mp, char *fname, int n, int t);
25217 @ One simple application of |find_font| is the implementation of the |font_size|
25218 operator that gets the design size for a given font name.
25220 @<Find the design size of the font whose name is |cur_exp|@>=
25221 mp_flush_cur_exp(mp, (mp->font_dsize[mp_find_font(mp, str(mp->cur_exp))]+8) / 16)
25223 @ If we discover that the font doesn't have a requested character, we omit it
25224 from the bounding box computation and expect the \ps\ interpreter to drop it.
25225 This routine issues a warning message if the user has asked for it.
25228 static void mp_lost_warning (MP mp,font_number f, pool_pointer k);
25231 void mp_lost_warning (MP mp,font_number f, pool_pointer k) {
25232 if ( mp->internal[mp_tracing_lost_chars]>0 ) {
25233 mp_begin_diagnostic(mp);
25234 if ( mp->selector==log_only ) incr(mp->selector);
25235 mp_print_nl(mp, "Missing character: There is no ");
25236 @.Missing character@>
25237 mp_print_str(mp, mp->str_pool[k]);
25238 mp_print(mp, " in font ");
25239 mp_print(mp, mp->font_name[f]); mp_print_char(mp, xord('!'));
25240 mp_end_diagnostic(mp, false);
25244 @ The whole purpose of saving the height, width, and depth information is to be
25245 able to find the bounding box of an item of text in an edge structure. The
25246 |set_text_box| procedure takes a text node and adds this information.
25249 static void mp_set_text_box (MP mp,pointer p);
25252 void mp_set_text_box (MP mp,pointer p) {
25253 font_number f; /* |font_n(p)| */
25254 ASCII_code bc,ec; /* range of valid characters for font |f| */
25255 pool_pointer k,kk; /* current character and character to stop at */
25256 four_quarters cc; /* the |char_info| for the current character */
25257 scaled h,d; /* dimensions of the current character */
25259 height_val(p)=-el_gordo;
25260 depth_val(p)=-el_gordo;
25261 f=(font_number)font_n(p);
25264 kk=str_stop(text_p(p));
25265 k=mp->str_start[text_p(p)];
25267 @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>;
25269 @<Set the height and depth to zero if the bounding box is empty@>;
25272 @ @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>=
25274 if ( (mp->str_pool[k]<bc)||(mp->str_pool[k]>ec) ) {
25275 mp_lost_warning(mp, f,k);
25277 cc=char_info(f,mp->str_pool[k]);
25278 if ( ! ichar_exists(cc) ) {
25279 mp_lost_warning(mp, f,k);
25281 width_val(p)=width_val(p)+char_width(f,cc);
25282 h=char_height(f,cc);
25283 d=char_depth(f,cc);
25284 if ( h>height_val(p) ) height_val(p)=h;
25285 if ( d>depth_val(p) ) depth_val(p)=d;
25291 @ Let's hope modern compilers do comparisons correctly when the difference would
25294 @<Set the height and depth to zero if the bounding box is empty@>=
25295 if ( height_val(p)<-depth_val(p) ) {
25300 @ The new primitives fontmapfile and fontmapline.
25302 @<Declare action procedures for use by |do_statement|@>=
25303 static void mp_do_mapfile (MP mp) ;
25304 static void mp_do_mapline (MP mp) ;
25307 static void mp_do_mapfile (MP mp) {
25308 mp_get_x_next(mp); mp_scan_expression(mp);
25309 if ( mp->cur_type!=mp_string_type ) {
25310 @<Complain about improper map operation@>;
25312 mp_map_file(mp,mp->cur_exp);
25315 static void mp_do_mapline (MP mp) {
25316 mp_get_x_next(mp); mp_scan_expression(mp);
25317 if ( mp->cur_type!=mp_string_type ) {
25318 @<Complain about improper map operation@>;
25320 mp_map_line(mp,mp->cur_exp);
25324 @ @<Complain about improper map operation@>=
25326 exp_err("Unsuitable expression");
25327 help1("Only known strings can be map files or map lines.");
25328 mp_put_get_error(mp);
25331 @ To print |scaled| value to PDF output we need some subroutines to ensure
25334 @d max_integer 0x7FFFFFFF /* $2^{31}-1$ */
25337 scaled one_bp; /* scaled value corresponds to 1bp */
25338 scaled one_hundred_bp; /* scaled value corresponds to 100bp */
25339 scaled one_hundred_inch; /* scaled value corresponds to 100in */
25340 integer ten_pow[10]; /* $10^0..10^9$ */
25341 integer scaled_out; /* amount of |scaled| that was taken out in |divide_scaled| */
25344 mp->one_bp = 65782; /* 65781.76 */
25345 mp->one_hundred_bp = 6578176;
25346 mp->one_hundred_inch = 473628672;
25347 mp->ten_pow[0] = 1;
25348 for (i = 1;i<= 9; i++ ) {
25349 mp->ten_pow[i] = 10*mp->ten_pow[i - 1];
25352 @ The following function divides |s| by |m|. |dd| is number of decimal digits.
25354 @c scaled mp_divide_scaled (MP mp,scaled s, scaled m, integer dd) {
25358 if ( s < 0 ) { sign = -sign; s = -s; }
25359 if ( m < 0 ) { sign = -sign; m = -m; }
25361 mp_confusion(mp, "arithmetic: divided by zero");
25362 else if ( m >= (max_integer / 10) )
25363 mp_confusion(mp, "arithmetic: number too big");
25366 for (i = 1;i<=dd;i++) {
25367 q = 10*q + (10*r) / m;
25370 if ( 2*r >= m ) { incr(q); r = r - m; }
25371 mp->scaled_out = sign*(s - (r / mp->ten_pow[dd]));
25375 @* \[44] Shipping pictures out.
25376 The |ship_out| procedure, to be described below, is given a pointer to
25377 an edge structure. Its mission is to output a file containing the \ps\
25378 description of an edge structure.
25380 @ Each time an edge structure is shipped out we write a new \ps\ output
25381 file named according to the current \&{charcode}.
25382 @:char_code_}{\&{charcode} primitive@>
25384 This is the only backend function that remains in the main |mpost.w| file.
25385 There are just too many variable accesses needed for status reporting
25386 etcetera to make it worthwile to move the code to |psout.w|.
25388 @<Internal library declarations@>=
25389 void mp_open_output_file (MP mp) ;
25392 static char *mp_set_output_file_name (MP mp, integer c) {
25393 char *ss = NULL; /* filename extension proposal */
25394 char *nn = NULL; /* temp string for str() */
25395 unsigned old_setting; /* previous |selector| setting */
25396 pool_pointer i; /* indexes into |filename_template| */
25397 integer cc; /* a temporary integer for template building */
25398 integer f,g=0; /* field widths */
25399 if ( mp->job_name==NULL ) mp_open_log_file(mp);
25400 if ( mp->filename_template==0 ) {
25401 char *s; /* a file extension derived from |c| */
25405 @<Use |c| to compute the file extension |s|@>;
25406 mp_pack_job_name(mp, s);
25408 ss = xstrdup(mp->name_of_file);
25409 } else { /* initializations */
25410 str_number s, n; /* a file extension derived from |c| */
25411 old_setting=mp->selector;
25412 mp->selector=new_string;
25414 i = mp->str_start[mp->filename_template];
25415 n = null_str; /* initialize */
25416 while ( i<str_stop(mp->filename_template) ) {
25417 if ( mp->str_pool[i]=='%' ) {
25420 if ( i<str_stop(mp->filename_template) ) {
25421 if ( mp->str_pool[i]=='j' ) {
25422 mp_print(mp, mp->job_name);
25423 } else if ( mp->str_pool[i]=='d' ) {
25424 cc= mp_round_unscaled(mp, mp->internal[mp_day]);
25425 print_with_leading_zeroes(cc);
25426 } else if ( mp->str_pool[i]=='m' ) {
25427 cc= mp_round_unscaled(mp, mp->internal[mp_month]);
25428 print_with_leading_zeroes(cc);
25429 } else if ( mp->str_pool[i]=='y' ) {
25430 cc= mp_round_unscaled(mp, mp->internal[mp_year]);
25431 print_with_leading_zeroes(cc);
25432 } else if ( mp->str_pool[i]=='H' ) {
25433 cc= mp_round_unscaled(mp, mp->internal[mp_time]) / 60;
25434 print_with_leading_zeroes(cc);
25435 } else if ( mp->str_pool[i]=='M' ) {
25436 cc= mp_round_unscaled(mp, mp->internal[mp_time]) % 60;
25437 print_with_leading_zeroes(cc);
25438 } else if ( mp->str_pool[i]=='c' ) {
25439 if ( c<0 ) mp_print(mp, "ps");
25440 else print_with_leading_zeroes(c);
25441 } else if ( (mp->str_pool[i]>='0') &&
25442 (mp->str_pool[i]<='9') ) {
25444 f = (f*10) + mp->str_pool[i]-'0';
25447 mp_print_str(mp, mp->str_pool[i]);
25451 if ( mp->str_pool[i]=='.' )
25453 n = mp_make_string(mp);
25454 mp_print_str(mp, mp->str_pool[i]);
25458 s = mp_make_string(mp);
25459 mp->selector= old_setting;
25460 if (length(n)==0) {
25466 mp_pack_file_name(mp, nn,"",ss);
25474 static char * mp_get_output_file_name (MP mp) {
25476 char *saved_name; /* saved |name_of_file| */
25477 saved_name = xstrdup(mp->name_of_file);
25478 f = xstrdup(mp_set_output_file_name(mp, mp_round_unscaled(mp, mp->internal[mp_char_code])));
25479 mp_pack_file_name(mp, saved_name,NULL,NULL);
25484 void mp_open_output_file (MP mp) {
25485 char *ss; /* filename extension proposal */
25486 integer c; /* \&{charcode} rounded to the nearest integer */
25487 c=mp_round_unscaled(mp, mp->internal[mp_char_code]);
25488 ss = mp_set_output_file_name(mp, c);
25489 while ( ! mp_a_open_out(mp, (void *)&mp->ps_file, mp_filetype_postscript) )
25490 mp_prompt_file_name(mp, "file name for output",ss);
25492 @<Store the true output file name if appropriate@>;
25495 @ The file extension created here could be up to five characters long in
25496 extreme cases so it may have to be shortened on some systems.
25497 @^system dependencies@>
25499 @<Use |c| to compute the file extension |s|@>=
25502 mp_snprintf(s,7,".%i",(int)c);
25505 @ The user won't want to see all the output file names so we only save the
25506 first and last ones and a count of how many there were. For this purpose
25507 files are ordered primarily by \&{charcode} and secondarily by order of
25509 @:char_code_}{\&{charcode} primitive@>
25511 @<Store the true output file name if appropriate@>=
25512 if ((c<mp->first_output_code)&&(mp->first_output_code>=0)) {
25513 mp->first_output_code=c;
25514 xfree(mp->first_file_name);
25515 mp->first_file_name=xstrdup(mp->name_of_file);
25517 if ( c>=mp->last_output_code ) {
25518 mp->last_output_code=c;
25519 xfree(mp->last_file_name);
25520 mp->last_file_name=xstrdup(mp->name_of_file);
25524 char * first_file_name;
25525 char * last_file_name; /* full file names */
25526 integer first_output_code;integer last_output_code; /* rounded \&{charcode} values */
25527 @:char_code_}{\&{charcode} primitive@>
25528 integer total_shipped; /* total number of |ship_out| operations completed */
25531 mp->first_file_name=xstrdup("");
25532 mp->last_file_name=xstrdup("");
25533 mp->first_output_code=32768;
25534 mp->last_output_code=-32768;
25535 mp->total_shipped=0;
25537 @ @<Dealloc variables@>=
25538 xfree(mp->first_file_name);
25539 xfree(mp->last_file_name);
25541 @ @<Begin the progress report for the output of picture~|c|@>=
25542 if ( (int)mp->term_offset>mp->max_print_line-6 ) mp_print_ln(mp);
25543 else if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_char(mp, xord(' '));
25544 mp_print_char(mp, xord('['));
25545 if ( c>=0 ) mp_print_int(mp, c)
25547 @ @<End progress report@>=
25548 mp_print_char(mp, xord(']'));
25550 incr(mp->total_shipped)
25552 @ @<Explain what output files were written@>=
25553 if ( mp->total_shipped>0 ) {
25554 mp_print_nl(mp, "");
25555 mp_print_int(mp, mp->total_shipped);
25556 if (mp->noninteractive) {
25557 mp_print(mp, " figure");
25558 if ( mp->total_shipped>1 ) mp_print_char(mp, xord('s'));
25559 mp_print(mp, " created.");
25561 mp_print(mp, " output file");
25562 if ( mp->total_shipped>1 ) mp_print_char(mp, xord('s'));
25563 mp_print(mp, " written: ");
25564 mp_print(mp, mp->first_file_name);
25565 if ( mp->total_shipped>1 ) {
25566 if ( 31+strlen(mp->first_file_name)+
25567 strlen(mp->last_file_name)> (unsigned)mp->max_print_line)
25569 mp_print(mp, " .. ");
25570 mp_print(mp, mp->last_file_name);
25575 @ @<Internal library declarations@>=
25576 boolean mp_has_font_size(MP mp, font_number f );
25579 boolean mp_has_font_size(MP mp, font_number f ) {
25580 return (mp->font_sizes[f]!=null);
25583 @ The \&{special} command saves up lines of text to be printed during the next
25584 |ship_out| operation. The saved items are stored as a list of capsule tokens.
25587 pointer last_pending; /* the last token in a list of pending specials */
25590 mp->last_pending=spec_head;
25592 @ @<Cases of |do_statement|...@>=
25593 case special_command:
25594 if ( mp->cur_mod==0 ) mp_do_special(mp); else
25595 if ( mp->cur_mod==1 ) mp_do_mapfile(mp); else
25599 @ @<Declare action procedures for use by |do_statement|@>=
25600 static void mp_do_special (MP mp) ;
25602 @ @c void mp_do_special (MP mp) {
25603 mp_get_x_next(mp); mp_scan_expression(mp);
25604 if ( mp->cur_type!=mp_string_type ) {
25605 @<Complain about improper special operation@>;
25607 mp_link(mp->last_pending)=mp_stash_cur_exp(mp);
25608 mp->last_pending=mp_link(mp->last_pending);
25609 mp_link(mp->last_pending)=null;
25613 @ @<Complain about improper special operation@>=
25615 exp_err("Unsuitable expression");
25616 help1("Only known strings are allowed for output as specials.");
25617 mp_put_get_error(mp);
25620 @ On the export side, we need an extra object type for special strings.
25622 @<Graphical object codes@>=
25625 @ @<Export pending specials@>=
25626 p=mp_link(spec_head);
25627 while ( p!=null ) {
25628 mp_special_object *tp;
25629 tp = (mp_special_object *)mp_new_graphic_object(mp,mp_special_code);
25630 gr_pre_script(tp) = str(value(p));
25631 if (hh->body==NULL) hh->body = (mp_graphic_object *)tp;
25632 else gr_link(hp) = (mp_graphic_object *)tp;
25633 hp = (mp_graphic_object *)tp;
25636 mp_flush_token_list(mp, mp_link(spec_head));
25637 mp_link(spec_head)=null;
25638 mp->last_pending=spec_head
25640 @ We are now ready for the main output procedure. Note that the |selector|
25641 setting is saved in a global variable so that |begin_diagnostic| can access it.
25643 @<Declare the \ps\ output procedures@>=
25644 static void mp_ship_out (MP mp, pointer h) ;
25646 @ Once again, the |gr_XXXX| macros are defined in |mppsout.h|
25648 @d export_color(q,p)
25649 if ( color_model(p)==mp_uninitialized_model ) {
25650 gr_color_model(q) = (unsigned char)(mp->internal[mp_default_color_model]/65536);
25651 gr_cyan_val(q) = 0;
25652 gr_magenta_val(q) = 0;
25653 gr_yellow_val(q) = 0;
25654 gr_black_val(q) = (gr_color_model(q)==mp_cmyk_model ? unity : 0);
25656 gr_color_model(q) = (unsigned char)color_model(p);
25657 gr_cyan_val(q) = cyan_val(p);
25658 gr_magenta_val(q) = magenta_val(p);
25659 gr_yellow_val(q) = yellow_val(p);
25660 gr_black_val(q) = black_val(p);
25663 @d export_scripts(q,p)
25664 if (pre_script(p)!=null) gr_pre_script(q) = str(pre_script(p));
25665 if (post_script(p)!=null) gr_post_script(q) = str(post_script(p));
25668 struct mp_edge_object *mp_gr_export(MP mp, pointer h) {
25669 pointer p; /* the current graphical object */
25670 integer t; /* a temporary value */
25671 integer c; /* a rounded charcode */
25672 scaled d_width; /* the current pen width */
25673 mp_edge_object *hh; /* the first graphical object */
25674 mp_graphic_object *hq; /* something |hp| points to */
25675 mp_text_object *tt;
25676 mp_fill_object *tf;
25677 mp_stroked_object *ts;
25678 mp_clip_object *tc;
25679 mp_bounds_object *tb;
25680 mp_graphic_object *hp = NULL; /* the current graphical object */
25681 mp_set_bbox(mp, h, true);
25682 hh = xmalloc(1,sizeof(mp_edge_object));
25686 hh->_minx = minx_val(h);
25687 hh->_miny = miny_val(h);
25688 hh->_maxx = maxx_val(h);
25689 hh->_maxy = maxy_val(h);
25690 hh->_filename = mp_get_output_file_name(mp);
25691 c = mp_round_unscaled(mp,mp->internal[mp_char_code]);
25693 hh->_width = mp->internal[mp_char_wd];
25694 hh->_height = mp->internal[mp_char_ht];
25695 hh->_depth = mp->internal[mp_char_dp];
25696 hh->_ital_corr = mp->internal[mp_char_ic];
25697 @<Export pending specials@>;
25698 p=mp_link(dummy_loc(h));
25699 while ( p!=null ) {
25700 hq = mp_new_graphic_object(mp,type(p));
25703 tf = (mp_fill_object *)hq;
25704 gr_pen_p(tf) = mp_export_knot_list(mp,pen_p(p));
25705 d_width = mp_get_pen_scale(mp, pen_p(p));
25706 if ((pen_p(p)==null) || pen_is_elliptical(pen_p(p))) {
25707 gr_path_p(tf) = mp_export_knot_list(mp,path_p(p));
25710 pc = mp_copy_path(mp, path_p(p));
25711 pp = mp_make_envelope(mp, pc, pen_p(p),ljoin_val(p),0,miterlim_val(p));
25712 gr_path_p(tf) = mp_export_knot_list(mp,pp);
25713 mp_toss_knot_list(mp, pp);
25714 pc = mp_htap_ypoc(mp, path_p(p));
25715 pp = mp_make_envelope(mp, pc, pen_p(p),ljoin_val(p),0,miterlim_val(p));
25716 gr_htap_p(tf) = mp_export_knot_list(mp,pp);
25717 mp_toss_knot_list(mp, pp);
25719 export_color(tf,p) ;
25720 export_scripts(tf,p);
25721 gr_ljoin_val(tf) = (unsigned char)ljoin_val(p);
25722 gr_miterlim_val(tf) = miterlim_val(p);
25724 case mp_stroked_code:
25725 ts = (mp_stroked_object *)hq;
25726 gr_pen_p(ts) = mp_export_knot_list(mp,pen_p(p));
25727 d_width = mp_get_pen_scale(mp, pen_p(p));
25728 if (pen_is_elliptical(pen_p(p))) {
25729 gr_path_p(ts) = mp_export_knot_list(mp,path_p(p));
25732 pc=mp_copy_path(mp, path_p(p));
25734 if ( left_type(pc)!=mp_endpoint ) {
25735 left_type(mp_insert_knot(mp, pc,x_coord(pc),y_coord(pc)))=mp_endpoint;
25736 right_type(pc)=mp_endpoint;
25740 pc=mp_make_envelope(mp,pc,pen_p(p),ljoin_val(p),t,miterlim_val(p));
25741 gr_path_p(ts) = mp_export_knot_list(mp,pc);
25742 mp_toss_knot_list(mp, pc);
25744 export_color(ts,p) ;
25745 export_scripts(ts,p);
25746 gr_ljoin_val(ts) = (unsigned char)ljoin_val(p);
25747 gr_miterlim_val(ts) = miterlim_val(p);
25748 gr_lcap_val(ts) = (unsigned char)lcap_val(p);
25749 gr_dash_p(ts) = mp_export_dashes(mp,p,&d_width);
25752 tt = (mp_text_object *)hq;
25753 gr_text_p(tt) = str(text_p(p));
25754 gr_font_n(tt) = (unsigned int)font_n(p);
25755 gr_font_name(tt) = mp_xstrdup(mp,mp->font_name[font_n(p)]);
25756 gr_font_dsize(tt) = (unsigned int)mp->font_dsize[font_n(p)];
25757 export_color(tt,p) ;
25758 export_scripts(tt,p);
25759 gr_width_val(tt) = width_val(p);
25760 gr_height_val(tt) = height_val(p);
25761 gr_depth_val(tt) = depth_val(p);
25762 gr_tx_val(tt) = tx_val(p);
25763 gr_ty_val(tt) = ty_val(p);
25764 gr_txx_val(tt) = txx_val(p);
25765 gr_txy_val(tt) = txy_val(p);
25766 gr_tyx_val(tt) = tyx_val(p);
25767 gr_tyy_val(tt) = tyy_val(p);
25769 case mp_start_clip_code:
25770 tc = (mp_clip_object *)hq;
25771 gr_path_p(tc) = mp_export_knot_list(mp,path_p(p));
25773 case mp_start_bounds_code:
25774 tb = (mp_bounds_object *)hq;
25775 gr_path_p(tb) = mp_export_knot_list(mp,path_p(p));
25777 case mp_stop_clip_code:
25778 case mp_stop_bounds_code:
25779 /* nothing to do here */
25782 if (hh->body==NULL) hh->body=hq; else gr_link(hp) = hq;
25789 @ @<Declarations@>=
25790 static struct mp_edge_object *mp_gr_export(MP mp, int h);
25792 @ This function is now nearly trivial.
25795 void mp_ship_out (MP mp, pointer h) { /* output edge structure |h| */
25796 integer c; /* \&{charcode} rounded to the nearest integer */
25797 c=mp_round_unscaled(mp, mp->internal[mp_char_code]);
25798 @<Begin the progress report for the output of picture~|c|@>;
25799 (mp->shipout_backend) (mp, h);
25800 @<End progress report@>;
25801 if ( mp->internal[mp_tracing_output]>0 )
25802 mp_print_edges(mp, h," (just shipped out)",true);
25805 @ @<Declarations@>=
25806 static void mp_shipout_backend (MP mp, pointer h);
25809 void mp_shipout_backend (MP mp, pointer h) {
25810 mp_edge_object *hh; /* the first graphical object */
25811 hh = mp_gr_export(mp,h);
25812 (void)mp_gr_ship_out (hh,
25813 (mp->internal[mp_prologues]/65536),
25814 (mp->internal[mp_procset]/65536),
25816 mp_gr_toss_objects(hh);
25819 @ @<Exported types@>=
25820 typedef void (*mp_backend_writer)(MP, int);
25822 @ @<Option variables@>=
25823 mp_backend_writer shipout_backend;
25825 @ Now that we've finished |ship_out|, let's look at the other commands
25826 by which a user can send things to the \.{GF} file.
25828 @ @<Determine if a character has been shipped out@>=
25830 mp->cur_exp=mp_round_unscaled(mp, mp->cur_exp) % 256;
25831 if ( mp->cur_exp<0 ) mp->cur_exp=mp->cur_exp+256;
25832 boolean_reset(mp->char_exists[mp->cur_exp]);
25833 mp->cur_type=mp_boolean_type;
25839 @ @<Allocate or initialize ...@>=
25840 mp_backend_initialize(mp);
25843 mp_backend_free(mp);
25846 @* \[45] Dumping and undumping the tables.
25847 After \.{INIMP} has seen a collection of macros, it
25848 can write all the necessary information on an auxiliary file so
25849 that production versions of \MP\ are able to initialize their
25850 memory at high speed. The present section of the program takes
25851 care of such output and input. We shall consider simultaneously
25852 the processes of storing and restoring,
25853 so that the inverse relation between them is clear.
25856 The global variable |mem_ident| is a string that is printed right
25857 after the |banner| line when \MP\ is ready to start. For \.{INIMP} this
25858 string says simply `\.{(INIMP)}'; for other versions of \MP\ it says,
25859 for example, `\.{(mem=plain 1990.4.14)}', showing the year,
25860 month, and day that the mem file was created. We have |mem_ident=0|
25861 before \MP's tables are loaded.
25867 mp->mem_ident=NULL;
25869 @ @<Initialize table entries...@>=
25870 mp->mem_ident=xstrdup(" (INIMP)");
25872 @ @<Declare act...@>=
25873 static void mp_store_mem_file (MP mp) ;
25875 @ @c void mp_store_mem_file (MP mp) {
25876 integer k; /* all-purpose index */
25877 pointer p,q; /* all-purpose pointers */
25878 integer x; /* something to dump */
25879 four_quarters w; /* four ASCII codes */
25881 @<Create the |mem_ident|, open the mem file,
25882 and inform the user that dumping has begun@>;
25883 @<Dump constants for consistency check@>;
25884 @<Dump the string pool@>;
25885 @<Dump the dynamic memory@>;
25886 @<Dump the table of equivalents and the hash table@>;
25887 @<Dump a few more things and the closing check word@>;
25888 @<Close the mem file@>;
25891 @ Corresponding to the procedure that dumps a mem file, we also have a function
25892 that reads~one~in. The function returns |false| if the dumped mem is
25893 incompatible with the present \MP\ table sizes, etc.
25895 @d too_small(A) { wake_up_terminal;
25896 wterm_ln("---! Must increase the "); wterm((A));
25897 @.Must increase the x@>
25902 boolean mp_load_mem_file (MP mp) {
25903 integer k; /* all-purpose index */
25904 pointer p,q; /* all-purpose pointers */
25905 integer x; /* something undumped */
25906 str_number s; /* some temporary string */
25907 four_quarters w; /* four ASCII codes */
25909 @<Undump the string pool@>;
25910 @<Undump the dynamic memory@>;
25911 @<Undump the table of equivalents and the hash table@>;
25912 @<Undump a few more things and the closing check word@>;
25913 return true; /* it worked! */
25916 wterm_ln("(Fatal mem file error; I'm stymied)\n");
25917 @.Fatal mem file error@>
25921 @ @<Declarations@>=
25922 static boolean mp_load_mem_file (MP mp) ;
25924 @ Mem files consist of |memory_word| items, and we use the following
25925 macros to dump words of different types:
25927 @d dump_wd(A) { WW=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
25928 @d dump_int(A) { int cint=(A); (mp->write_binary_file)(mp,mp->mem_file,&cint,sizeof(cint)); }
25929 @d dump_hh(A) { WW.hh=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
25930 @d dump_qqqq(A) { WW.qqqq=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
25931 @d dump_string(A) { dump_int((int)(strlen(A)+1));
25932 (mp->write_binary_file)(mp,mp->mem_file,A,strlen(A)+1); }
25935 void * mem_file; /* for input or output of mem information */
25937 @ The inverse macros are slightly more complicated, since we need to check
25938 the range of the values we are reading in. We say `|undump(a)(b)(x)|' to
25939 read an integer value |x| that is supposed to be in the range |a<=x<=b|.
25942 size_t wanted = sizeof(A);
25944 (mp->read_binary_file)(mp, mp->mem_file,&A_ptr,&wanted);
25945 if (wanted!=sizeof(A)) goto OFF_BASE;
25949 size_t wanted = sizeof(A);
25951 (mp->read_binary_file)(mp, mp->mem_file,&A_ptr,&wanted);
25952 if (wanted!=sizeof(A)) goto OFF_BASE;
25955 @d undump_wd(A) { mgetw(WW); A=WW; }
25956 @d undump_int(A) { int cint; mgeti(cint); A=cint; }
25957 @d undump_hh(A) { mgetw(WW); A=WW.hh; }
25958 @d undump_qqqq(A) { mgetw(WW); A=WW.qqqq; }
25959 @d undump_strings(A,B,C) {
25960 undump_int(x); if ( (x<(A)) || (x>(B)) ) goto OFF_BASE; else C=str(x); }
25961 @d undump(A,B,C) { undump_int(x);
25962 if ( (x<(A)) || (x>(int)(B)) ) goto OFF_BASE; else C=x; }
25963 @d undump_size(A,B,C,D) { undump_int(x);
25964 if (x<(A)) goto OFF_BASE;
25965 if (x>(B)) too_small((C)); else D=x; }
25966 @d undump_string(A) {
25971 the_wanted = (size_t)XX;
25972 the_string = xmalloc(XX,1);
25973 (mp->read_binary_file)(mp,mp->mem_file,&the_string,&the_wanted);
25974 A = (char *)the_string;
25975 if (the_wanted!=(size_t)XX) goto OFF_BASE;
25978 @ The next few sections of the program should make it clear how we use the
25979 dump/undump macros.
25981 @<Dump constants for consistency check@>=
25982 x = metapost_magic; dump_int(x);
25983 dump_int(mp->mem_top);
25984 dump_int((integer)mp->hash_size);
25985 dump_int(mp->hash_prime)
25986 dump_int(mp->param_size);
25987 dump_int(mp->max_in_open);
25989 @ Sections of a \.{WEB} program that are ``commented out'' still contribute
25990 strings to the string pool; therefore \.{INIMP} and \MP\ will have
25991 the same strings. (And it is, of course, a good thing that they do.)
25995 @<Undump constants for consistency check@>=
25997 if (x!=metapost_magic) goto OFF_BASE;
25998 undump_int(x); mp->mem_top = x;
25999 undump_int(x); mp->hash_size = (unsigned)x;
26000 undump_int(x); mp->hash_prime = x;
26001 undump_int(x); mp->param_size = x;
26002 undump_int(x); mp->max_in_open = x;
26004 @ We do string pool compaction to avoid dumping unused strings.
26007 w.b0=qi(mp->str_pool[k]); w.b1=qi(mp->str_pool[k+1]);
26008 w.b2=qi(mp->str_pool[k+2]); w.b3=qi(mp->str_pool[k+3]);
26011 @<Dump the string pool@>=
26012 mp_do_compaction(mp, mp->pool_size);
26013 dump_int(mp->pool_ptr);
26014 dump_int(mp->max_str_ptr);
26015 dump_int(mp->str_ptr);
26017 while ( (mp->next_str[k]==k+1) && (k<=mp->max_str_ptr) )
26020 while ( k<=mp->max_str_ptr ) {
26021 dump_int(mp->next_str[k]); incr(k);
26025 dump_int(mp->str_start[k]); /* TODO: valgrind warning here */
26026 if ( k==mp->str_ptr ) {
26033 while (k+4<mp->pool_ptr ) {
26034 dump_four_ASCII; k=k+4;
26036 k=mp->pool_ptr-4; dump_four_ASCII;
26037 mp_print_ln(mp); mp_print(mp, "at most "); mp_print_int(mp, mp->max_str_ptr);
26038 mp_print(mp, " strings of total length ");
26039 mp_print_int(mp, mp->pool_ptr)
26041 @ @d undump_four_ASCII
26043 mp->str_pool[k]=(ASCII_code)qo(w.b0); mp->str_pool[k+1]=(ASCII_code)qo(w.b1);
26044 mp->str_pool[k+2]=(ASCII_code)qo(w.b2); mp->str_pool[k+3]=(ASCII_code)qo(w.b3)
26046 @<Undump the string pool@>=
26047 undump_int(mp->pool_ptr);
26048 mp_reallocate_pool(mp, mp->pool_ptr) ;
26049 undump_int(mp->max_str_ptr);
26050 mp_reallocate_strings (mp,mp->max_str_ptr) ;
26051 undump(0,mp->max_str_ptr,mp->str_ptr);
26052 undump(0,mp->max_str_ptr+1,s);
26053 for (k=0;k<=s-1;k++)
26054 mp->next_str[k]=k+1;
26055 for (k=s;k<=mp->max_str_ptr;k++)
26056 undump(s+1,mp->max_str_ptr+1,mp->next_str[k]);
26057 mp->fixed_str_use=0;
26060 undump(0,mp->pool_ptr,mp->str_start[k]);
26061 if ( k==mp->str_ptr ) break;
26062 mp->str_ref[k]=max_str_ref;
26063 incr(mp->fixed_str_use);
26064 mp->last_fixed_str=k; k=mp->next_str[k];
26067 while ( k+4<mp->pool_ptr ) {
26068 undump_four_ASCII; k=k+4;
26070 k=mp->pool_ptr-4; undump_four_ASCII;
26071 mp->init_str_use=mp->fixed_str_use; mp->init_pool_ptr=mp->pool_ptr;
26072 mp->max_pool_ptr=mp->pool_ptr;
26073 mp->strs_used_up=mp->fixed_str_use;
26074 mp->pool_in_use=mp->str_start[mp->str_ptr]; mp->strs_in_use=mp->fixed_str_use;
26075 mp->max_pl_used=mp->pool_in_use; mp->max_strs_used=mp->strs_in_use;
26076 mp->pact_count=0; mp->pact_chars=0; mp->pact_strs=0;
26078 @ By sorting the list of available spaces in the variable-size portion of
26079 |mem|, we are usually able to get by without having to dump very much
26080 of the dynamic memory.
26082 We recompute |var_used| and |dyn_used|, so that \.{INIMP} dumps valid
26083 information even when it has not been gathering statistics.
26085 @<Dump the dynamic memory@>=
26086 mp_sort_avail(mp); mp->var_used=0;
26087 dump_int(mp->lo_mem_max); dump_int(mp->rover);
26088 p=0; q=mp->rover; x=0;
26090 for (k=p;k<= q+1;k++)
26091 dump_wd(mp->mem[k]);
26092 x=x+q+2-p; mp->var_used=mp->var_used+q-p;
26093 p=q+node_size(q); q=rmp_link(q);
26094 } while (q!=mp->rover);
26095 mp->var_used=mp->var_used+mp->lo_mem_max-p;
26096 mp->dyn_used=mp->mem_end+1-mp->hi_mem_min;
26097 for (k=p;k<= mp->lo_mem_max;k++ )
26098 dump_wd(mp->mem[k]);
26099 x=x+mp->lo_mem_max+1-p;
26100 dump_int(mp->hi_mem_min); dump_int(mp->avail);
26101 for (k=mp->hi_mem_min;k<=mp->mem_end;k++ )
26102 dump_wd(mp->mem[k]);
26103 x=x+mp->mem_end+1-mp->hi_mem_min;
26105 while ( p!=null ) {
26106 decr(mp->dyn_used); p=mp_link(p);
26108 dump_int(mp->var_used); dump_int(mp->dyn_used);
26109 mp_print_ln(mp); mp_print_int(mp, x);
26110 mp_print(mp, " memory locations dumped; current usage is ");
26111 mp_print_int(mp, mp->var_used); mp_print_char(mp, xord('&')); mp_print_int(mp, mp->dyn_used)
26113 @ @<Undump the dynamic memory@>=
26114 undump(lo_mem_stat_max+1000,hi_mem_stat_min-1,mp->lo_mem_max);
26115 undump(lo_mem_stat_max+1,mp->lo_mem_max,mp->rover);
26118 for (k=p;k<= q+1; k++)
26119 undump_wd(mp->mem[k]);
26121 if ( (p>mp->lo_mem_max)||((q>=rmp_link(q))&&(rmp_link(q)!=mp->rover)) )
26124 } while (q!=mp->rover);
26125 for (k=p;k<=mp->lo_mem_max;k++ )
26126 undump_wd(mp->mem[k]);
26127 undump(mp->lo_mem_max+1,hi_mem_stat_min,mp->hi_mem_min);
26128 undump(null,mp->mem_top,mp->avail); mp->mem_end=mp->mem_top;
26129 mp->last_pending=spec_head;
26130 for (k=mp->hi_mem_min;k<= mp->mem_end;k++)
26131 undump_wd(mp->mem[k]);
26132 undump_int(mp->var_used); undump_int(mp->dyn_used)
26134 @ A different scheme is used to compress the hash table, since its lower region
26135 is usually sparse. When |text(p)<>0| for |p<=hash_used|, we output three
26136 words: |p|, |hash[p]|, and |eqtb[p]|. The hash table is, of course, densely
26137 packed for |p>=hash_used|, so the remaining entries are output in~a~block.
26139 @<Dump the table of equivalents and the hash table@>=
26140 dump_int(mp->hash_used);
26141 mp->st_count=frozen_inaccessible-1-mp->hash_used;
26142 for (p=1;p<=mp->hash_used;p++) {
26143 if ( text(p)!=0 ) {
26144 dump_int(p); dump_hh(mp->hash[p]); dump_hh(mp->eqtb[p]); incr(mp->st_count);
26147 for (p=mp->hash_used+1;p<=(int)hash_end;p++) {
26148 dump_hh(mp->hash[p]); dump_hh(mp->eqtb[p]);
26150 dump_int(mp->st_count);
26151 mp_print_ln(mp); mp_print_int(mp, mp->st_count); mp_print(mp, " symbolic tokens")
26153 @ @<Undump the table of equivalents and the hash table@>=
26154 undump(1,frozen_inaccessible,mp->hash_used);
26157 undump(p+1,mp->hash_used,p);
26158 undump_hh(mp->hash[p]); undump_hh(mp->eqtb[p]);
26159 } while (p!=mp->hash_used);
26160 for (p=mp->hash_used+1;p<=(int)hash_end;p++ ) {
26161 undump_hh(mp->hash[p]); undump_hh(mp->eqtb[p]);
26163 undump_int(mp->st_count)
26165 @ We have already printed a lot of statistics, so we set |mp_tracing_stats:=0|
26166 to prevent them appearing again.
26168 @<Dump a few more things and the closing check word@>=
26169 dump_int(mp->max_internal);
26170 dump_int(mp->int_ptr);
26171 for (k=1;k<= mp->int_ptr;k++ ) {
26172 dump_int(mp->internal[k]);
26173 dump_string(mp->int_name[k]);
26175 dump_int(mp->start_sym);
26176 dump_int(mp->interaction);
26177 dump_string(mp->mem_ident);
26178 dump_int(mp->bg_loc); dump_int(mp->eg_loc); dump_int(mp->serial_no); dump_int(69073);
26179 mp->internal[mp_tracing_stats]=0
26181 @ @<Undump a few more things and the closing check word@>=
26183 if (x>mp->max_internal) mp_grow_internals(mp,x);
26184 undump_int(mp->int_ptr);
26185 for (k=1;k<= mp->int_ptr;k++) {
26186 undump_int(mp->internal[k]);
26187 undump_string(mp->int_name[k]);
26189 undump(0,frozen_inaccessible,mp->start_sym);
26190 if (mp->interaction==mp_unspecified_mode) {
26191 undump(mp_unspecified_mode,mp_error_stop_mode,mp->interaction);
26193 undump(mp_unspecified_mode,mp_error_stop_mode,x);
26195 undump_string(mp->mem_ident);
26196 undump(1,hash_end,mp->bg_loc);
26197 undump(1,hash_end,mp->eg_loc);
26198 undump_int(mp->serial_no);
26200 if (x!=69073) goto OFF_BASE
26202 @ @<Create the |mem_ident|...@>=
26204 char *tmp = xmalloc(11,1);
26205 xfree(mp->mem_ident);
26206 mp->mem_ident = xmalloc(256,1);
26207 mp_snprintf(tmp,11,"%04d.%02d.%02d",
26208 (int)mp_round_unscaled(mp, mp->internal[mp_year]),
26209 (int)mp_round_unscaled(mp, mp->internal[mp_month]),
26210 (int)mp_round_unscaled(mp, mp->internal[mp_day]));
26211 mp_snprintf(mp->mem_ident,256," (mem=%s %s)",mp->job_name, tmp);
26213 mp_pack_job_name(mp, ".mem");
26214 while (! mp_w_open_out(mp, &mp->mem_file) )
26215 mp_prompt_file_name(mp, "mem file name", ".mem");
26216 mp_print_nl(mp, "Beginning to dump on file ");
26217 @.Beginning to dump...@>
26218 mp_print(mp, mp->name_of_file);
26219 mp_print_nl(mp, mp->mem_ident);
26222 @ @<Dealloc variables@>=
26223 xfree(mp->mem_ident);
26225 @ @<Close the mem file@>=
26226 (mp->close_file)(mp,mp->mem_file)
26228 @* \[46] The main program.
26229 This is it: the part of \MP\ that executes all those procedures we have
26232 Well---almost. We haven't put the parsing subroutines into the
26233 program yet; and we'd better leave space for a few more routines that may
26234 have been forgotten.
26236 @c @<Declare the basic parsing subroutines@>
26237 @<Declare miscellaneous procedures that were declared |forward|@>
26239 @ We've noted that there are two versions of \MP. One, called \.{INIMP},
26241 has to be run first; it initializes everything from scratch, without
26242 reading a mem file, and it has the capability of dumping a mem file.
26243 The other one is called `\.{VIRMP}'; it is a ``virgin'' program that needs
26245 to input a mem file in order to get started. \.{VIRMP} typically has
26246 a bit more memory capacity than \.{INIMP}, because it does not need the
26247 space consumed by the dumping/undumping routines and the numerous calls on
26250 The \.{VIRMP} program cannot read a mem file instantaneously, of course;
26251 the best implementations therefore allow for production versions of \MP\ that
26252 not only avoid the loading routine for object code, they also have
26253 a mem file pre-loaded.
26255 @ @<Option variables@>=
26256 int ini_version; /* are we iniMP? */
26258 @ @<Set |ini_version|@>=
26259 mp->ini_version = (opt->ini_version ? true : false);
26261 @ The code below make the final chosen hash size the next larger
26262 multiple of 2 from the requested size, and this array is a list of
26263 suitable prime numbers to go with such values.
26265 The top limit is chosen such that it is definately lower than
26266 |max_halfword-3*param_size|, because |param_size| cannot be larger
26267 than |max_halfword/sizeof(pointer)|.
26270 static int mp_prime_choices[] =
26271 { 12289, 24593, 49157, 98317,
26272 196613, 393241, 786433, 1572869,
26273 3145739, 6291469, 12582917, 25165843,
26274 50331653, 100663319 };
26276 @ @<Find constant sizes@>=
26277 if (mp->ini_version) {
26279 set_value(mp->mem_top,opt->main_memory,5000);
26280 mp->mem_max = mp->mem_top;
26281 set_value(mp->param_size,opt->param_size,150);
26282 set_value(mp->max_in_open,opt->max_in_open,10);
26283 if (opt->hash_size>0x8000000)
26284 opt->hash_size=0x8000000;
26285 set_value(mp->hash_size,(2*opt->hash_size-1),16384);
26286 mp->hash_size = mp->hash_size>>i;
26287 while (mp->hash_size>=2) {
26288 mp->hash_size /= 2;
26291 mp->hash_size = mp->hash_size << i;
26292 if (mp->hash_size>0x8000000)
26293 mp->hash_size=0x8000000;
26294 mp->hash_prime=mp_prime_choices[(i-14)];
26297 if (mp->mem_name == NULL) {
26298 mp->mem_name = mp_xstrdup(mp,"plain");
26300 if (mp_open_mem_file(mp)) {
26301 @<Undump constants for consistency check@>;
26302 set_value(mp->mem_max,opt->main_memory,mp->mem_top);
26306 wterm_ln("(Fatal mem file error; I'm stymied)\n");
26307 mp->history = mp_fatal_error_stop;
26313 @ Here we do whatever is needed to complete \MP's job gracefully on the
26314 local operating system. The code here might come into play after a fatal
26315 error; it must therefore consist entirely of ``safe'' operations that
26316 cannot produce error messages. For example, it would be a mistake to call
26317 |str_room| or |make_string| at this time, because a call on |overflow|
26318 might lead to an infinite loop.
26319 @^system dependencies@>
26321 This program doesn't bother to close the input files that may still be open.
26324 void mp_close_files_and_terminate (MP mp) {
26325 integer k; /* all-purpose index */
26326 integer LH; /* the length of the \.{TFM} header, in words */
26327 int lk_offset; /* extra words inserted at beginning of |lig_kern| array */
26328 pointer p; /* runs through a list of \.{TFM} dimensions */
26329 @<Close all open files in the |rd_file| and |wr_file| arrays@>;
26330 if ( mp->internal[mp_tracing_stats]>0 )
26331 @<Output statistics about this job@>;
26333 @<Do all the finishing work on the \.{TFM} file@>;
26334 @<Explain what output files were written@>;
26335 if ( mp->log_opened && ! mp->noninteractive ){
26337 (mp->close_file)(mp,mp->log_file);
26338 mp->selector=mp->selector-2;
26339 if ( mp->selector==term_only ) {
26340 mp_print_nl(mp, "Transcript written on ");
26341 @.Transcript written...@>
26342 mp_print(mp, mp->log_name); mp_print_char(mp, xord('.'));
26346 mp->finished = true;
26349 @ @<Declarations@>=
26350 static void mp_close_files_and_terminate (MP mp) ;
26352 @ @<Close all open files in the |rd_file| and |wr_file| arrays@>=
26353 if (mp->rd_fname!=NULL) {
26354 for (k=0;k<=(int)mp->read_files-1;k++ ) {
26355 if ( mp->rd_fname[k]!=NULL ) {
26356 (mp->close_file)(mp,mp->rd_file[k]);
26357 xfree(mp->rd_fname[k]);
26361 if (mp->wr_fname!=NULL) {
26362 for (k=0;k<=(int)mp->write_files-1;k++) {
26363 if ( mp->wr_fname[k]!=NULL ) {
26364 (mp->close_file)(mp,mp->wr_file[k]);
26365 xfree(mp->wr_fname[k]);
26371 for (k=0;k<(int)mp->max_read_files;k++ ) {
26372 if ( mp->rd_fname[k]!=NULL ) {
26373 (mp->close_file)(mp,mp->rd_file[k]);
26374 xfree(mp->rd_fname[k]);
26377 xfree(mp->rd_file);
26378 xfree(mp->rd_fname);
26379 for (k=0;k<(int)mp->max_write_files;k++) {
26380 if ( mp->wr_fname[k]!=NULL ) {
26381 (mp->close_file)(mp,mp->wr_file[k]);
26382 xfree(mp->wr_fname[k]);
26385 xfree(mp->wr_file);
26386 xfree(mp->wr_fname);
26389 @ We want to produce a \.{TFM} file if and only if |mp_fontmaking| is positive.
26391 We reclaim all of the variable-size memory at this point, so that
26392 there is no chance of another memory overflow after the memory capacity
26393 has already been exceeded.
26395 @<Do all the finishing work on the \.{TFM} file@>=
26396 if ( mp->internal[mp_fontmaking]>0 ) {
26397 @<Make the dynamic memory into one big available node@>;
26398 @<Massage the \.{TFM} widths@>;
26399 mp_fix_design_size(mp); mp_fix_check_sum(mp);
26400 @<Massage the \.{TFM} heights, depths, and italic corrections@>;
26401 mp->internal[mp_fontmaking]=0; /* avoid loop in case of fatal error */
26402 @<Finish the \.{TFM} file@>;
26405 @ @<Make the dynamic memory into one big available node@>=
26406 mp->rover=lo_mem_stat_max+1; mp_link(mp->rover)=empty_flag; mp->lo_mem_max=mp->hi_mem_min-1;
26407 if ( mp->lo_mem_max-mp->rover>max_halfword ) mp->lo_mem_max=max_halfword+mp->rover;
26408 node_size(mp->rover)=mp->lo_mem_max-mp->rover;
26409 lmp_link(mp->rover)=mp->rover; rmp_link(mp->rover)=mp->rover;
26410 mp_link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null
26412 @ The present section goes directly to the log file instead of using
26413 |print| commands, because there's no need for these strings to take
26414 up |str_pool| memory when a non-{\bf stat} version of \MP\ is being used.
26416 @<Output statistics...@>=
26417 if ( mp->log_opened ) {
26420 wlog_ln("Here is how much of MetaPost's memory you used:");
26421 @.Here is how much...@>
26422 mp_snprintf(s,128," %i string%s out of %i",(int)mp->max_strs_used-mp->init_str_use,
26423 (mp->max_strs_used!=mp->init_str_use+1 ? "s" : ""),
26424 (int)(mp->max_strings-1-mp->init_str_use));
26426 mp_snprintf(s,128," %i string characters out of %i",
26427 (int)mp->max_pl_used-mp->init_pool_ptr,
26428 (int)mp->pool_size-mp->init_pool_ptr);
26430 mp_snprintf(s,128," %i words of memory out of %i",
26431 (int)mp->lo_mem_max+mp->mem_end-mp->hi_mem_min+2,
26434 mp_snprintf(s,128," %i symbolic tokens out of %i", (int)mp->st_count, (int)mp->hash_size);
26436 mp_snprintf(s,128," %ii,%in,%ip,%ib stack positions out of %ii,%in,%ip,%ib",
26437 (int)mp->max_in_stack,(int)mp->int_ptr,
26438 (int)mp->max_param_stack,(int)mp->max_buf_stack+1,
26439 (int)mp->stack_size,(int)mp->max_internal,(int)mp->param_size,(int)mp->buf_size);
26441 mp_snprintf(s,128," %i string compactions (moved %i characters, %i strings)",
26442 (int)mp->pact_count,(int)mp->pact_chars,(int)mp->pact_strs);
26446 @ It is nice to have have some of the stats available from the API.
26448 @<Exported function ...@>=
26449 int mp_memory_usage (MP mp );
26450 int mp_hash_usage (MP mp );
26451 int mp_param_usage (MP mp );
26452 int mp_open_usage (MP mp );
26455 int mp_memory_usage (MP mp ) {
26456 return (int)mp->lo_mem_max+mp->mem_end-mp->hi_mem_min+2;
26458 int mp_hash_usage (MP mp ) {
26459 return (int)mp->st_count;
26461 int mp_param_usage (MP mp ) {
26462 return (int)mp->max_param_stack;
26464 int mp_open_usage (MP mp ) {
26465 return (int)mp->max_in_stack;
26468 @ We get to the |final_cleanup| routine when \&{end} or \&{dump} has
26472 void mp_final_cleanup (MP mp) {
26473 quarterword c; /* 0 for \&{end}, 1 for \&{dump} */
26475 if ( mp->job_name==NULL ) mp_open_log_file(mp);
26476 while ( mp->input_ptr>0 ) {
26477 if ( token_state ) mp_end_token_list(mp);
26478 else mp_end_file_reading(mp);
26480 while ( mp->loop_ptr!=null ) mp_stop_iteration(mp);
26481 while ( mp->open_parens>0 ) {
26482 mp_print(mp, " )"); decr(mp->open_parens);
26484 while ( mp->cond_ptr!=null ) {
26485 mp_print_nl(mp, "(end occurred when ");
26486 @.end occurred...@>
26487 mp_print_cmd_mod(mp, fi_or_else,mp->cur_if);
26488 /* `\.{if}' or `\.{elseif}' or `\.{else}' */
26489 if ( mp->if_line!=0 ) {
26490 mp_print(mp, " on line "); mp_print_int(mp, mp->if_line);
26492 mp_print(mp, " was incomplete)");
26493 mp->if_line=if_line_field(mp->cond_ptr);
26494 mp->cur_if=name_type(mp->cond_ptr); mp->cond_ptr=mp_link(mp->cond_ptr);
26496 if ( mp->history!=mp_spotless )
26497 if ( ((mp->history==mp_warning_issued)||(mp->interaction<mp_error_stop_mode)) )
26498 if ( mp->selector==term_and_log ) {
26499 mp->selector=term_only;
26500 mp_print_nl(mp, "(see the transcript file for additional information)");
26501 @.see the transcript file...@>
26502 mp->selector=term_and_log;
26505 if (mp->ini_version) {
26506 mp_store_mem_file(mp); return;
26508 mp_print_nl(mp, "(dump is performed only by INIMP)"); return;
26509 @.dump...only by INIMP@>
26513 @ @<Declarations@>=
26514 static void mp_final_cleanup (MP mp) ;
26515 static void mp_init_prim (MP mp) ;
26516 static void mp_init_tab (MP mp) ;
26519 void mp_init_prim (MP mp) { /* initialize all the primitives */
26523 void mp_init_tab (MP mp) { /* initialize other tables */
26524 integer k; /* all-purpose index */
26525 @<Initialize table entries (done by \.{INIMP} only)@>;
26529 @ When we begin the following code, \MP's tables may still contain garbage;
26530 thus we must proceed cautiously to get bootstrapped in.
26532 But when we finish this part of the program, \MP\ is ready to call on the
26533 |main_control| routine to do its work.
26535 @<Get the first line...@>=
26537 @<Initialize the input routines@>;
26538 if (mp->mem_ident==NULL) {
26539 if ( ! mp_load_mem_file(mp) ) {
26540 (mp->close_file)(mp, mp->mem_file);
26541 mp->history = mp_fatal_error_stop;
26544 (mp->close_file)(mp, mp->mem_file);
26546 @<Initializations following first line@>;
26549 @ @<Initializations following first line@>=
26550 mp->buffer[limit]=(ASCII_code)'%';
26551 mp_fix_date_and_time(mp);
26552 if (mp->random_seed==0)
26553 mp->random_seed = (mp->internal[mp_time] / unity)+mp->internal[mp_day];
26554 mp_init_randoms(mp, mp->random_seed);
26555 @<Initialize the print |selector|...@>;
26556 if ( loc<limit ) if ( mp->buffer[loc]!='\\' )
26557 mp_start_input(mp); /* \&{input} assumed */
26559 @ @<Run inimpost commands@>=
26561 mp_get_strings_started(mp);
26562 mp_init_tab(mp); /* initialize the tables */
26563 mp_init_prim(mp); /* call |primitive| for each primitive */
26564 mp->init_str_use=mp->max_str_ptr=mp->str_ptr;
26565 mp->init_pool_ptr=mp->max_pool_ptr=mp->pool_ptr;
26566 mp_fix_date_and_time(mp);
26569 @ Saving the filename template
26571 @<Save the filename template@>=
26573 if ( mp->filename_template!=0 ) delete_str_ref(mp->filename_template);
26574 if ( length(mp->cur_exp)==0 ) mp->filename_template=0;
26576 mp->filename_template=mp->cur_exp; add_str_ref(mp->filename_template);
26580 @* \[47] Debugging.
26583 @* \[48] System-dependent changes.
26584 This section should be replaced, if necessary, by any special
26585 modification of the program
26586 that are necessary to make \MP\ work at a particular installation.
26587 It is usually best to design your change file so that all changes to
26588 previous sections preserve the section numbering; then everybody's version
26589 will be consistent with the published program. More extensive changes,
26590 which introduce new sections, can be inserted here; then only the index
26591 itself will get a new section number.
26592 @^system dependencies@>
26595 Here is where you can find all uses of each identifier in the program,
26596 with underlined entries pointing to where the identifier was defined.
26597 If the identifier is only one letter long, however, you get to see only
26598 the underlined entries. {\sl All references are to section numbers instead of
26601 This index also lists error messages and other aspects of the program
26602 that you might want to look up some day. For example, the entry
26603 for ``system dependencies'' lists all sections that should receive
26604 special attention from people who are installing \MP\ in a new
26605 operating environment. A list of various things that can't happen appears
26606 under ``this can't happen''.
26607 Approximately 25 sections are listed under ``inner loop''; these account
26608 for more than 60\pct! of \MP's running time, exclusive of input and output.