1 % $Id: mp.w 1313 2008-06-15 14:32:34Z taco $
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 banner "This is MetaPost, Version 1.071 (Cweb version)" /* printed when \MP\ starts */
92 @d metapost_version "1.071"
97 @ The external library header for \MP\ is |mplib.h|. It contains a
98 few typedefs and the header defintions for the externally used
101 The most important of the typedefs is the definition of the structure
102 |MP_options|, that acts as a small, configurable front-end to the fairly
103 large |MP_instance| structure.
106 typedef struct MP_instance * MP;
108 typedef struct MP_options {
111 @<Exported function headers@>
113 @ The internal header file is much longer: it not only lists the complete
114 |MP_instance|, but also a lot of functions that have to be available to
115 the \ps\ backend, that is defined in a separate \.{WEB} file.
117 The variables from |MP_options| are included inside the |MP_instance|
122 typedef struct psout_data_struct * psout_data;
130 @<Types in the outer block@>
131 @<Constants in the outer block@>
132 # ifndef LIBAVL_ALLOCATOR
133 # define LIBAVL_ALLOCATOR
134 struct libavl_allocator {
135 void *(*libavl_malloc) (struct libavl_allocator *, size_t libavl_size);
136 void (*libavl_free) (struct libavl_allocator *, void *libavl_block);
139 typedef struct MP_instance {
143 @<Internal library declarations@>
152 #include <unistd.h> /* for access() */
153 #include <time.h> /* for struct tm \& co */
155 #include "psout.h" /* external header */
156 #include "mpmp.h" /* internal header */
157 #include "mppsout.h" /* internal header */
160 @<Basic printing procedures@>
161 @<Error handling procedures@>
163 @ Here are the functions that set up the \MP\ instance.
166 @<Declare |mp_reallocate| functions@>
167 struct MP_options *mp_options (void);
168 MP mp_initialize (struct MP_options *opt);
171 struct MP_options *mp_options (void) {
172 struct MP_options *opt;
173 opt = malloc(sizeof(MP_options));
175 memset (opt,0,sizeof(MP_options));
177 opt->ini_version = true;
181 @ The |__attribute__| pragma is gcc-only.
183 @<Internal library ... @>=
184 #if !defined(__GNUC__) || (__GNUC__ < 2)
185 # define __attribute__(x)
186 #endif /* !defined(__GNUC__) || (__GNUC__ < 2) */
188 @ The whole instance structure is initialized with zeroes,
189 this greatly reduces the number of statements needed in
190 the |Allocate or initialize variables| block.
192 @d set_callback_option(A) do { mp->A = mp_##A;
193 if (opt->A!=NULL) mp->A = opt->A;
197 MP __attribute__ ((noinline))
198 mp_do_new (jmp_buf *buf) {
199 MP mp = malloc(sizeof(MP_instance));
202 memset(mp,0,sizeof(MP_instance));
208 static void mp_free (MP mp) {
209 int k; /* loop variable */
210 @<Dealloc variables@>
211 if (mp->noninteractive) {
212 @<Finish non-interactive use@>;
218 void __attribute__((noinline))
219 mp_do_initialize ( MP mp) {
220 @<Local variables for initialization@>
221 @<Set initial values of key variables@>
224 @ This procedure gets things started properly.
226 MP __attribute__ ((noinline))
227 mp_initialize (struct MP_options *opt) {
230 @<Setup the non-local jump buffer in |mp_new|@>;
231 mp = mp_do_new(&buf);
234 mp->userdata=opt->userdata;
235 @<Set |ini_version|@>;
236 mp->noninteractive=opt->noninteractive;
237 set_callback_option(find_file);
238 set_callback_option(open_file);
239 set_callback_option(read_ascii_file);
240 set_callback_option(read_binary_file);
241 set_callback_option(close_file);
242 set_callback_option(eof_file);
243 set_callback_option(flush_file);
244 set_callback_option(write_ascii_file);
245 set_callback_option(write_binary_file);
246 set_callback_option(shipout_backend);
247 if (opt->command_line && *(opt->command_line))
248 mp->command_line = xstrdup(opt->command_line);
249 if (mp->noninteractive) {
250 @<Prepare function pointers for non-interactive use@>;
252 /* open the terminal for output */
254 @<Find constant sizes@>;
255 @<Allocate or initialize variables@>
256 mp_reallocate_memory(mp,mp->mem_max);
257 mp_reallocate_paths(mp,1000);
258 mp_reallocate_fonts(mp,8);
259 mp->history=mp_fatal_error_stop; /* in case we quit during initialization */
260 @<Check the ``constant'' values...@>;
263 mp_snprintf(ss,256,"Ouch---my internal constants have been clobbered!\n"
264 "---case %i",(int)mp->bad);
265 do_fprintf(mp->err_out,(char *)ss);
269 mp_do_initialize(mp); /* erase preloaded mem */
270 if (mp->ini_version) {
271 @<Run inimpost commands@>;
273 if (!mp->noninteractive) {
274 @<Initialize the output routines@>;
275 @<Get the first line of input and prepare to start@>;
276 @<Initializations after first line is read@>;
278 mp->history=mp_spotless;
283 @ @<Initializations after first line is read@>=
285 mp_init_map_file(mp, mp->troff_mode);
286 mp->history=mp_spotless; /* ready to go! */
287 if (mp->troff_mode) {
288 mp->internal[mp_gtroffmode]=unity;
289 mp->internal[mp_prologues]=unity;
291 if ( mp->start_sym>0 ) { /* insert the `\&{everyjob}' symbol */
292 mp->cur_sym=mp->start_sym; mp_back_input(mp);
295 @ @<Exported function headers@>=
296 extern struct MP_options *mp_options (void);
297 extern MP mp_initialize (struct MP_options *opt) ;
298 extern int mp_status(MP mp);
299 extern void *mp_userdata(MP mp);
302 int mp_status(MP mp) { return mp->history; }
305 void *mp_userdata(MP mp) { return mp->userdata; }
307 @ The overall \MP\ program begins with the heading just shown, after which
308 comes a bunch of procedure declarations and function declarations.
309 Finally we will get to the main program, which begins with the
310 comment `|start_here|'. If you want to skip down to the
311 main program now, you can look up `|start_here|' in the index.
312 But the author suggests that the best way to understand this program
313 is to follow pretty much the order of \MP's components as they appear in the
314 \.{WEB} description you are now reading, since the present ordering is
315 intended to combine the advantages of the ``bottom up'' and ``top down''
316 approaches to the problem of understanding a somewhat complicated system.
318 @ Some of the code below is intended to be used only when diagnosing the
319 strange behavior that sometimes occurs when \MP\ is being installed or
320 when system wizards are fooling around with \MP\ without quite knowing
321 what they are doing. Such code will not normally be compiled; it is
322 delimited by the preprocessor test `|#ifdef DEBUG .. #endif|'.
324 @ This program has two important variations: (1) There is a long and slow
325 version called \.{INIMP}, which does the extra calculations needed to
327 initialize \MP's internal tables; and (2)~there is a shorter and faster
328 production version, which cuts the initialization to a bare minimum.
330 Which is which is decided at runtime.
332 @ The following parameters can be changed at compile time to extend or
333 reduce \MP's capacity. They may have different values in \.{INIMP} and
334 in production versions of \MP.
336 @^system dependencies@>
339 #define file_name_size 255 /* file names shouldn't be longer than this */
340 #define bistack_size 1500 /* size of stack for bisection algorithms;
341 should probably be left at this value */
343 @ Like the preceding parameters, the following quantities can be changed
344 to extend or reduce \MP's capacity. But if they are changed,
345 it is necessary to rerun the initialization program \.{INIMP}
347 to generate new tables for the production \MP\ program.
348 One can't simply make helter-skelter changes to the following constants,
349 since certain rather complex initialization
350 numbers are computed from them.
353 int max_strings; /* maximum number of strings; must not exceed |max_halfword| */
354 int pool_size; /* maximum number of characters in strings, including all
355 error messages and help texts, and the names of all identifiers */
356 int mem_max; /* greatest index in \MP's internal |mem| array;
357 must be strictly less than |max_halfword|;
358 must be equal to |mem_top| in \.{INIMP}, otherwise |>=mem_top| */
359 int mem_top; /* largest index in the |mem| array dumped by \.{INIMP};
360 must not be greater than |mem_max| */
361 int hash_prime; /* a prime number equal to about 85\pct! of |hash_size| */
363 @ @<Option variables@>=
364 int error_line; /* width of context lines on terminal error messages */
365 int half_error_line; /* width of first lines of contexts in terminal
366 error messages; should be between 30 and |error_line-15| */
367 int max_print_line; /* width of longest text lines output; should be at least 60 */
368 int hash_size; /* maximum number of symbolic tokens,
369 must be less than |max_halfword-3*param_size| */
370 int param_size; /* maximum number of simultaneous macro parameters */
371 int max_in_open; /* maximum number of input files and error insertions that
372 can be going on simultaneously */
373 int main_memory; /* only for options, to set up |mem_max| and |mem_top| */
374 void *userdata; /* this allows the calling application to setup local */
378 @d set_value(a,b,c) do { a=c; if (b>c) a=b; } while (0)
383 set_value(mp->error_line,opt->error_line,79);
384 set_value(mp->half_error_line,opt->half_error_line,50);
385 if (mp->half_error_line>mp->error_line-15 )
386 mp->half_error_line = mp->error_line-15;
387 set_value(mp->max_print_line,opt->max_print_line,100);
389 @ In case somebody has inadvertently made bad settings of the ``constants,''
390 \MP\ checks them using a global variable called |bad|.
392 This is the second of many sections of \MP\ where global variables are
396 integer bad; /* is some ``constant'' wrong? */
398 @ Later on we will say `\ignorespaces|if (mem_max>=max_halfword) bad=10;|',
399 or something similar. (We can't do that until |max_halfword| has been defined.)
401 In case you are wondering about the non-consequtive values of |bad|: some
402 of the things that used to be WEB constants are now runtime variables
403 with checking at assignment time.
405 @<Check the ``constant'' values for consistency@>=
407 if ( mp->mem_top<=1100 ) mp->bad=4;
409 @ Some |goto| labels are used by the following definitions. The label
410 `|restart|' is occasionally used at the very beginning of a procedure; and
411 the label `|reswitch|' is occasionally used just prior to a |case|
412 statement in which some cases change the conditions and we wish to branch
413 to the newly applicable case. Loops that are set up with the |loop|
414 construction defined below are commonly exited by going to `|done|' or to
415 `|found|' or to `|not_found|', and they are sometimes repeated by going to
416 `|continue|'. If two or more parts of a subroutine start differently but
417 end up the same, the shared code may be gathered together at
420 @ Here are some macros for common programming idioms.
422 @d incr(A) (A)=(A)+1 /* increase a variable by unity */
423 @d decr(A) (A)=(A)-1 /* decrease a variable by unity */
424 @d negate(A) (A)=-(A) /* change the sign of a variable */
425 @d double(A) (A)=(A)+(A)
427 @d do_nothing /* empty statement */
429 @* \[2] The character set.
430 In order to make \MP\ readily portable to a wide variety of
431 computers, all of its input text is converted to an internal eight-bit
432 code that includes standard ASCII, the ``American Standard Code for
433 Information Interchange.'' This conversion is done immediately when each
434 character is read in. Conversely, characters are converted from ASCII to
435 the user's external representation just before they are output to a
439 Such an internal code is relevant to users of \MP\ only with respect to
440 the \&{char} and \&{ASCII} operations, and the comparison of strings.
442 @ Characters of text that have been converted to \MP's internal form
443 are said to be of type |ASCII_code|, which is a subrange of the integers.
446 typedef unsigned char ASCII_code; /* eight-bit numbers */
448 @ The present specification of \MP\ has been written under the assumption
449 that the character set contains at least the letters and symbols associated
450 with ASCII codes 040 through 0176; all of these characters are now
451 available on most computer terminals.
454 typedef unsigned char text_char; /* the data type of characters in text files */
456 @ @<Local variables for init...@>=
459 @ The \MP\ processor converts between ASCII code and
460 the user's external character set by means of arrays |xord| and |xchr|
461 that are analogous to Pascal's |ord| and |chr| functions.
463 @d xchr(A) mp->xchr[(A)]
464 @d xord(A) mp->xord[(A)]
467 ASCII_code xord[256]; /* specifies conversion of input characters */
468 text_char xchr[256]; /* specifies conversion of output characters */
470 @ The core system assumes all 8-bit is acceptable. If it is not,
471 a change file has to alter the below section.
472 @^system dependencies@>
474 Additionally, people with extended character sets can
475 assign codes arbitrarily, giving an |xchr| equivalent to whatever
476 characters the users of \MP\ are allowed to have in their input files.
477 Appropriate changes to \MP's |char_class| table should then be made.
478 (Unlike \TeX, each installation of \MP\ has a fixed assignment of category
479 codes, called the |char_class|.) Such changes make portability of programs
480 more difficult, so they should be introduced cautiously if at all.
481 @^character set dependencies@>
482 @^system dependencies@>
485 for (i=0;i<=0377;i++) { xchr(i)=i; }
487 @ The following system-independent code makes the |xord| array contain a
488 suitable inverse to the information in |xchr|. Note that if |xchr[i]=xchr[j]|
489 where |i<j<0177|, the value of |xord[xchr[i]]| will turn out to be
490 |j| or more; hence, standard ASCII code numbers will be used instead of
491 codes below 040 in case there is a coincidence.
494 for (i=0;i<=255;i++) {
497 for (i=0200;i<=0377;i++) { xord(xchr(i))=i;}
498 for (i=0;i<=0176;i++) { xord(xchr(i))=i;}
500 @* \[3] Input and output.
501 The bane of portability is the fact that different operating systems treat
502 input and output quite differently, perhaps because computer scientists
503 have not given sufficient attention to this problem. People have felt somehow
504 that input and output are not part of ``real'' programming. Well, it is true
505 that some kinds of programming are more fun than others. With existing
506 input/output conventions being so diverse and so messy, the only sources of
507 joy in such parts of the code are the rare occasions when one can find a
508 way to make the program a little less bad than it might have been. We have
509 two choices, either to attack I/O now and get it over with, or to postpone
510 I/O until near the end. Neither prospect is very attractive, so let's
513 The basic operations we need to do are (1)~inputting and outputting of
514 text, to or from a file or the user's terminal; (2)~inputting and
515 outputting of eight-bit bytes, to or from a file; (3)~instructing the
516 operating system to initiate (``open'') or to terminate (``close'') input or
517 output from a specified file; (4)~testing whether the end of an input
518 file has been reached; (5)~display of bits on the user's screen.
519 The bit-display operation will be discussed in a later section; we shall
520 deal here only with more traditional kinds of I/O.
522 @ Finding files happens in a slightly roundabout fashion: the \MP\
523 instance object contains a field that holds a function pointer that finds a
524 file, and returns its name, or NULL. For this, it receives three
525 parameters: the non-qualified name |fname|, the intended |fopen|
526 operation type |fmode|, and the type of the file |ftype|.
528 The file types that are passed on in |ftype| can be used to
529 differentiate file searches if a library like kpathsea is used,
530 the fopen mode is passed along for the same reason.
533 typedef unsigned char eight_bits ; /* unsigned one-byte quantity */
535 @ @<Exported types@>=
537 mp_filetype_terminal = 0, /* the terminal */
538 mp_filetype_error, /* the terminal */
539 mp_filetype_program , /* \MP\ language input */
540 mp_filetype_log, /* the log file */
541 mp_filetype_postscript, /* the postscript output */
542 mp_filetype_memfile, /* memory dumps */
543 mp_filetype_metrics, /* TeX font metric files */
544 mp_filetype_fontmap, /* PostScript font mapping files */
545 mp_filetype_font, /* PostScript type1 font programs */
546 mp_filetype_encoding, /* PostScript font encoding files */
547 mp_filetype_text /* first text file for readfrom and writeto primitives */
549 typedef char *(*mp_file_finder)(MP, const char *, const char *, int);
550 typedef void *(*mp_file_opener)(MP, const char *, const char *, int);
551 typedef char *(*mp_file_reader)(MP, void *, size_t *);
552 typedef void (*mp_binfile_reader)(MP, void *, void **, size_t *);
553 typedef void (*mp_file_closer)(MP, void *);
554 typedef int (*mp_file_eoftest)(MP, void *);
555 typedef void (*mp_file_flush)(MP, void *);
556 typedef void (*mp_file_writer)(MP, void *, const char *);
557 typedef void (*mp_binfile_writer)(MP, void *, void *, size_t);
559 @ @<Option variables@>=
560 mp_file_finder find_file;
561 mp_file_opener open_file;
562 mp_file_reader read_ascii_file;
563 mp_binfile_reader read_binary_file;
564 mp_file_closer close_file;
565 mp_file_eoftest eof_file;
566 mp_file_flush flush_file;
567 mp_file_writer write_ascii_file;
568 mp_binfile_writer write_binary_file;
570 @ The default function for finding files is |mp_find_file|. It is
571 pretty stupid: it will only find files in the current directory.
573 This function may disappear altogether, it is currently only
574 used for the default font map file.
577 char *mp_find_file (MP mp, const char *fname, const char *fmode, int ftype) {
579 if (fmode[0] != 'r' || (! access (fname,R_OK)) || ftype) {
580 return strdup(fname);
585 @ Because |mp_find_file| is used so early, it has to be in the helpers
589 char *mp_find_file (MP mp, const char *fname, const char *fmode, int ftype) ;
590 void *mp_open_file (MP mp , const char *fname, const char *fmode, int ftype) ;
591 char *mp_read_ascii_file (MP mp, void *f, size_t *size) ;
592 void mp_read_binary_file (MP mp, void *f, void **d, size_t *size) ;
593 void mp_close_file (MP mp, void *f) ;
594 int mp_eof_file (MP mp, void *f) ;
595 void mp_flush_file (MP mp, void *f) ;
596 void mp_write_ascii_file (MP mp, void *f, const char *s) ;
597 void mp_write_binary_file (MP mp, void *f, void *s, size_t t) ;
599 @ The function to open files can now be very short.
602 void *mp_open_file(MP mp, const char *fname, const char *fmode, int ftype) {
605 realmode[0] = *fmode;
608 if (ftype==mp_filetype_terminal) {
609 return (fmode[0] == 'r' ? stdin : stdout);
610 } else if (ftype==mp_filetype_error) {
612 } else if (fname != NULL && (fmode[0] != 'r' || (! access (fname,R_OK)))) {
613 return (void *)fopen(fname, realmode);
618 @ This is a legacy interface: (almost) all file names pass through |name_of_file|.
621 char name_of_file[file_name_size+1]; /* the name of a system file */
622 int name_length;/* this many characters are actually
623 relevant in |name_of_file| (the rest are blank) */
625 @ @<Option variables@>=
626 int print_found_names; /* configuration parameter */
628 @ If this parameter is true, the terminal and log will report the found
629 file names for input files instead of the requested ones.
630 It is off by default because it creates an extra filename lookup.
632 @<Allocate or initialize ...@>=
633 mp->print_found_names = (opt->print_found_names>0 ? true : false);
635 @ \MP's file-opening procedures return |false| if no file identified by
636 |name_of_file| could be opened.
638 The |OPEN_FILE| macro takes care of the |print_found_names| parameter.
639 It is not used for opening a mem file for read, because that file name
643 if (mp->print_found_names) {
644 char *s = (mp->find_file)(mp,mp->name_of_file,A,ftype);
646 *f = (mp->open_file)(mp,mp->name_of_file,A, ftype);
647 strncpy(mp->name_of_file,s,file_name_size);
653 *f = (mp->open_file)(mp,mp->name_of_file,A, ftype);
656 return (*f ? true : false)
659 boolean mp_a_open_in (MP mp, void **f, int ftype) {
660 /* open a text file for input */
664 boolean mp_w_open_in (MP mp, void **f) {
665 /* open a word file for input */
666 *f = (mp->open_file)(mp,mp->name_of_file,"r",mp_filetype_memfile);
667 return (*f ? true : false);
670 boolean mp_a_open_out (MP mp, void **f, int ftype) {
671 /* open a text file for output */
675 boolean mp_b_open_out (MP mp, void **f, int ftype) {
676 /* open a binary file for output */
680 boolean mp_w_open_out (MP mp, void **f) {
681 /* open a word file for output */
682 int ftype = mp_filetype_memfile;
687 char *mp_read_ascii_file (MP mp, void *ff, size_t *size) {
689 size_t len = 0, lim = 128;
691 FILE *f = (FILE *)ff;
693 (void) mp; /* for -Wunused */
700 if (s==NULL) return NULL;
701 while (c!=EOF && c!='\n' && c!='\r') {
703 s =realloc(s, (lim+(lim>>2)));
704 if (s==NULL) return NULL;
712 if (c!=EOF && c!='\n')
721 void mp_write_ascii_file (MP mp, void *f, const char *s) {
729 void mp_read_binary_file (MP mp, void *f, void **data, size_t *size) {
733 len = fread(*data,1,*size,(FILE *)f);
738 void mp_write_binary_file (MP mp, void *f, void *s, size_t size) {
741 fwrite(s,size,1,(FILE *)f);
746 void mp_close_file (MP mp, void *f) {
753 int mp_eof_file (MP mp, void *f) {
756 return feof((FILE *)f);
762 void mp_flush_file (MP mp, void *f) {
768 @ Input from text files is read one line at a time, using a routine called
769 |input_ln|. This function is defined in terms of global variables called
770 |buffer|, |first|, and |last| that will be described in detail later; for
771 now, it suffices for us to know that |buffer| is an array of |ASCII_code|
772 values, and that |first| and |last| are indices into this array
773 representing the beginning and ending of a line of text.
776 size_t buf_size; /* maximum number of characters simultaneously present in
777 current lines of open files */
778 ASCII_code *buffer; /* lines of characters being read */
779 size_t first; /* the first unused position in |buffer| */
780 size_t last; /* end of the line just input to |buffer| */
781 size_t max_buf_stack; /* largest index used in |buffer| */
783 @ @<Allocate or initialize ...@>=
785 mp->buffer = xmalloc((mp->buf_size+1),sizeof(ASCII_code));
787 @ @<Dealloc variables@>=
791 void mp_reallocate_buffer(MP mp, size_t l) {
793 if (l>max_halfword) {
794 mp_confusion(mp,"buffer size"); /* can't happen (I hope) */
796 buffer = xmalloc((l+1),sizeof(ASCII_code));
797 memcpy(buffer,mp->buffer,(mp->buf_size+1));
799 mp->buffer = buffer ;
803 @ The |input_ln| function brings the next line of input from the specified
804 field into available positions of the buffer array and returns the value
805 |true|, unless the file has already been entirely read, in which case it
806 returns |false| and sets |last:=first|. In general, the |ASCII_code|
807 numbers that represent the next line of the file are input into
808 |buffer[first]|, |buffer[first+1]|, \dots, |buffer[last-1]|; and the
809 global variable |last| is set equal to |first| plus the length of the
810 line. Trailing blanks are removed from the line; thus, either |last=first|
811 (in which case the line was entirely blank) or |buffer[last-1]<>" "|.
814 The variable |max_buf_stack|, which is used to keep track of how large
815 the |buf_size| parameter must be to accommodate the present job, is
816 also kept up to date by |input_ln|.
819 boolean mp_input_ln (MP mp, void *f ) {
820 /* inputs the next line or returns |false| */
823 mp->last=mp->first; /* cf.\ Matthew 19\thinspace:\thinspace30 */
824 s = (mp->read_ascii_file)(mp,f, &size);
828 mp->last = mp->first+size;
829 if ( mp->last>=mp->max_buf_stack ) {
830 mp->max_buf_stack=mp->last+1;
831 while ( mp->max_buf_stack>=mp->buf_size ) {
832 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
835 memcpy((mp->buffer+mp->first),s,size);
836 /* while ( mp->buffer[mp->last]==' ' ) mp->last--; */
842 @ The user's terminal acts essentially like other files of text, except
843 that it is used both for input and for output. When the terminal is
844 considered an input file, the file variable is called |term_in|, and when it
845 is considered an output file the file variable is |term_out|.
846 @^system dependencies@>
849 void * term_in; /* the terminal as an input file */
850 void * term_out; /* the terminal as an output file */
851 void * err_out; /* the terminal as an output file */
853 @ Here is how to open the terminal files. In the default configuration,
854 nothing happens except that the command line (if there is one) is copied
855 to the input buffer. The variable |command_line| will be filled by the
856 |main| procedure. The copying can not be done earlier in the program
857 logic because in the |INI| version, the |buffer| is also used for primitive
860 @d t_open_out do {/* open the terminal for text output */
861 mp->term_out = (mp->open_file)(mp,"terminal", "w", mp_filetype_terminal);
862 mp->err_out = (mp->open_file)(mp,"error", "w", mp_filetype_error);
864 @d t_open_in do { /* open the terminal for text input */
865 mp->term_in = (mp->open_file)(mp,"terminal", "r", mp_filetype_terminal);
866 if (mp->command_line!=NULL) {
867 mp->last = strlen(mp->command_line);
868 strncpy((char *)mp->buffer,mp->command_line,mp->last);
869 xfree(mp->command_line);
875 @<Option variables@>=
878 @ Sometimes it is necessary to synchronize the input/output mixture that
879 happens on the user's terminal, and three system-dependent
880 procedures are used for this
881 purpose. The first of these, |update_terminal|, is called when we want
882 to make sure that everything we have output to the terminal so far has
883 actually left the computer's internal buffers and been sent.
884 The second, |clear_terminal|, is called when we wish to cancel any
885 input that the user may have typed ahead (since we are about to
886 issue an unexpected error message). The third, |wake_up_terminal|,
887 is supposed to revive the terminal if the user has disabled it by
888 some instruction to the operating system. The following macros show how
889 these operations can be specified:
890 @^system dependencies@>
892 @d update_terminal (mp->flush_file)(mp,mp->term_out) /* empty the terminal output buffer */
893 @d clear_terminal do_nothing /* clear the terminal input buffer */
894 @d wake_up_terminal (mp->flush_file)(mp,mp->term_out)
895 /* cancel the user's cancellation of output */
897 @ We need a special routine to read the first line of \MP\ input from
898 the user's terminal. This line is different because it is read before we
899 have opened the transcript file; there is sort of a ``chicken and
900 egg'' problem here. If the user types `\.{input cmr10}' on the first
901 line, or if some macro invoked by that line does such an \.{input},
902 the transcript file will be named `\.{cmr10.log}'; but if no \.{input}
903 commands are performed during the first line of terminal input, the transcript
904 file will acquire its default name `\.{mpout.log}'. (The transcript file
905 will not contain error messages generated by the first line before the
906 first \.{input} command.)
908 The first line is even more special. It's nice to let the user start
909 running a \MP\ job by typing a command line like `\.{MP cmr10}'; in
910 such a case, \MP\ will operate as if the first line of input were
911 `\.{cmr10}', i.e., the first line will consist of the remainder of the
912 command line, after the part that invoked \MP.
914 @ Different systems have different ways to get started. But regardless of
915 what conventions are adopted, the routine that initializes the terminal
916 should satisfy the following specifications:
918 \yskip\textindent{1)}It should open file |term_in| for input from the
919 terminal. (The file |term_out| will already be open for output to the
922 \textindent{2)}If the user has given a command line, this line should be
923 considered the first line of terminal input. Otherwise the
924 user should be prompted with `\.{**}', and the first line of input
925 should be whatever is typed in response.
927 \textindent{3)}The first line of input, which might or might not be a
928 command line, should appear in locations |first| to |last-1| of the
931 \textindent{4)}The global variable |loc| should be set so that the
932 character to be read next by \MP\ is in |buffer[loc]|. This
933 character should not be blank, and we should have |loc<last|.
935 \yskip\noindent(It may be necessary to prompt the user several times
936 before a non-blank line comes in. The prompt is `\.{**}' instead of the
937 later `\.*' because the meaning is slightly different: `\.{input}' need
938 not be typed immediately after~`\.{**}'.)
940 @d loc mp->cur_input.loc_field /* location of first unread character in |buffer| */
943 boolean mp_init_terminal (MP mp) { /* gets the terminal input started */
950 if (!mp->noninteractive) {
951 wake_up_terminal; do_fprintf(mp->term_out,"**"); update_terminal;
954 if ( ! mp_input_ln(mp, mp->term_in ) ) { /* this shouldn't happen */
955 do_fprintf(mp->term_out,"\n! End of file on the terminal... why?");
956 @.End of file on the terminal@>
960 while ( (loc<(int)mp->last)&&(mp->buffer[loc]==' ') )
962 if ( loc<(int)mp->last ) {
963 return true; /* return unless the line was all blank */
965 if (!mp->noninteractive) {
966 do_fprintf(mp->term_out,"Please type the name of your input file.\n");
972 boolean mp_init_terminal (MP mp) ;
975 @* \[4] String handling.
976 Symbolic token names and diagnostic messages are variable-length strings
977 of eight-bit characters. Many strings \MP\ uses are simply literals
978 in the compiled source, like the error messages and the names of the
979 internal parameters. Other strings are used or defined from the \MP\ input
980 language, and these have to be interned.
982 \MP\ uses strings more extensively than \MF\ does, but the necessary
983 operations can still be handled with a fairly simple data structure.
984 The array |str_pool| contains all of the (eight-bit) ASCII codes in all
985 of the strings, and the array |str_start| contains indices of the starting
986 points of each string. Strings are referred to by integer numbers, so that
987 string number |s| comprises the characters |str_pool[j]| for
988 |str_start[s]<=j<str_start[ss]| where |ss=next_str[s]|. The string pool
989 is allocated sequentially and |str_pool[pool_ptr]| is the next unused
990 location. The first string number not currently in use is |str_ptr|
991 and |next_str[str_ptr]| begins a list of free string numbers. String
992 pool entries |str_start[str_ptr]| up to |pool_ptr| are reserved for a
993 string currently being constructed.
995 String numbers 0 to 255 are reserved for strings that correspond to single
996 ASCII characters. This is in accordance with the conventions of \.{WEB},
998 which converts single-character strings into the ASCII code number of the
999 single character involved, while it converts other strings into integers
1000 and builds a string pool file. Thus, when the string constant \.{"."} appears
1001 in the program below, \.{WEB} converts it into the integer 46, which is the
1002 ASCII code for a period, while \.{WEB} will convert a string like \.{"hello"}
1003 into some integer greater than~255. String number 46 will presumably be the
1004 single character `\..'\thinspace; but some ASCII codes have no standard visible
1005 representation, and \MP\ may need to be able to print an arbitrary
1006 ASCII character, so the first 256 strings are used to specify exactly what
1007 should be printed for each of the 256 possibilities.
1010 typedef int pool_pointer; /* for variables that point into |str_pool| */
1011 typedef int str_number; /* for variables that point into |str_start| */
1014 ASCII_code *str_pool; /* the characters */
1015 pool_pointer *str_start; /* the starting pointers */
1016 str_number *next_str; /* for linking strings in order */
1017 pool_pointer pool_ptr; /* first unused position in |str_pool| */
1018 str_number str_ptr; /* number of the current string being created */
1019 pool_pointer init_pool_ptr; /* the starting value of |pool_ptr| */
1020 str_number init_str_use; /* the initial number of strings in use */
1021 pool_pointer max_pool_ptr; /* the maximum so far of |pool_ptr| */
1022 str_number max_str_ptr; /* the maximum so far of |str_ptr| */
1024 @ @<Allocate or initialize ...@>=
1025 mp->str_pool = xmalloc ((mp->pool_size +1),sizeof(ASCII_code));
1026 mp->str_start = xmalloc ((mp->max_strings+1),sizeof(pool_pointer));
1027 mp->next_str = xmalloc ((mp->max_strings+1),sizeof(str_number));
1029 @ @<Dealloc variables@>=
1030 xfree(mp->str_pool);
1031 xfree(mp->str_start);
1032 xfree(mp->next_str);
1034 @ Most printing is done from |char *|s, but sometimes not. Here are
1035 functions that convert an internal string into a |char *| for use
1036 by the printing routines, and vice versa.
1038 @d str(A) mp_str(mp,A)
1039 @d rts(A) mp_rts(mp,A)
1042 int mp_xstrcmp (const char *a, const char *b);
1043 char * mp_str (MP mp, str_number s);
1046 str_number mp_rts (MP mp, const char *s);
1047 str_number mp_make_string (MP mp);
1050 int mp_xstrcmp (const char *a, const char *b) {
1051 if (a==NULL && b==NULL)
1060 @ The attempt to catch interrupted strings that is in |mp_rts|, is not
1061 very good: it does not handle nesting over more than one level.
1064 char * mp_str (MP mp, str_number ss) {
1067 if (ss==mp->str_ptr) {
1071 s = xmalloc(len+1,sizeof(char));
1072 strncpy(s,(char *)(mp->str_pool+(mp->str_start[ss])),len);
1077 str_number mp_rts (MP mp, const char *s) {
1078 int r; /* the new string */
1079 int old; /* a possible string in progress */
1083 } else if (strlen(s)==1) {
1087 str_room((integer)strlen(s));
1088 if (mp->str_start[mp->str_ptr]<mp->pool_ptr)
1089 old = mp_make_string(mp);
1094 r = mp_make_string(mp);
1096 str_room(length(old));
1097 while (i<length(old)) {
1098 append_char((mp->str_start[old]+i));
1100 mp_flush_string(mp,old);
1106 @ Except for |strs_used_up|, the following string statistics are only
1107 maintained when code between |stat| $\ldots$ |tats| delimiters is not
1111 integer strs_used_up; /* strings in use or unused but not reclaimed */
1112 integer pool_in_use; /* total number of cells of |str_pool| actually in use */
1113 integer strs_in_use; /* total number of strings actually in use */
1114 integer max_pl_used; /* maximum |pool_in_use| so far */
1115 integer max_strs_used; /* maximum |strs_in_use| so far */
1117 @ Several of the elementary string operations are performed using \.{WEB}
1118 macros instead of functions, because many of the
1119 operations are done quite frequently and we want to avoid the
1120 overhead of procedure calls. For example, here is
1121 a simple macro that computes the length of a string.
1124 @d str_stop(A) mp->str_start[mp->next_str[(A)]] /* one cell past the end of string \# */
1125 @d length(A) (str_stop((A))-mp->str_start[(A)]) /* the number of characters in string \# */
1127 @ The length of the current string is called |cur_length|. If we decide that
1128 the current string is not needed, |flush_cur_string| resets |pool_ptr| so that
1129 |cur_length| becomes zero.
1131 @d cur_length (mp->pool_ptr - mp->str_start[mp->str_ptr])
1132 @d flush_cur_string mp->pool_ptr=mp->str_start[mp->str_ptr]
1134 @ Strings are created by appending character codes to |str_pool|.
1135 The |append_char| macro, defined here, does not check to see if the
1136 value of |pool_ptr| has gotten too high; this test is supposed to be
1137 made before |append_char| is used.
1139 To test if there is room to append |l| more characters to |str_pool|,
1140 we shall write |str_room(l)|, which tries to make sure there is enough room
1141 by compacting the string pool if necessary. If this does not work,
1142 |do_compaction| aborts \MP\ and gives an apologetic error message.
1144 @d append_char(A) /* put |ASCII_code| \# at the end of |str_pool| */
1145 { mp->str_pool[mp->pool_ptr]=(A); incr(mp->pool_ptr);
1147 @d str_room(A) /* make sure that the pool hasn't overflowed */
1148 { if ( mp->pool_ptr+(A) > mp->max_pool_ptr ) {
1149 if ( mp->pool_ptr+(A) > mp->pool_size ) mp_do_compaction(mp, (A));
1150 else mp->max_pool_ptr=mp->pool_ptr+(A); }
1153 @ The following routine is similar to |str_room(1)| but it uses the
1154 argument |mp->pool_size| to prevent |do_compaction| from aborting when
1155 string space is exhausted.
1157 @<Declare the procedure called |unit_str_room|@>=
1158 void mp_unit_str_room (MP mp);
1161 void mp_unit_str_room (MP mp) {
1162 if ( mp->pool_ptr>=mp->pool_size ) mp_do_compaction(mp, mp->pool_size);
1163 if ( mp->pool_ptr>=mp->max_pool_ptr ) mp->max_pool_ptr=mp->pool_ptr+1;
1166 @ \MP's string expressions are implemented in a brute-force way: Every
1167 new string or substring that is needed is simply copied into the string pool.
1168 Space is eventually reclaimed by a procedure called |do_compaction| with
1169 the aid of a simple system system of reference counts.
1170 @^reference counts@>
1172 The number of references to string number |s| will be |str_ref[s]|. The
1173 special value |str_ref[s]=max_str_ref=127| is used to denote an unknown
1174 positive number of references; such strings will never be recycled. If
1175 a string is ever referred to more than 126 times, simultaneously, we
1176 put it in this category. Hence a single byte suffices to store each |str_ref|.
1178 @d max_str_ref 127 /* ``infinite'' number of references */
1179 @d add_str_ref(A) { if ( mp->str_ref[(A)]<max_str_ref ) incr(mp->str_ref[(A)]); }
1184 @ @<Allocate or initialize ...@>=
1185 mp->str_ref = xmalloc ((mp->max_strings+1),sizeof(int));
1187 @ @<Dealloc variables@>=
1190 @ Here's what we do when a string reference disappears:
1192 @d delete_str_ref(A) {
1193 if ( mp->str_ref[(A)]<max_str_ref ) {
1194 if ( mp->str_ref[(A)]>1 ) decr(mp->str_ref[(A)]);
1195 else mp_flush_string(mp, (A));
1199 @<Declare the procedure called |flush_string|@>=
1200 void mp_flush_string (MP mp,str_number s) ;
1203 @ We can't flush the first set of static strings at all, so there
1204 is no point in trying
1207 void mp_flush_string (MP mp,str_number s) {
1209 mp->pool_in_use=mp->pool_in_use-length(s);
1210 decr(mp->strs_in_use);
1211 if ( mp->next_str[s]!=mp->str_ptr ) {
1215 decr(mp->strs_used_up);
1217 mp->pool_ptr=mp->str_start[mp->str_ptr];
1221 @ C literals cannot be simply added, they need to be set so they can't
1224 @d intern(A) mp_intern(mp,(A))
1227 str_number mp_intern (MP mp, const char *s) {
1230 mp->str_ref[r] = max_str_ref;
1235 str_number mp_intern (MP mp, const char *s);
1238 @ Once a sequence of characters has been appended to |str_pool|, it
1239 officially becomes a string when the function |make_string| is called.
1240 This function returns the identification number of the new string as its
1243 When getting the next unused string number from the linked list, we pretend
1245 $$ \hbox{|max_str_ptr+1|, |max_str_ptr+2|, $\ldots$, |mp->max_strings|} $$
1246 are linked sequentially even though the |next_str| entries have not been
1247 initialized yet. We never allow |str_ptr| to reach |mp->max_strings|;
1248 |do_compaction| is responsible for making sure of this.
1251 @<Declare the procedure called |do_compaction|@>
1252 @<Declare the procedure called |unit_str_room|@>
1253 str_number mp_make_string (MP mp);
1256 str_number mp_make_string (MP mp) { /* current string enters the pool */
1257 str_number s; /* the new string */
1260 mp->str_ptr=mp->next_str[s];
1261 if ( mp->str_ptr>mp->max_str_ptr ) {
1262 if ( mp->str_ptr==mp->max_strings ) {
1264 mp_do_compaction(mp, 0);
1267 mp->max_str_ptr=mp->str_ptr;
1268 mp->next_str[mp->str_ptr]=mp->max_str_ptr+1;
1272 mp->str_start[mp->str_ptr]=mp->pool_ptr;
1273 incr(mp->strs_used_up);
1274 incr(mp->strs_in_use);
1275 mp->pool_in_use=mp->pool_in_use+length(s);
1276 if ( mp->pool_in_use>mp->max_pl_used )
1277 mp->max_pl_used=mp->pool_in_use;
1278 if ( mp->strs_in_use>mp->max_strs_used )
1279 mp->max_strs_used=mp->strs_in_use;
1283 @ The most interesting string operation is string pool compaction. The idea
1284 is to recover unused space in the |str_pool| array by recopying the strings
1285 to close the gaps created when some strings become unused. All string
1286 numbers~$k$ where |str_ref[k]=0| are to be linked into the list of free string
1287 numbers after |str_ptr|. If this fails to free enough pool space we issue an
1288 |overflow| error unless |needed=mp->pool_size|. Calling |do_compaction|
1289 with |needed=mp->pool_size| supresses all overflow tests.
1291 The compaction process starts with |last_fixed_str| because all lower numbered
1292 strings are permanently allocated with |max_str_ref| in their |str_ref| entries.
1295 str_number last_fixed_str; /* last permanently allocated string */
1296 str_number fixed_str_use; /* number of permanently allocated strings */
1298 @ @<Declare the procedure called |do_compaction|@>=
1299 void mp_do_compaction (MP mp, pool_pointer needed) ;
1302 void mp_do_compaction (MP mp, pool_pointer needed) {
1303 str_number str_use; /* a count of strings in use */
1304 str_number r,s,t; /* strings being manipulated */
1305 pool_pointer p,q; /* destination and source for copying string characters */
1306 @<Advance |last_fixed_str| as far as possible and set |str_use|@>;
1307 r=mp->last_fixed_str;
1310 while ( s!=mp->str_ptr ) {
1311 while ( mp->str_ref[s]==0 ) {
1312 @<Advance |s| and add the old |s| to the list of free string numbers;
1313 then |break| if |s=str_ptr|@>;
1315 r=s; s=mp->next_str[s];
1317 @<Move string |r| back so that |str_start[r]=p|; make |p| the location
1318 after the end of the string@>;
1321 @<Move the current string back so that it starts at |p|@>;
1322 if ( needed<mp->pool_size ) {
1323 @<Make sure that there is room for another string with |needed| characters@>;
1325 @<Account for the compaction and make sure the statistics agree with the
1327 mp->strs_used_up=str_use;
1330 @ @<Advance |last_fixed_str| as far as possible and set |str_use|@>=
1331 t=mp->next_str[mp->last_fixed_str];
1332 while (t!=mp->str_ptr && mp->str_ref[t]==max_str_ref) {
1333 incr(mp->fixed_str_use);
1334 mp->last_fixed_str=t;
1337 str_use=mp->fixed_str_use
1339 @ Because of the way |flush_string| has been written, it should never be
1340 necessary to |break| here. The extra line of code seems worthwhile to
1341 preserve the generality of |do_compaction|.
1343 @<Advance |s| and add the old |s| to the list of free string numbers;...@>=
1348 mp->next_str[t]=mp->next_str[mp->str_ptr];
1349 mp->next_str[mp->str_ptr]=t;
1350 if ( s==mp->str_ptr ) goto DONE;
1353 @ The string currently starts at |str_start[r]| and ends just before
1354 |str_start[s]|. We don't change |str_start[s]| because it might be needed
1355 to locate the next string.
1357 @<Move string |r| back so that |str_start[r]=p|; make |p| the location...@>=
1360 while ( q<mp->str_start[s] ) {
1361 mp->str_pool[p]=mp->str_pool[q];
1365 @ Pointers |str_start[str_ptr]| and |pool_ptr| have not been updated. When
1366 we do this, anything between them should be moved.
1368 @ @<Move the current string back so that it starts at |p|@>=
1369 q=mp->str_start[mp->str_ptr];
1370 mp->str_start[mp->str_ptr]=p;
1371 while ( q<mp->pool_ptr ) {
1372 mp->str_pool[p]=mp->str_pool[q];
1377 @ We must remember that |str_ptr| is not allowed to reach |mp->max_strings|.
1379 @<Make sure that there is room for another string with |needed| char...@>=
1380 if ( str_use>=mp->max_strings-1 )
1381 mp_reallocate_strings (mp,str_use);
1382 if ( mp->pool_ptr+needed>mp->max_pool_ptr ) {
1383 mp_reallocate_pool(mp, mp->pool_ptr+needed);
1384 mp->max_pool_ptr=mp->pool_ptr+needed;
1388 void mp_reallocate_strings (MP mp, str_number str_use) ;
1389 void mp_reallocate_pool(MP mp, pool_pointer needed) ;
1392 void mp_reallocate_strings (MP mp, str_number str_use) {
1393 while ( str_use>=mp->max_strings-1 ) {
1394 int l = mp->max_strings + (mp->max_strings>>2);
1395 XREALLOC (mp->str_ref, l, int);
1396 XREALLOC (mp->str_start, l, pool_pointer);
1397 XREALLOC (mp->next_str, l, str_number);
1398 mp->max_strings = l;
1401 void mp_reallocate_pool(MP mp, pool_pointer needed) {
1402 while ( needed>mp->pool_size ) {
1403 int l = mp->pool_size + (mp->pool_size>>2);
1404 XREALLOC (mp->str_pool, l, ASCII_code);
1409 @ @<Account for the compaction and make sure the statistics agree with...@>=
1410 if ( (mp->str_start[mp->str_ptr]!=mp->pool_in_use)||(str_use!=mp->strs_in_use) )
1411 mp_confusion(mp, "string");
1412 @:this can't happen string}{\quad string@>
1413 incr(mp->pact_count);
1414 mp->pact_chars=mp->pact_chars+mp->pool_ptr-str_stop(mp->last_fixed_str);
1415 mp->pact_strs=mp->pact_strs+str_use-mp->fixed_str_use;
1417 @ A few more global variables are needed to keep track of statistics when
1418 |stat| $\ldots$ |tats| blocks are not commented out.
1421 integer pact_count; /* number of string pool compactions so far */
1422 integer pact_chars; /* total number of characters moved during compactions */
1423 integer pact_strs; /* total number of strings moved during compactions */
1425 @ @<Initialize compaction statistics@>=
1430 @ The following subroutine compares string |s| with another string of the
1431 same length that appears in |buffer| starting at position |k|;
1432 the result is |true| if and only if the strings are equal.
1435 boolean mp_str_eq_buf (MP mp,str_number s, integer k) {
1436 /* test equality of strings */
1437 pool_pointer j; /* running index */
1439 while ( j<str_stop(s) ) {
1440 if ( mp->str_pool[j++]!=mp->buffer[k++] )
1446 @ Here is a similar routine, but it compares two strings in the string pool,
1447 and it does not assume that they have the same length. If the first string
1448 is lexicographically greater than, less than, or equal to the second,
1449 the result is respectively positive, negative, or zero.
1452 integer mp_str_vs_str (MP mp, str_number s, str_number t) {
1453 /* test equality of strings */
1454 pool_pointer j,k; /* running indices */
1455 integer ls,lt; /* lengths */
1456 integer l; /* length remaining to test */
1457 ls=length(s); lt=length(t);
1458 if ( ls<=lt ) l=ls; else l=lt;
1459 j=mp->str_start[s]; k=mp->str_start[t];
1461 if ( mp->str_pool[j]!=mp->str_pool[k] ) {
1462 return (mp->str_pool[j]-mp->str_pool[k]);
1469 @ The initial values of |str_pool|, |str_start|, |pool_ptr|,
1470 and |str_ptr| are computed by the \.{INIMP} program, based in part
1471 on the information that \.{WEB} has output while processing \MP.
1476 void mp_get_strings_started (MP mp) {
1477 /* initializes the string pool,
1478 but returns |false| if something goes wrong */
1479 int k; /* small indices or counters */
1480 str_number g; /* a new string */
1481 mp->pool_ptr=0; mp->str_ptr=0; mp->max_pool_ptr=0; mp->max_str_ptr=0;
1484 mp->pool_in_use=0; mp->strs_in_use=0;
1485 mp->max_pl_used=0; mp->max_strs_used=0;
1486 @<Initialize compaction statistics@>;
1488 @<Make the first 256 strings@>;
1489 g=mp_make_string(mp); /* string 256 == "" */
1490 mp->str_ref[g]=max_str_ref;
1491 mp->last_fixed_str=mp->str_ptr-1;
1492 mp->fixed_str_use=mp->str_ptr;
1497 void mp_get_strings_started (MP mp);
1499 @ The first 256 strings will consist of a single character only.
1501 @<Make the first 256...@>=
1502 for (k=0;k<=255;k++) {
1504 g=mp_make_string(mp);
1505 mp->str_ref[g]=max_str_ref;
1508 @ The first 128 strings will contain 95 standard ASCII characters, and the
1509 other 33 characters will be printed in three-symbol form like `\.{\^\^A}'
1510 unless a system-dependent change is made here. Installations that have
1511 an extended character set, where for example |xchr[032]=@t\.{'^^Z'}@>|,
1512 would like string 032 to be printed as the single character 032 instead
1513 of the three characters 0136, 0136, 0132 (\.{\^\^Z}). On the other hand,
1514 even people with an extended character set will want to represent string
1515 015 by \.{\^\^M}, since 015 is ASCII's ``carriage return'' code; the idea is
1516 to produce visible strings instead of tabs or line-feeds or carriage-returns
1517 or bell-rings or characters that are treated anomalously in text files.
1519 The boolean expression defined here should be |true| unless \MP\ internal
1520 code number~|k| corresponds to a non-troublesome visible symbol in the
1521 local character set.
1522 If character |k| cannot be printed, and |k<0200|, then character |k+0100| or
1523 |k-0100| must be printable; moreover, ASCII codes |[060..071, 0141..0146]|
1525 @^character set dependencies@>
1526 @^system dependencies@>
1528 @<Character |k| cannot be printed@>=
1531 @* \[5] On-line and off-line printing.
1532 Messages that are sent to a user's terminal and to the transcript-log file
1533 are produced by several `|print|' procedures. These procedures will
1534 direct their output to a variety of places, based on the setting of
1535 the global variable |selector|, which has the following possible
1539 \hang |term_and_log|, the normal setting, prints on the terminal and on the
1542 \hang |log_only|, prints only on the transcript file.
1544 \hang |term_only|, prints only on the terminal.
1546 \hang |no_print|, doesn't print at all. This is used only in rare cases
1547 before the transcript file is open.
1549 \hang |pseudo|, puts output into a cyclic buffer that is used
1550 by the |show_context| routine; when we get to that routine we shall discuss
1551 the reasoning behind this curious mode.
1553 \hang |new_string|, appends the output to the current string in the
1556 \hang |>=write_file| prints on one of the files used for the \&{write}
1557 @:write_}{\&{write} primitive@>
1561 \noindent The symbolic names `|term_and_log|', etc., have been assigned
1562 numeric codes that satisfy the convenient relations |no_print+1=term_only|,
1563 |no_print+2=log_only|, |term_only+2=log_only+1=term_and_log|. These
1564 relations are not used when |selector| could be |pseudo|, or |new_string|.
1565 We need not check for unprintable characters when |selector<pseudo|.
1567 Three additional global variables, |tally|, |term_offset| and |file_offset|
1568 record the number of characters that have been printed
1569 since they were most recently cleared to zero. We use |tally| to record
1570 the length of (possibly very long) stretches of printing; |term_offset|,
1571 and |file_offset|, on the other hand, keep track of how many
1572 characters have appeared so far on the current line that has been output
1573 to the terminal, the transcript file, or the \ps\ output file, respectively.
1575 @d new_string 0 /* printing is deflected to the string pool */
1576 @d pseudo 2 /* special |selector| setting for |show_context| */
1577 @d no_print 3 /* |selector| setting that makes data disappear */
1578 @d term_only 4 /* printing is destined for the terminal only */
1579 @d log_only 5 /* printing is destined for the transcript file only */
1580 @d term_and_log 6 /* normal |selector| setting */
1581 @d write_file 7 /* first write file selector */
1584 void * log_file; /* transcript of \MP\ session */
1585 void * ps_file; /* the generic font output goes here */
1586 unsigned int selector; /* where to print a message */
1587 unsigned char dig[23]; /* digits in a number, for rounding */
1588 integer tally; /* the number of characters recently printed */
1589 unsigned int term_offset;
1590 /* the number of characters on the current terminal line */
1591 unsigned int file_offset;
1592 /* the number of characters on the current file line */
1593 ASCII_code *trick_buf; /* circular buffer for pseudoprinting */
1594 integer trick_count; /* threshold for pseudoprinting, explained later */
1595 integer first_count; /* another variable for pseudoprinting */
1597 @ @<Allocate or initialize ...@>=
1598 mp->trick_buf = xmalloc((mp->error_line+1),sizeof(ASCII_code));
1600 @ @<Dealloc variables@>=
1601 xfree(mp->trick_buf);
1603 @ @<Initialize the output routines@>=
1604 mp->selector=term_only; mp->tally=0; mp->term_offset=0; mp->file_offset=0;
1606 @ Macro abbreviations for output to the terminal and to the log file are
1607 defined here for convenience. Some systems need special conventions
1608 for terminal output, and it is possible to adhere to those conventions
1609 by changing |wterm|, |wterm_ln|, and |wterm_cr| here.
1610 @^system dependencies@>
1612 @d do_fprintf(f,b) (mp->write_ascii_file)(mp,f,b)
1613 @d wterm(A) do_fprintf(mp->term_out,(A))
1614 @d wterm_chr(A) { unsigned char ss[2]; ss[0]=(A); ss[1]=0; do_fprintf(mp->term_out,(char *)ss); }
1615 @d wterm_cr do_fprintf(mp->term_out,"\n")
1616 @d wterm_ln(A) { wterm_cr; do_fprintf(mp->term_out,(A)); }
1617 @d wlog(A) do_fprintf(mp->log_file,(A))
1618 @d wlog_chr(A) { unsigned char ss[2]; ss[0]=(A); ss[1]=0; do_fprintf(mp->log_file,(char *)ss); }
1619 @d wlog_cr do_fprintf(mp->log_file, "\n")
1620 @d wlog_ln(A) { wlog_cr; do_fprintf(mp->log_file,(A)); }
1623 @ To end a line of text output, we call |print_ln|. Cases |0..max_write_files|
1624 use an array |wr_file| that will be declared later.
1626 @d mp_print_text(A) mp_print_str(mp,text((A)))
1629 void mp_print_ln (MP mp);
1630 void mp_print_visible_char (MP mp, ASCII_code s);
1631 void mp_print_char (MP mp, ASCII_code k);
1632 void mp_print (MP mp, const char *s);
1633 void mp_print_str (MP mp, str_number s);
1634 void mp_print_nl (MP mp, const char *s);
1635 void mp_print_two (MP mp,scaled x, scaled y) ;
1636 void mp_print_scaled (MP mp,scaled s);
1638 @ @<Basic print...@>=
1639 void mp_print_ln (MP mp) { /* prints an end-of-line */
1640 switch (mp->selector) {
1643 mp->term_offset=0; mp->file_offset=0;
1646 wlog_cr; mp->file_offset=0;
1649 wterm_cr; mp->term_offset=0;
1656 do_fprintf(mp->wr_file[(mp->selector-write_file)],"\n");
1658 } /* note that |tally| is not affected */
1660 @ The |print_visible_char| procedure sends one character to the desired
1661 destination, using the |xchr| array to map it into an external character
1662 compatible with |input_ln|. (It assumes that it is always called with
1663 a visible ASCII character.) All printing comes through |print_ln| or
1664 |print_char|, which ultimately calls |print_visible_char|, hence these
1665 routines are the ones that limit lines to at most |max_print_line| characters.
1666 But we must make an exception for the \ps\ output file since it is not safe
1667 to cut up lines arbitrarily in \ps.
1669 Procedure |unit_str_room| needs to be declared |forward| here because it calls
1670 |do_compaction| and |do_compaction| can call the error routines. Actually,
1671 |unit_str_room| avoids |overflow| errors but it can call |confusion|.
1673 @<Basic printing...@>=
1674 void mp_print_visible_char (MP mp, ASCII_code s) { /* prints a single character */
1675 switch (mp->selector) {
1677 wterm_chr(xchr(s)); wlog_chr(xchr(s));
1678 incr(mp->term_offset); incr(mp->file_offset);
1679 if ( mp->term_offset==(unsigned)mp->max_print_line ) {
1680 wterm_cr; mp->term_offset=0;
1682 if ( mp->file_offset==(unsigned)mp->max_print_line ) {
1683 wlog_cr; mp->file_offset=0;
1687 wlog_chr(xchr(s)); incr(mp->file_offset);
1688 if ( mp->file_offset==(unsigned)mp->max_print_line ) mp_print_ln(mp);
1691 wterm_chr(xchr(s)); incr(mp->term_offset);
1692 if ( mp->term_offset==(unsigned)mp->max_print_line ) mp_print_ln(mp);
1697 if ( mp->tally<mp->trick_count )
1698 mp->trick_buf[mp->tally % mp->error_line]=s;
1701 if ( mp->pool_ptr>=mp->max_pool_ptr ) {
1702 mp_unit_str_room(mp);
1703 if ( mp->pool_ptr>=mp->pool_size )
1704 goto DONE; /* drop characters if string space is full */
1709 { char ss[2]; ss[0] = xchr(s); ss[1]=0;
1710 do_fprintf(mp->wr_file[(mp->selector-write_file)],(char *)ss);
1717 @ The |print_char| procedure sends one character to the desired destination.
1718 File names and string expressions might contain |ASCII_code| values that
1719 can't be printed using |print_visible_char|. These characters will be
1720 printed in three- or four-symbol form like `\.{\^\^A}' or `\.{\^\^e4}'.
1721 (This procedure assumes that it is safe to bypass all checks for unprintable
1722 characters when |selector| is in the range |0..max_write_files-1|.
1723 The user might want to write unprintable characters.
1725 @<Basic printing...@>=
1726 void mp_print_char (MP mp, ASCII_code k) { /* prints a single character */
1727 if ( mp->selector<pseudo || mp->selector>=write_file) {
1728 mp_print_visible_char(mp, k);
1729 } else if ( @<Character |k| cannot be printed@> ) {
1732 mp_print_visible_char(mp, k+0100);
1733 } else if ( k<0200 ) {
1734 mp_print_visible_char(mp, k-0100);
1736 int l; /* small index or counter */
1738 mp_print_visible_char(mp, (l<10 ? l+'0' : l-10+'a'));
1740 mp_print_visible_char(mp, (l<10 ? l+'0' : l-10+'a'));
1743 mp_print_visible_char(mp, k);
1747 @ An entire string is output by calling |print|. Note that if we are outputting
1748 the single standard ASCII character \.c, we could call |print("c")|, since
1749 |"c"=99| is the number of a single-character string, as explained above. But
1750 |print_char("c")| is quicker, so \MP\ goes directly to the |print_char|
1751 routine when it knows that this is safe. (The present implementation
1752 assumes that it is always safe to print a visible ASCII character.)
1753 @^system dependencies@>
1756 void mp_do_print (MP mp, const char *ss, unsigned int len) { /* prints string |s| */
1759 mp_print_char(mp, ss[j]); incr(j);
1765 void mp_print (MP mp, const char *ss) {
1766 if (ss==NULL) return;
1767 mp_do_print(mp, ss, strlen(ss));
1769 void mp_print_str (MP mp, str_number s) {
1770 pool_pointer j; /* current character code position */
1771 if ( (s<0)||(s>mp->max_str_ptr) ) {
1772 mp_do_print(mp,"???",3); /* this can't happen */
1776 mp_do_print(mp, (char *)(mp->str_pool+j), (str_stop(s)-j));
1780 @ Here is the very first thing that \MP\ prints: a headline that identifies
1781 the version number and base name. The |term_offset| variable is temporarily
1782 incorrect, but the discrepancy is not serious since we assume that the banner
1783 and mem identifier together will occupy at most |max_print_line|
1784 character positions.
1786 @<Initialize the output...@>=
1788 if (mp->mem_ident!=NULL)
1789 mp_print(mp,mp->mem_ident);
1793 @ The procedure |print_nl| is like |print|, but it makes sure that the
1794 string appears at the beginning of a new line.
1797 void mp_print_nl (MP mp, const char *s) { /* prints string |s| at beginning of line */
1798 switch(mp->selector) {
1800 if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_ln(mp);
1803 if ( mp->file_offset>0 ) mp_print_ln(mp);
1806 if ( mp->term_offset>0 ) mp_print_ln(mp);
1812 } /* there are no other cases */
1816 @ The following procedure, which prints out the decimal representation of a
1817 given integer |n|, assumes that all integers fit nicely into a |int|.
1818 @^system dependencies@>
1821 void mp_print_int (MP mp,integer n) { /* prints an integer in decimal form */
1823 mp_snprintf(s,12,"%d", (int)n);
1828 void mp_print_int (MP mp,integer n);
1830 @ \MP\ also makes use of a trivial procedure to print two digits. The
1831 following subroutine is usually called with a parameter in the range |0<=n<=99|.
1834 void mp_print_dd (MP mp,integer n) { /* prints two least significant digits */
1836 mp_print_char(mp, '0'+(n / 10));
1837 mp_print_char(mp, '0'+(n % 10));
1842 void mp_print_dd (MP mp,integer n);
1844 @ Here is a procedure that asks the user to type a line of input,
1845 assuming that the |selector| setting is either |term_only| or |term_and_log|.
1846 The input is placed into locations |first| through |last-1| of the
1847 |buffer| array, and echoed on the transcript file if appropriate.
1849 This procedure is never called when |interaction<mp_scroll_mode|.
1851 @d prompt_input(A) do {
1852 if (!mp->noninteractive) {
1853 wake_up_terminal; mp_print(mp, (A));
1856 } while (0) /* prints a string and gets a line of input */
1859 void mp_term_input (MP mp) { /* gets a line from the terminal */
1860 size_t k; /* index into |buffer| */
1861 if (mp->noninteractive) {
1862 if (!mp_input_ln(mp, mp->term_in ))
1863 longjmp(*(mp->jump_buf),1); /* chunk finished */
1864 mp->buffer[mp->last]='%';
1866 update_terminal; /* Now the user sees the prompt for sure */
1867 if (!mp_input_ln(mp, mp->term_in )) {
1868 mp_fatal_error(mp, "End of file on the terminal!");
1869 @.End of file on the terminal@>
1871 mp->term_offset=0; /* the user's line ended with \<\rm return> */
1872 decr(mp->selector); /* prepare to echo the input */
1873 if ( mp->last!=mp->first ) {
1874 for (k=mp->first;k<=mp->last-1;k++) {
1875 mp_print_char(mp, mp->buffer[k]);
1879 mp->buffer[mp->last]='%';
1880 incr(mp->selector); /* restore previous status */
1884 @* \[6] Reporting errors.
1885 When something anomalous is detected, \MP\ typically does something like this:
1886 $$\vbox{\halign{#\hfil\cr
1887 |print_err("Something anomalous has been detected");|\cr
1888 |help3("This is the first line of my offer to help.")|\cr
1889 |("This is the second line. I'm trying to")|\cr
1890 |("explain the best way for you to proceed.");|\cr
1892 A two-line help message would be given using |help2|, etc.; these informal
1893 helps should use simple vocabulary that complements the words used in the
1894 official error message that was printed. (Outside the U.S.A., the help
1895 messages should preferably be translated into the local vernacular. Each
1896 line of help is at most 60 characters long, in the present implementation,
1897 so that |max_print_line| will not be exceeded.)
1899 The |print_err| procedure supplies a `\.!' before the official message,
1900 and makes sure that the terminal is awake if a stop is going to occur.
1901 The |error| procedure supplies a `\..' after the official message, then it
1902 shows the location of the error; and if |interaction=error_stop_mode|,
1903 it also enters into a dialog with the user, during which time the help
1904 message may be printed.
1905 @^system dependencies@>
1907 @ The global variable |interaction| has four settings, representing increasing
1908 amounts of user interaction:
1911 enum mp_interaction_mode {
1912 mp_unspecified_mode=0, /* extra value for command-line switch */
1913 mp_batch_mode, /* omits all stops and omits terminal output */
1914 mp_nonstop_mode, /* omits all stops */
1915 mp_scroll_mode, /* omits error stops */
1916 mp_error_stop_mode /* stops at every opportunity to interact */
1919 @ @<Option variables@>=
1920 int interaction; /* current level of interaction */
1921 int noninteractive; /* do we have a terminal? */
1923 @ Set it here so it can be overwritten by the commandline
1925 @<Allocate or initialize ...@>=
1926 mp->interaction=opt->interaction;
1927 if (mp->interaction==mp_unspecified_mode || mp->interaction>mp_error_stop_mode)
1928 mp->interaction=mp_error_stop_mode;
1929 if (mp->interaction<mp_unspecified_mode)
1930 mp->interaction=mp_batch_mode;
1934 @d print_err(A) mp_print_err(mp,(A))
1937 void mp_print_err(MP mp, const char * A);
1940 void mp_print_err(MP mp, const char * A) {
1941 if ( mp->interaction==mp_error_stop_mode )
1943 mp_print_nl(mp, "! ");
1949 @ \MP\ is careful not to call |error| when the print |selector| setting
1950 might be unusual. The only possible values of |selector| at the time of
1953 \yskip\hang|no_print| (when |interaction=mp_batch_mode|
1954 and |log_file| not yet open);
1956 \hang|term_only| (when |interaction>mp_batch_mode| and |log_file| not yet open);
1958 \hang|log_only| (when |interaction=mp_batch_mode| and |log_file| is open);
1960 \hang|term_and_log| (when |interaction>mp_batch_mode| and |log_file| is open).
1962 @<Initialize the print |selector| based on |interaction|@>=
1963 if ( mp->interaction==mp_batch_mode ) mp->selector=no_print; else mp->selector=term_only
1965 @ A global variable |deletions_allowed| is set |false| if the |get_next|
1966 routine is active when |error| is called; this ensures that |get_next|
1967 will never be called recursively.
1970 The global variable |history| records the worst level of error that
1971 has been detected. It has four possible values: |spotless|, |warning_issued|,
1972 |error_message_issued|, and |fatal_error_stop|.
1974 Another global variable, |error_count|, is increased by one when an
1975 |error| occurs without an interactive dialog, and it is reset to zero at
1976 the end of every statement. If |error_count| reaches 100, \MP\ decides
1977 that there is no point in continuing further.
1980 enum mp_history_states {
1981 mp_spotless=0, /* |history| value when nothing has been amiss yet */
1982 mp_warning_issued, /* |history| value when |begin_diagnostic| has been called */
1983 mp_error_message_issued, /* |history| value when |error| has been called */
1984 mp_fatal_error_stop, /* |history| value when termination was premature */
1985 mp_system_error_stop /* |history| value when termination was due to disaster */
1989 boolean deletions_allowed; /* is it safe for |error| to call |get_next|? */
1990 int history; /* has the source input been clean so far? */
1991 int error_count; /* the number of scrolled errors since the last statement ended */
1993 @ The value of |history| is initially |fatal_error_stop|, but it will
1994 be changed to |spotless| if \MP\ survives the initialization process.
1996 @<Allocate or ...@>=
1997 mp->deletions_allowed=true; /* |history| is initialized elsewhere */
1999 @ Since errors can be detected almost anywhere in \MP, we want to declare the
2000 error procedures near the beginning of the program. But the error procedures
2001 in turn use some other procedures, which need to be declared |forward|
2002 before we get to |error| itself.
2004 It is possible for |error| to be called recursively if some error arises
2005 when |get_next| is being used to delete a token, and/or if some fatal error
2006 occurs while \MP\ is trying to fix a non-fatal one. But such recursion
2008 is never more than two levels deep.
2011 void mp_get_next (MP mp);
2012 void mp_term_input (MP mp);
2013 void mp_show_context (MP mp);
2014 void mp_begin_file_reading (MP mp);
2015 void mp_open_log_file (MP mp);
2016 void mp_clear_for_error_prompt (MP mp);
2017 @<Declare the procedure called |flush_string|@>
2020 void mp_normalize_selector (MP mp);
2022 @ Individual lines of help are recorded in the array |help_line|, which
2023 contains entries in positions |0..(help_ptr-1)|. They should be printed
2024 in reverse order, i.e., with |help_line[0]| appearing last.
2026 @d hlp1(A) mp->help_line[0]=(A); }
2027 @d hlp2(A) mp->help_line[1]=(A); hlp1
2028 @d hlp3(A) mp->help_line[2]=(A); hlp2
2029 @d hlp4(A) mp->help_line[3]=(A); hlp3
2030 @d hlp5(A) mp->help_line[4]=(A); hlp4
2031 @d hlp6(A) mp->help_line[5]=(A); hlp5
2032 @d help0 mp->help_ptr=0 /* sometimes there might be no help */
2033 @d help1 { mp->help_ptr=1; hlp1 /* use this with one help line */
2034 @d help2 { mp->help_ptr=2; hlp2 /* use this with two help lines */
2035 @d help3 { mp->help_ptr=3; hlp3 /* use this with three help lines */
2036 @d help4 { mp->help_ptr=4; hlp4 /* use this with four help lines */
2037 @d help5 { mp->help_ptr=5; hlp5 /* use this with five help lines */
2038 @d help6 { mp->help_ptr=6; hlp6 /* use this with six help lines */
2041 const char * help_line[6]; /* helps for the next |error| */
2042 unsigned int help_ptr; /* the number of help lines present */
2043 boolean use_err_help; /* should the |err_help| string be shown? */
2044 str_number err_help; /* a string set up by \&{errhelp} */
2045 str_number filename_template; /* a string set up by \&{filenametemplate} */
2047 @ @<Allocate or ...@>=
2048 mp->use_err_help=false;
2050 @ The |jump_out| procedure just cuts across all active procedure levels and
2051 goes to |end_of_MP|. This is the only nonlocal |goto| statement in the
2052 whole program. It is used when there is no recovery from a particular error.
2054 The program uses a |jump_buf| to handle this, this is initialized at three
2055 spots: the start of |mp_new|, the start of |mp_initialize|, and the start
2056 of |mp_run|. Those are the only library enty points.
2058 @^system dependencies@>
2063 @ @<Install and test the non-local jump buffer@>=
2064 mp->jump_buf = &buf;
2065 if (setjmp(*(mp->jump_buf)) != 0) { return mp->history; }
2067 @ @<Setup the non-local jump buffer in |mp_new|@>=
2068 if (setjmp(buf) != 0) { return NULL; }
2071 @ If the array of internals is still |NULL| when |jump_out| is called, a
2072 crash occured during initialization, and it is not safe to run the normal
2076 void mp_jump_out (MP mp) {
2077 if (mp->internal!=NULL && mp->history < mp_system_error_stop)
2078 mp_close_files_and_terminate(mp);
2079 longjmp(*(mp->jump_buf),1);
2082 @ Here now is the general |error| routine.
2085 void mp_error (MP mp) { /* completes the job of error reporting */
2086 ASCII_code c; /* what the user types */
2087 integer s1,s2,s3; /* used to save global variables when deleting tokens */
2088 pool_pointer j; /* character position being printed */
2089 if ( mp->history<mp_error_message_issued )
2090 mp->history=mp_error_message_issued;
2091 mp_print_char(mp, '.'); mp_show_context(mp);
2092 if ((!mp->noninteractive) && (mp->interaction==mp_error_stop_mode )) {
2093 @<Get user's advice and |return|@>;
2095 incr(mp->error_count);
2096 if ( mp->error_count==100 ) {
2097 mp_print_nl(mp,"(That makes 100 errors; please try again.)");
2098 @.That makes 100 errors...@>
2099 mp->history=mp_fatal_error_stop; mp_jump_out(mp);
2101 @<Put help message on the transcript file@>;
2103 void mp_warn (MP mp, const char *msg) {
2104 int saved_selector = mp->selector;
2105 mp_normalize_selector(mp);
2106 mp_print_nl(mp,"Warning: ");
2109 mp->selector = saved_selector;
2112 @ @<Exported function ...@>=
2113 void mp_error (MP mp);
2114 void mp_warn (MP mp, const char *msg);
2117 @ @<Get user's advice...@>=
2120 mp_clear_for_error_prompt(mp); prompt_input("? ");
2122 if ( mp->last==mp->first ) return;
2123 c=mp->buffer[mp->first];
2124 if ( c>='a' ) c=c+'A'-'a'; /* convert to uppercase */
2125 @<Interpret code |c| and |return| if done@>;
2128 @ It is desirable to provide an `\.E' option here that gives the user
2129 an easy way to return from \MP\ to the system editor, with the offending
2130 line ready to be edited. But such an extension requires some system
2131 wizardry, so the present implementation simply types out the name of the
2133 edited and the relevant line number.
2134 @^system dependencies@>
2137 typedef void (*mp_run_editor_command)(MP, char *, int);
2139 @ @<Option variables@>=
2140 mp_run_editor_command run_editor;
2142 @ @<Allocate or initialize ...@>=
2143 set_callback_option(run_editor);
2146 void mp_run_editor (MP mp, char *fname, int fline);
2148 @ @c void mp_run_editor (MP mp, char *fname, int fline) {
2149 mp_print_nl(mp, "You want to edit file ");
2150 @.You want to edit file x@>
2151 mp_print(mp, fname);
2152 mp_print(mp, " at line ");
2153 mp_print_int(mp, fline);
2154 mp->interaction=mp_scroll_mode;
2159 There is a secret `\.D' option available when the debugging routines haven't
2163 @<Interpret code |c| and |return| if done@>=
2165 case '0': case '1': case '2': case '3': case '4':
2166 case '5': case '6': case '7': case '8': case '9':
2167 if ( mp->deletions_allowed ) {
2168 @<Delete |c-"0"| tokens and |continue|@>;
2172 if ( mp->file_ptr>0 ){
2173 (mp->run_editor)(mp,
2174 str(mp->input_stack[mp->file_ptr].name_field),
2179 @<Print the help information and |continue|@>;
2182 @<Introduce new material from the terminal and |return|@>;
2184 case 'Q': case 'R': case 'S':
2185 @<Change the interaction level and |return|@>;
2188 mp->interaction=mp_scroll_mode; mp_jump_out(mp);
2193 @<Print the menu of available options@>
2195 @ @<Print the menu...@>=
2197 mp_print(mp, "Type <return> to proceed, S to scroll future error messages,");
2198 @.Type <return> to proceed...@>
2199 mp_print_nl(mp, "R to run without stopping, Q to run quietly,");
2200 mp_print_nl(mp, "I to insert something, ");
2201 if ( mp->file_ptr>0 )
2202 mp_print(mp, "E to edit your file,");
2203 if ( mp->deletions_allowed )
2204 mp_print_nl(mp, "1 or ... or 9 to ignore the next 1 to 9 tokens of input,");
2205 mp_print_nl(mp, "H for help, X to quit.");
2208 @ Here the author of \MP\ apologizes for making use of the numerical
2209 relation between |"Q"|, |"R"|, |"S"|, and the desired interaction settings
2210 |mp_batch_mode|, |mp_nonstop_mode|, |mp_scroll_mode|.
2211 @^Knuth, Donald Ervin@>
2213 @<Change the interaction...@>=
2215 mp->error_count=0; mp->interaction=mp_batch_mode+c-'Q';
2216 mp_print(mp, "OK, entering ");
2218 case 'Q': mp_print(mp, "batchmode"); decr(mp->selector); break;
2219 case 'R': mp_print(mp, "nonstopmode"); break;
2220 case 'S': mp_print(mp, "scrollmode"); break;
2221 } /* there are no other cases */
2222 mp_print(mp, "..."); mp_print_ln(mp); update_terminal; return;
2225 @ When the following code is executed, |buffer[(first+1)..(last-1)]| may
2226 contain the material inserted by the user; otherwise another prompt will
2227 be given. In order to understand this part of the program fully, you need
2228 to be familiar with \MP's input stacks.
2230 @<Introduce new material...@>=
2232 mp_begin_file_reading(mp); /* enter a new syntactic level for terminal input */
2233 if ( mp->last>mp->first+1 ) {
2234 loc=mp->first+1; mp->buffer[mp->first]=' ';
2236 prompt_input("insert>"); loc=mp->first;
2239 mp->first=mp->last+1; mp->cur_input.limit_field=mp->last; return;
2242 @ We allow deletion of up to 99 tokens at a time.
2244 @<Delete |c-"0"| tokens...@>=
2246 s1=mp->cur_cmd; s2=mp->cur_mod; s3=mp->cur_sym; mp->OK_to_interrupt=false;
2247 if ( (mp->last>mp->first+1) && (mp->buffer[mp->first+1]>='0')&&(mp->buffer[mp->first+1]<='9') )
2248 c=c*10+mp->buffer[mp->first+1]-'0'*11;
2252 mp_get_next(mp); /* one-level recursive call of |error| is possible */
2253 @<Decrease the string reference count, if the current token is a string@>;
2256 mp->cur_cmd=s1; mp->cur_mod=s2; mp->cur_sym=s3; mp->OK_to_interrupt=true;
2257 help2("I have just deleted some text, as you asked.")
2258 ("You can now delete more, or insert, or whatever.");
2259 mp_show_context(mp);
2263 @ @<Print the help info...@>=
2265 if ( mp->use_err_help ) {
2266 @<Print the string |err_help|, possibly on several lines@>;
2267 mp->use_err_help=false;
2269 if ( mp->help_ptr==0 ) {
2270 help2("Sorry, I don't know how to help in this situation.")
2271 ("Maybe you should try asking a human?");
2274 decr(mp->help_ptr); mp_print(mp, mp->help_line[mp->help_ptr]); mp_print_ln(mp);
2275 } while (mp->help_ptr!=0);
2277 help4("Sorry, I already gave what help I could...")
2278 ("Maybe you should try asking a human?")
2279 ("An error might have occurred before I noticed any problems.")
2280 ("``If all else fails, read the instructions.''");
2284 @ @<Print the string |err_help|, possibly on several lines@>=
2285 j=mp->str_start[mp->err_help];
2286 while ( j<str_stop(mp->err_help) ) {
2287 if ( mp->str_pool[j]!='%' ) mp_print_str(mp, mp->str_pool[j]);
2288 else if ( j+1==str_stop(mp->err_help) ) mp_print_ln(mp);
2289 else if ( mp->str_pool[j+1]!='%' ) mp_print_ln(mp);
2290 else { incr(j); mp_print_char(mp, '%'); };
2294 @ @<Put help message on the transcript file@>=
2295 if ( mp->interaction>mp_batch_mode ) decr(mp->selector); /* avoid terminal output */
2296 if ( mp->use_err_help ) {
2297 mp_print_nl(mp, "");
2298 @<Print the string |err_help|, possibly on several lines@>;
2300 while ( mp->help_ptr>0 ){
2301 decr(mp->help_ptr); mp_print_nl(mp, mp->help_line[mp->help_ptr]);
2305 if ( mp->interaction>mp_batch_mode ) incr(mp->selector); /* re-enable terminal output */
2308 @ In anomalous cases, the print selector might be in an unknown state;
2309 the following subroutine is called to fix things just enough to keep
2310 running a bit longer.
2313 void mp_normalize_selector (MP mp) {
2314 if ( mp->log_opened ) mp->selector=term_and_log;
2315 else mp->selector=term_only;
2316 if ( mp->job_name==NULL) mp_open_log_file(mp);
2317 if ( mp->interaction==mp_batch_mode ) decr(mp->selector);
2320 @ The following procedure prints \MP's last words before dying.
2322 @d succumb { if ( mp->interaction==mp_error_stop_mode )
2323 mp->interaction=mp_scroll_mode; /* no more interaction */
2324 if ( mp->log_opened ) mp_error(mp);
2325 mp->history=mp_fatal_error_stop; mp_jump_out(mp); /* irrecoverable error */
2329 void mp_fatal_error (MP mp, const char *s) { /* prints |s|, and that's it */
2330 mp_normalize_selector(mp);
2331 print_err("Emergency stop"); help1(s); succumb;
2335 @ @<Exported function ...@>=
2336 void mp_fatal_error (MP mp, const char *s);
2339 @ Here is the most dreaded error message.
2342 void mp_overflow (MP mp, const char *s, integer n) { /* stop due to finiteness */
2344 mp_normalize_selector(mp);
2345 mp_snprintf(msg, 256, "MetaPost capacity exceeded, sorry [%s=%d]",s,(int)n);
2346 @.MetaPost capacity exceeded ...@>
2348 help2("If you really absolutely need more capacity,")
2349 ("you can ask a wizard to enlarge me.");
2353 @ @<Internal library declarations@>=
2354 void mp_overflow (MP mp, const char *s, integer n);
2356 @ The program might sometime run completely amok, at which point there is
2357 no choice but to stop. If no previous error has been detected, that's bad
2358 news; a message is printed that is really intended for the \MP\
2359 maintenance person instead of the user (unless the user has been
2360 particularly diabolical). The index entries for `this can't happen' may
2361 help to pinpoint the problem.
2364 @<Internal library ...@>=
2365 void mp_confusion (MP mp, const char *s);
2367 @ Consistency check violated; |s| tells where.
2369 void mp_confusion (MP mp, const char *s) {
2371 mp_normalize_selector(mp);
2372 if ( mp->history<mp_error_message_issued ) {
2373 mp_snprintf(msg, 256, "This can't happen (%s)",s);
2374 @.This can't happen@>
2376 help1("I'm broken. Please show this to someone who can fix can fix");
2378 print_err("I can\'t go on meeting you like this");
2379 @.I can't go on...@>
2380 help2("One of your faux pas seems to have wounded me deeply...")
2381 ("in fact, I'm barely conscious. Please fix it and try again.");
2386 @ Users occasionally want to interrupt \MP\ while it's running.
2387 If the runtime system allows this, one can implement
2388 a routine that sets the global variable |interrupt| to some nonzero value
2389 when such an interrupt is signaled. Otherwise there is probably at least
2390 a way to make |interrupt| nonzero using the C debugger.
2391 @^system dependencies@>
2394 @d check_interrupt { if ( mp->interrupt!=0 )
2395 mp_pause_for_instructions(mp); }
2398 integer interrupt; /* should \MP\ pause for instructions? */
2399 boolean OK_to_interrupt; /* should interrupts be observed? */
2400 integer run_state; /* are we processing input ?*/
2401 boolean finished; /* set true by |close_files_and_terminate| */
2403 @ @<Allocate or ...@>=
2404 mp->OK_to_interrupt=true;
2407 @ When an interrupt has been detected, the program goes into its
2408 highest interaction level and lets the user have the full flexibility of
2409 the |error| routine. \MP\ checks for interrupts only at times when it is
2413 void mp_pause_for_instructions (MP mp) {
2414 if ( mp->OK_to_interrupt ) {
2415 mp->interaction=mp_error_stop_mode;
2416 if ( (mp->selector==log_only)||(mp->selector==no_print) )
2418 print_err("Interruption");
2421 ("Try to insert some instructions for me (e.g.,`I show x'),")
2422 ("unless you just want to quit by typing `X'.");
2423 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
2428 @ Many of \MP's error messages state that a missing token has been
2429 inserted behind the scenes. We can save string space and program space
2430 by putting this common code into a subroutine.
2433 void mp_missing_err (MP mp, const char *s) {
2435 mp_snprintf(msg, 256, "Missing `%s' has been inserted", s);
2436 @.Missing...inserted@>
2440 @* \[7] Arithmetic with scaled numbers.
2441 The principal computations performed by \MP\ are done entirely in terms of
2442 integers less than $2^{31}$ in magnitude; thus, the arithmetic specified in this
2443 program can be carried out in exactly the same way on a wide variety of
2444 computers, including some small ones.
2447 But C does not rigidly define the |/| operation in the case of negative
2448 dividends; for example, the result of |(-2*n-1) / 2| is |-(n+1)| on some
2449 computers and |-n| on others (is this true ?). There are two principal
2450 types of arithmetic: ``translation-preserving,'' in which the identity
2451 |(a+q*b)/b=(a/b)+q| is valid; and ``negation-preserving,'' in which
2452 |(-a)/b=-(a/b)|. This leads to two \MP s, which can produce
2453 different results, although the differences should be negligible when the
2454 language is being used properly. The \TeX\ processor has been defined
2455 carefully so that both varieties of arithmetic will produce identical
2456 output, but it would be too inefficient to constrain \MP\ in a similar way.
2458 @d el_gordo 0x7fffffff /* $2^{31}-1$, the largest value that \MP\ likes */
2461 @ One of \MP's most common operations is the calculation of
2462 $\lfloor{a+b\over2}\rfloor$,
2463 the midpoint of two given integers |a| and~|b|. The most decent way to do
2464 this is to write `|(a+b)/2|'; but on many machines it is more efficient
2465 to calculate `|(a+b)>>1|'.
2467 Therefore the midpoint operation will always be denoted by `|half(a+b)|'
2468 in this program. If \MP\ is being implemented with languages that permit
2469 binary shifting, the |half| macro should be changed to make this operation
2470 as efficient as possible. Since some systems have shift operators that can
2471 only be trusted to work on positive numbers, there is also a macro |halfp|
2472 that is used only when the quantity being halved is known to be positive
2475 @d half(A) ((A) / 2)
2476 @d halfp(A) ((A) >> 1)
2478 @ A single computation might use several subroutine calls, and it is
2479 desirable to avoid producing multiple error messages in case of arithmetic
2480 overflow. So the routines below set the global variable |arith_error| to |true|
2481 instead of reporting errors directly to the user.
2482 @^overflow in arithmetic@>
2485 boolean arith_error; /* has arithmetic overflow occurred recently? */
2487 @ @<Allocate or ...@>=
2488 mp->arith_error=false;
2490 @ At crucial points the program will say |check_arith|, to test if
2491 an arithmetic error has been detected.
2493 @d check_arith { if ( mp->arith_error ) mp_clear_arith(mp); }
2496 void mp_clear_arith (MP mp) {
2497 print_err("Arithmetic overflow");
2498 @.Arithmetic overflow@>
2499 help4("Uh, oh. A little while ago one of the quantities that I was")
2500 ("computing got too large, so I'm afraid your answers will be")
2501 ("somewhat askew. You'll probably have to adopt different")
2502 ("tactics next time. But I shall try to carry on anyway.");
2504 mp->arith_error=false;
2507 @ Addition is not always checked to make sure that it doesn't overflow,
2508 but in places where overflow isn't too unlikely the |slow_add| routine
2511 @c integer mp_slow_add (MP mp,integer x, integer y) {
2513 if ( y<=el_gordo-x ) {
2516 mp->arith_error=true;
2519 } else if ( -y<=el_gordo+x ) {
2522 mp->arith_error=true;
2527 @ Fixed-point arithmetic is done on {\sl scaled integers\/} that are multiples
2528 of $2^{-16}$. In other words, a binary point is assumed to be sixteen bit
2529 positions from the right end of a binary computer word.
2531 @d quarter_unit 040000 /* $2^{14}$, represents 0.250000 */
2532 @d half_unit 0100000 /* $2^{15}$, represents 0.50000 */
2533 @d three_quarter_unit 0140000 /* $3\cdot2^{14}$, represents 0.75000 */
2534 @d unity 0200000 /* $2^{16}$, represents 1.00000 */
2535 @d two 0400000 /* $2^{17}$, represents 2.00000 */
2536 @d three 0600000 /* $2^{17}+2^{16}$, represents 3.00000 */
2539 typedef integer scaled; /* this type is used for scaled integers */
2540 typedef unsigned char small_number; /* this type is self-explanatory */
2542 @ The following function is used to create a scaled integer from a given decimal
2543 fraction $(.d_0d_1\ldots d_{k-1})$, where |0<=k<=17|. The digit $d_i$ is
2544 given in |dig[i]|, and the calculation produces a correctly rounded result.
2547 scaled mp_round_decimals (MP mp,small_number k) {
2548 /* converts a decimal fraction */
2549 integer a = 0; /* the accumulator */
2551 a=(a+mp->dig[k]*two) / 10;
2556 @ Conversely, here is a procedure analogous to |print_int|. If the output
2557 of this procedure is subsequently read by \MP\ and converted by the
2558 |round_decimals| routine above, it turns out that the original value will
2559 be reproduced exactly. A decimal point is printed only if the value is
2560 not an integer. If there is more than one way to print the result with
2561 the optimum number of digits following the decimal point, the closest
2562 possible value is given.
2564 The invariant relation in the \&{repeat} loop is that a sequence of
2565 decimal digits yet to be printed will yield the original number if and only if
2566 they form a fraction~$f$ in the range $s-\delta\L10\cdot2^{16}f<s$.
2567 We can stop if and only if $f=0$ satisfies this condition; the loop will
2568 terminate before $s$ can possibly become zero.
2570 @<Basic printing...@>=
2571 void mp_print_scaled (MP mp,scaled s) { /* prints scaled real, rounded to five digits */
2572 scaled delta; /* amount of allowable inaccuracy */
2574 mp_print_char(mp, '-');
2575 negate(s); /* print the sign, if negative */
2577 mp_print_int(mp, s / unity); /* print the integer part */
2581 mp_print_char(mp, '.');
2584 s=s+0100000-(delta / 2); /* round the final digit */
2585 mp_print_char(mp, '0'+(s / unity));
2592 @ We often want to print two scaled quantities in parentheses,
2593 separated by a comma.
2595 @<Basic printing...@>=
2596 void mp_print_two (MP mp,scaled x, scaled y) { /* prints `|(x,y)|' */
2597 mp_print_char(mp, '(');
2598 mp_print_scaled(mp, x);
2599 mp_print_char(mp, ',');
2600 mp_print_scaled(mp, y);
2601 mp_print_char(mp, ')');
2604 @ The |scaled| quantities in \MP\ programs are generally supposed to be
2605 less than $2^{12}$ in absolute value, so \MP\ does much of its internal
2606 arithmetic with 28~significant bits of precision. A |fraction| denotes
2607 a scaled integer whose binary point is assumed to be 28 bit positions
2610 @d fraction_half 01000000000 /* $2^{27}$, represents 0.50000000 */
2611 @d fraction_one 02000000000 /* $2^{28}$, represents 1.00000000 */
2612 @d fraction_two 04000000000 /* $2^{29}$, represents 2.00000000 */
2613 @d fraction_three 06000000000 /* $3\cdot2^{28}$, represents 3.00000000 */
2614 @d fraction_four 010000000000 /* $2^{30}$, represents 4.00000000 */
2617 typedef integer fraction; /* this type is used for scaled fractions */
2619 @ In fact, the two sorts of scaling discussed above aren't quite
2620 sufficient; \MP\ has yet another, used internally to keep track of angles
2621 in units of $2^{-20}$ degrees.
2623 @d forty_five_deg 0264000000 /* $45\cdot2^{20}$, represents $45^\circ$ */
2624 @d ninety_deg 0550000000 /* $90\cdot2^{20}$, represents $90^\circ$ */
2625 @d one_eighty_deg 01320000000 /* $180\cdot2^{20}$, represents $180^\circ$ */
2626 @d three_sixty_deg 02640000000 /* $360\cdot2^{20}$, represents $360^\circ$ */
2629 typedef integer angle; /* this type is used for scaled angles */
2631 @ The |make_fraction| routine produces the |fraction| equivalent of
2632 |p/q|, given integers |p| and~|q|; it computes the integer
2633 $f=\lfloor2^{28}p/q+{1\over2}\rfloor$, when $p$ and $q$ are
2634 positive. If |p| and |q| are both of the same scaled type |t|,
2635 the ``type relation'' |make_fraction(t,t)=fraction| is valid;
2636 and it's also possible to use the subroutine ``backwards,'' using
2637 the relation |make_fraction(t,fraction)=t| between scaled types.
2639 If the result would have magnitude $2^{31}$ or more, |make_fraction|
2640 sets |arith_error:=true|. Most of \MP's internal computations have
2641 been designed to avoid this sort of error.
2643 If this subroutine were programmed in assembly language on a typical
2644 machine, we could simply compute |(@t$2^{28}$@>*p)div q|, since a
2645 double-precision product can often be input to a fixed-point division
2646 instruction. But when we are restricted to int-eger arithmetic it
2647 is necessary either to resort to multiple-precision maneuvering
2648 or to use a simple but slow iteration. The multiple-precision technique
2649 would be about three times faster than the code adopted here, but it
2650 would be comparatively long and tricky, involving about sixteen
2651 additional multiplications and divisions.
2653 This operation is part of \MP's ``inner loop''; indeed, it will
2654 consume nearly 10\pct! of the running time (exclusive of input and output)
2655 if the code below is left unchanged. A machine-dependent recoding
2656 will therefore make \MP\ run faster. The present implementation
2657 is highly portable, but slow; it avoids multiplication and division
2658 except in the initial stage. System wizards should be careful to
2659 replace it with a routine that is guaranteed to produce identical
2660 results in all cases.
2661 @^system dependencies@>
2663 As noted below, a few more routines should also be replaced by machine-dependent
2664 code, for efficiency. But when a procedure is not part of the ``inner loop,''
2665 such changes aren't advisable; simplicity and robustness are
2666 preferable to trickery, unless the cost is too high.
2670 fraction mp_make_fraction (MP mp,integer p, integer q);
2671 integer mp_take_scaled (MP mp,integer q, scaled f) ;
2673 @ If FIXPT is not defined, we need these preprocessor values
2675 @d TWEXP31 2147483648.0
2676 @d TWEXP28 268435456.0
2678 @d TWEXP_16 (1.0/65536.0)
2679 @d TWEXP_28 (1.0/268435456.0)
2683 fraction mp_make_fraction (MP mp,integer p, integer q) {
2685 if ( q==0 ) mp_confusion(mp, "/");
2686 @:this can't happen /}{\quad \./@>
2689 integer f; /* the fraction bits, with a leading 1 bit */
2690 integer n; /* the integer part of $\vert p/q\vert$ */
2691 boolean negative = false; /* should the result be negated? */
2693 negate(p); negative=true;
2696 negate(q); negative = ! negative;
2700 mp->arith_error=true;
2701 i= ( negative ? -el_gordo : el_gordo);
2703 n=(n-1)*fraction_one;
2704 @<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>;
2705 i = (negative ? (-(f+n)) : (f+n));
2711 d = TWEXP28 * (double)p /(double)q;
2714 if (d>=TWEXP31) {mp->arith_error=true; return el_gordo;}
2716 if (d==i && ( ((q>0 ? -q : q)&077777)
2717 * (((i&037777)<<1)-1) & 04000)!=0) --i;
2720 if (d<= -TWEXP31) {mp->arith_error=true; return -el_gordo;}
2722 if (d==i && ( ((q>0 ? q : -q)&077777)
2723 * (((i&037777)<<1)+1) & 04000)!=0) ++i;
2730 @ The |repeat| loop here preserves the following invariant relations
2731 between |f|, |p|, and~|q|:
2732 (i)~|0<=p<q|; (ii)~$fq+p=2^k(q+p_0)$, where $k$ is an integer and
2733 $p_0$ is the original value of~$p$.
2735 Notice that the computation specifies
2736 |(p-q)+p| instead of |(p+p)-q|, because the latter could overflow.
2737 Let us hope that optimizing compilers do not miss this point; a
2738 special variable |be_careful| is used to emphasize the necessary
2739 order of computation. Optimizing compilers should keep |be_careful|
2740 in a register, not store it in memory.
2743 @<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>=
2745 integer be_careful; /* disables certain compiler optimizations */
2748 be_careful=p-q; p=be_careful+p;
2754 } while (f<fraction_one);
2756 if ( be_careful+p>=0 ) incr(f);
2759 @ The dual of |make_fraction| is |take_fraction|, which multiplies a
2760 given integer~|q| by a fraction~|f|. When the operands are positive, it
2761 computes $p=\lfloor qf/2^{28}+{1\over2}\rfloor$, a symmetric function
2764 This routine is even more ``inner loopy'' than |make_fraction|;
2765 the present implementation consumes almost 20\pct! of \MP's computation
2766 time during typical jobs, so a machine-language substitute is advisable.
2767 @^inner loop@> @^system dependencies@>
2770 integer mp_take_fraction (MP mp,integer q, fraction f) ;
2774 integer mp_take_fraction (MP mp,integer q, fraction f) {
2775 integer p; /* the fraction so far */
2776 boolean negative; /* should the result be negated? */
2777 integer n; /* additional multiple of $q$ */
2778 integer be_careful; /* disables certain compiler optimizations */
2779 @<Reduce to the case that |f>=0| and |q>=0|@>;
2780 if ( f<fraction_one ) {
2783 n=f / fraction_one; f=f % fraction_one;
2784 if ( q<=el_gordo / n ) {
2787 mp->arith_error=true; n=el_gordo;
2791 @<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>;
2792 be_careful=n-el_gordo;
2793 if ( be_careful+p>0 ){
2794 mp->arith_error=true; n=el_gordo-p;
2801 integer mp_take_fraction (MP mp,integer p, fraction q) {
2804 d = (double)p * (double)q * TWEXP_28;
2808 if (d!=TWEXP31 || (((p&077777)*(q&077777))&040000)==0)
2809 mp->arith_error = true;
2813 if (d==i && (((p&077777)*(q&077777))&040000)!=0) --i;
2817 if (d!= -TWEXP31 || ((-(p&077777)*(q&077777))&040000)==0)
2818 mp->arith_error = true;
2822 if (d==i && ((-(p&077777)*(q&077777))&040000)!=0) ++i;
2828 @ @<Reduce to the case that |f>=0| and |q>=0|@>=
2832 negate( f); negative=true;
2835 negate(q); negative=! negative;
2838 @ The invariant relations in this case are (i)~$\lfloor(qf+p)/2^k\rfloor
2839 =\lfloor qf_0/2^{28}+{1\over2}\rfloor$, where $k$ is an integer and
2840 $f_0$ is the original value of~$f$; (ii)~$2^k\L f<2^{k+1}$.
2843 @<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>=
2844 p=fraction_half; /* that's $2^{27}$; the invariants hold now with $k=28$ */
2845 if ( q<fraction_four ) {
2847 if ( odd(f) ) p=halfp(p+q); else p=halfp(p);
2852 if ( odd(f) ) p=p+halfp(q-p); else p=halfp(p);
2858 @ When we want to multiply something by a |scaled| quantity, we use a scheme
2859 analogous to |take_fraction| but with a different scaling.
2860 Given positive operands, |take_scaled|
2861 computes the quantity $p=\lfloor qf/2^{16}+{1\over2}\rfloor$.
2863 Once again it is a good idea to use a machine-language replacement if
2864 possible; otherwise |take_scaled| will use more than 2\pct! of the running time
2865 when the Computer Modern fonts are being generated.
2870 integer mp_take_scaled (MP mp,integer q, scaled f) {
2871 integer p; /* the fraction so far */
2872 boolean negative; /* should the result be negated? */
2873 integer n; /* additional multiple of $q$ */
2874 integer be_careful; /* disables certain compiler optimizations */
2875 @<Reduce to the case that |f>=0| and |q>=0|@>;
2879 n=f / unity; f=f % unity;
2880 if ( q<=el_gordo / n ) {
2883 mp->arith_error=true; n=el_gordo;
2887 @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>;
2888 be_careful=n-el_gordo;
2889 if ( be_careful+p>0 ) {
2890 mp->arith_error=true; n=el_gordo-p;
2892 return ( negative ?(-(n+p)) :(n+p));
2894 integer mp_take_scaled (MP mp,integer p, scaled q) {
2897 d = (double)p * (double)q * TWEXP_16;
2901 if (d!=TWEXP31 || (((p&077777)*(q&077777))&040000)==0)
2902 mp->arith_error = true;
2906 if (d==i && (((p&077777)*(q&077777))&040000)!=0) --i;
2910 if (d!= -TWEXP31 || ((-(p&077777)*(q&077777))&040000)==0)
2911 mp->arith_error = true;
2915 if (d==i && ((-(p&077777)*(q&077777))&040000)!=0) ++i;
2921 @ @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>=
2922 p=half_unit; /* that's $2^{15}$; the invariants hold now with $k=16$ */
2924 if ( q<fraction_four ) {
2926 p = (odd(f) ? halfp(p+q) : halfp(p));
2931 p = (odd(f) ? p+halfp(q-p) : halfp(p));
2936 @ For completeness, there's also |make_scaled|, which computes a
2937 quotient as a |scaled| number instead of as a |fraction|.
2938 In other words, the result is $\lfloor2^{16}p/q+{1\over2}\rfloor$, if the
2939 operands are positive. \ (This procedure is not used especially often,
2940 so it is not part of \MP's inner loop.)
2942 @<Internal library ...@>=
2943 scaled mp_make_scaled (MP mp,integer p, integer q) ;
2946 scaled mp_make_scaled (MP mp,integer p, integer q) {
2948 if ( q==0 ) mp_confusion(mp, "/");
2949 @:this can't happen /}{\quad \./@>
2952 integer f; /* the fraction bits, with a leading 1 bit */
2953 integer n; /* the integer part of $\vert p/q\vert$ */
2954 boolean negative; /* should the result be negated? */
2955 integer be_careful; /* disables certain compiler optimizations */
2956 if ( p>=0 ) negative=false;
2957 else { negate(p); negative=true; };
2959 negate(q); negative=! negative;
2963 mp->arith_error=true;
2964 return (negative ? (-el_gordo) : el_gordo);
2967 @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>;
2968 i = (negative ? (-(f+n)) :(f+n));
2972 d = TWEXP16 * (double)p /(double)q;
2975 if (d>=TWEXP31) {mp->arith_error=true; return el_gordo;}
2977 if (d==i && ( ((q>0 ? -q : q)&077777)
2978 * (((i&037777)<<1)-1) & 04000)!=0) --i;
2981 if (d<= -TWEXP31) {mp->arith_error=true; return -el_gordo;}
2983 if (d==i && ( ((q>0 ? q : -q)&077777)
2984 * (((i&037777)<<1)+1) & 04000)!=0) ++i;
2991 @ @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>=
2994 be_careful=p-q; p=be_careful+p;
2995 if ( p>=0 ) f=f+f+1;
2996 else { f+=f; p=p+q; };
2999 if ( be_careful+p>=0 ) incr(f)
3001 @ Here is a typical example of how the routines above can be used.
3002 It computes the function
3003 $${1\over3\tau}f(\theta,\phi)=
3004 {\tau^{-1}\bigl(2+\sqrt2\,(\sin\theta-{1\over16}\sin\phi)
3005 (\sin\phi-{1\over16}\sin\theta)(\cos\theta-\cos\phi)\bigr)\over
3006 3\,\bigl(1+{1\over2}(\sqrt5-1)\cos\theta+{1\over2}(3-\sqrt5\,)\cos\phi\bigr)},$$
3007 where $\tau$ is a |scaled| ``tension'' parameter. This is \MP's magic
3008 fudge factor for placing the first control point of a curve that starts
3009 at an angle $\theta$ and ends at an angle $\phi$ from the straight path.
3010 (Actually, if the stated quantity exceeds 4, \MP\ reduces it to~4.)
3012 The trigonometric quantity to be multiplied by $\sqrt2$ is less than $\sqrt2$.
3013 (It's a sum of eight terms whose absolute values can be bounded using
3014 relations such as $\sin\theta\cos\theta\L{1\over2}$.) Thus the numerator
3015 is positive; and since the tension $\tau$ is constrained to be at least
3016 $3\over4$, the numerator is less than $16\over3$. The denominator is
3017 nonnegative and at most~6. Hence the fixed-point calculations below
3018 are guaranteed to stay within the bounds of a 32-bit computer word.
3020 The angles $\theta$ and $\phi$ are given implicitly in terms of |fraction|
3021 arguments |st|, |ct|, |sf|, and |cf|, representing $\sin\theta$, $\cos\theta$,
3022 $\sin\phi$, and $\cos\phi$, respectively.
3025 fraction mp_velocity (MP mp,fraction st, fraction ct, fraction sf,
3026 fraction cf, scaled t) {
3027 integer acc,num,denom; /* registers for intermediate calculations */
3028 acc=mp_take_fraction(mp, st-(sf / 16), sf-(st / 16));
3029 acc=mp_take_fraction(mp, acc,ct-cf);
3030 num=fraction_two+mp_take_fraction(mp, acc,379625062);
3031 /* $2^{28}\sqrt2\approx379625062.497$ */
3032 denom=fraction_three+mp_take_fraction(mp, ct,497706707)+mp_take_fraction(mp, cf,307599661);
3033 /* $3\cdot2^{27}\cdot(\sqrt5-1)\approx497706706.78$ and
3034 $3\cdot2^{27}\cdot(3-\sqrt5\,)\approx307599661.22$ */
3035 if ( t!=unity ) num=mp_make_scaled(mp, num,t);
3036 /* |make_scaled(fraction,scaled)=fraction| */
3037 if ( num / 4>=denom )
3038 return fraction_four;
3040 return mp_make_fraction(mp, num, denom);
3043 @ The following somewhat different subroutine tests rigorously if $ab$ is
3044 greater than, equal to, or less than~$cd$,
3045 given integers $(a,b,c,d)$. In most cases a quick decision is reached.
3046 The result is $+1$, 0, or~$-1$ in the three respective cases.
3048 @d mp_ab_vs_cd(M,A,B,C,D) mp_do_ab_vs_cd(A,B,C,D)
3051 integer mp_do_ab_vs_cd (integer a,integer b, integer c, integer d) {
3052 integer q,r; /* temporary registers */
3053 @<Reduce to the case that |a,c>=0|, |b,d>0|@>;
3055 q = a / d; r = c / b;
3057 return ( q>r ? 1 : -1);
3058 q = a % d; r = c % b;
3061 if ( q==0 ) return -1;
3063 } /* now |a>d>0| and |c>b>0| */
3066 @ @<Reduce to the case that |a...@>=
3067 if ( a<0 ) { negate(a); negate(b); };
3068 if ( c<0 ) { negate(c); negate(d); };
3071 if ( (a==0||b==0)&&(c==0||d==0) ) return 0;
3075 return ( a==0 ? 0 : -1);
3076 q=a; a=c; c=q; q=-b; b=-d; d=q;
3077 } else if ( b<=0 ) {
3078 if ( b<0 ) if ( a>0 ) return -1;
3079 return (c==0 ? 0 : -1);
3082 @ We conclude this set of elementary routines with some simple rounding
3083 and truncation operations.
3085 @<Internal library declarations@>=
3086 #define mp_floor_scaled(M,i) ((i)&(-65536))
3087 #define mp_round_unscaled(M,i) (((i>>15)+1)>>1)
3088 #define mp_round_fraction(M,i) (((i>>11)+1)>>1)
3091 @* \[8] Algebraic and transcendental functions.
3092 \MP\ computes all of the necessary special functions from scratch, without
3093 relying on |real| arithmetic or system subroutines for sines, cosines, etc.
3095 @ To get the square root of a |scaled| number |x|, we want to calculate
3096 $s=\lfloor 2^8\!\sqrt x +{1\over2}\rfloor$. If $x>0$, this is the unique
3097 integer such that $2^{16}x-s\L s^2<2^{16}x+s$. The following subroutine
3098 determines $s$ by an iterative method that maintains the invariant
3099 relations $x=2^{46-2k}x_0\bmod 2^{30}$, $0<y=\lfloor 2^{16-2k}x_0\rfloor
3100 -s^2+s\L q=2s$, where $x_0$ is the initial value of $x$. The value of~$y$
3101 might, however, be zero at the start of the first iteration.
3104 scaled mp_square_rt (MP mp,scaled x) ;
3107 scaled mp_square_rt (MP mp,scaled x) {
3108 small_number k; /* iteration control counter */
3109 integer y,q; /* registers for intermediate calculations */
3111 @<Handle square root of zero or negative argument@>;
3114 while ( x<fraction_two ) { /* i.e., |while x<@t$2^{29}$@>|\unskip */
3117 if ( x<fraction_four ) y=0;
3118 else { x=x-fraction_four; y=1; };
3120 @<Decrease |k| by 1, maintaining the invariant
3121 relations between |x|, |y|, and~|q|@>;
3127 @ @<Handle square root of zero...@>=
3130 print_err("Square root of ");
3131 @.Square root...replaced by 0@>
3132 mp_print_scaled(mp, x); mp_print(mp, " has been replaced by 0");
3133 help2("Since I don't take square roots of negative numbers,")
3134 ("I'm zeroing this one. Proceed, with fingers crossed.");
3140 @ @<Decrease |k| by 1, maintaining...@>=
3142 if ( x>=fraction_four ) { /* note that |fraction_four=@t$2^{30}$@>| */
3143 x=x-fraction_four; incr(y);
3145 x+=x; y=y+y-q; q+=q;
3146 if ( x>=fraction_four ) { x=x-fraction_four; incr(y); };
3147 if ( y>q ){ y=y-q; q=q+2; }
3148 else if ( y<=0 ) { q=q-2; y=y+q; };
3151 @ Pythagorean addition $\psqrt{a^2+b^2}$ is implemented by an elegant
3152 iterative scheme due to Cleve Moler and Donald Morrison [{\sl IBM Journal
3153 @^Moler, Cleve Barry@>
3154 @^Morrison, Donald Ross@>
3155 of Research and Development\/ \bf27} (1983), 577--581]. It modifies |a| and~|b|
3156 in such a way that their Pythagorean sum remains invariant, while the
3157 smaller argument decreases.
3159 @<Internal library ...@>=
3160 integer mp_pyth_add (MP mp,integer a, integer b);
3164 integer mp_pyth_add (MP mp,integer a, integer b) {
3165 fraction r; /* register used to transform |a| and |b| */
3166 boolean big; /* is the result dangerously near $2^{31}$? */
3168 if ( a<b ) { r=b; b=a; a=r; }; /* now |0<=b<=a| */
3170 if ( a<fraction_two ) {
3173 a=a / 4; b=b / 4; big=true;
3174 }; /* we reduced the precision to avoid arithmetic overflow */
3175 @<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>;
3177 if ( a<fraction_two ) {
3180 mp->arith_error=true; a=el_gordo;
3187 @ The key idea here is to reflect the vector $(a,b)$ about the
3188 line through $(a,b/2)$.
3190 @<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>=
3192 r=mp_make_fraction(mp, b,a);
3193 r=mp_take_fraction(mp, r,r); /* now $r\approx b^2/a^2$ */
3195 r=mp_make_fraction(mp, r,fraction_four+r);
3196 a=a+mp_take_fraction(mp, a+a,r); b=mp_take_fraction(mp, b,r);
3200 @ Here is a similar algorithm for $\psqrt{a^2-b^2}$.
3201 It converges slowly when $b$ is near $a$, but otherwise it works fine.
3204 integer mp_pyth_sub (MP mp,integer a, integer b) {
3205 fraction r; /* register used to transform |a| and |b| */
3206 boolean big; /* is the input dangerously near $2^{31}$? */
3209 @<Handle erroneous |pyth_sub| and set |a:=0|@>;
3211 if ( a<fraction_four ) {
3214 a=halfp(a); b=halfp(b); big=true;
3216 @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>;
3217 if ( big ) double(a);
3222 @ @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>=
3224 r=mp_make_fraction(mp, b,a);
3225 r=mp_take_fraction(mp, r,r); /* now $r\approx b^2/a^2$ */
3227 r=mp_make_fraction(mp, r,fraction_four-r);
3228 a=a-mp_take_fraction(mp, a+a,r); b=mp_take_fraction(mp, b,r);
3231 @ @<Handle erroneous |pyth_sub| and set |a:=0|@>=
3234 print_err("Pythagorean subtraction "); mp_print_scaled(mp, a);
3235 mp_print(mp, "+-+"); mp_print_scaled(mp, b);
3236 mp_print(mp, " has been replaced by 0");
3238 help2("Since I don't take square roots of negative numbers,")
3239 ("I'm zeroing this one. Proceed, with fingers crossed.");
3245 @ The subroutines for logarithm and exponential involve two tables.
3246 The first is simple: |two_to_the[k]| equals $2^k$. The second involves
3247 a bit more calculation, which the author claims to have done correctly:
3248 |spec_log[k]| is $2^{27}$ times $\ln\bigl(1/(1-2^{-k})\bigr)=
3249 2^{-k}+{1\over2}2^{-2k}+{1\over3}2^{-3k}+\cdots\,$, rounded to the
3252 @d two_to_the(A) (1<<(A))
3255 static const integer spec_log[29] = { 0, /* special logarithms */
3256 93032640, 38612034, 17922280, 8662214, 4261238, 2113709,
3257 1052693, 525315, 262400, 131136, 65552, 32772, 16385,
3258 8192, 4096, 2048, 1024, 512, 256, 128, 64, 32, 16, 8, 4, 2, 1, 1 };
3260 @ @<Local variables for initialization@>=
3261 integer k; /* all-purpose loop index */
3264 @ Here is the routine that calculates $2^8$ times the natural logarithm
3265 of a |scaled| quantity; it is an integer approximation to $2^{24}\ln(x/2^{16})$,
3266 when |x| is a given positive integer.
3268 The method is based on exercise 1.2.2--25 in {\sl The Art of Computer
3269 Programming\/}: During the main iteration we have $1\L 2^{-30}x<1/(1-2^{1-k})$,
3270 and the logarithm of $2^{30}x$ remains to be added to an accumulator
3271 register called~$y$. Three auxiliary bits of accuracy are retained in~$y$
3272 during the calculation, and sixteen auxiliary bits to extend |y| are
3273 kept in~|z| during the initial argument reduction. (We add
3274 $100\cdot2^{16}=6553600$ to~|z| and subtract 100 from~|y| so that |z| will
3275 not become negative; also, the actual amount subtracted from~|y| is~96,
3276 not~100, because we want to add~4 for rounding before the final division by~8.)
3279 scaled mp_m_log (MP mp,scaled x) {
3280 integer y,z; /* auxiliary registers */
3281 integer k; /* iteration counter */
3283 @<Handle non-positive logarithm@>;
3285 y=1302456956+4-100; /* $14\times2^{27}\ln2\approx1302456956.421063$ */
3286 z=27595+6553600; /* and $2^{16}\times .421063\approx 27595$ */
3287 while ( x<fraction_four ) {
3288 double(x); y-=93032639; z-=48782;
3289 } /* $2^{27}\ln2\approx 93032639.74436163$ and $2^{16}\times.74436163\approx 48782$ */
3290 y=y+(z / unity); k=2;
3291 while ( x>fraction_four+4 ) {
3292 @<Increase |k| until |x| can be multiplied by a
3293 factor of $2^{-k}$, and adjust $y$ accordingly@>;
3299 @ @<Increase |k| until |x| can...@>=
3301 z=((x-1) / two_to_the(k))+1; /* $z=\lceil x/2^k\rceil$ */
3302 while ( x<fraction_four+z ) { z=halfp(z+1); incr(k); };
3303 y+=spec_log[k]; x-=z;
3306 @ @<Handle non-positive logarithm@>=
3308 print_err("Logarithm of ");
3309 @.Logarithm...replaced by 0@>
3310 mp_print_scaled(mp, x); mp_print(mp, " has been replaced by 0");
3311 help2("Since I don't take logs of non-positive numbers,")
3312 ("I'm zeroing this one. Proceed, with fingers crossed.");
3317 @ Conversely, the exponential routine calculates $\exp(x/2^8)$,
3318 when |x| is |scaled|. The result is an integer approximation to
3319 $2^{16}\exp(x/2^{24})$, when |x| is regarded as an integer.
3322 scaled mp_m_exp (MP mp,scaled x) {
3323 small_number k; /* loop control index */
3324 integer y,z; /* auxiliary registers */
3325 if ( x>174436200 ) {
3326 /* $2^{24}\ln((2^{31}-1)/2^{16})\approx 174436199.51$ */
3327 mp->arith_error=true;
3329 } else if ( x<-197694359 ) {
3330 /* $2^{24}\ln(2^{-1}/2^{16})\approx-197694359.45$ */
3334 z=-8*x; y=04000000; /* $y=2^{20}$ */
3336 if ( x<=127919879 ) {
3338 /* $2^{27}\ln((2^{31}-1)/2^{20})\approx 1023359037.125$ */
3340 z=8*(174436200-x); /* |z| is always nonnegative */
3344 @<Multiply |y| by $\exp(-z/2^{27})$@>;
3346 return ((y+8) / 16);
3352 @ The idea here is that subtracting |spec_log[k]| from |z| corresponds
3353 to multiplying |y| by $1-2^{-k}$.
3355 A subtle point (which had to be checked) was that if $x=127919879$, the
3356 value of~|y| will decrease so that |y+8| doesn't overflow. In fact,
3357 $z$ will be 5 in this case, and |y| will decrease by~64 when |k=25|
3358 and by~16 when |k=27|.
3360 @<Multiply |y| by...@>=
3363 while ( z>=spec_log[k] ) {
3365 y=y-1-((y-two_to_the(k-1)) / two_to_the(k));
3370 @ The trigonometric subroutines use an auxiliary table such that
3371 |spec_atan[k]| contains an approximation to the |angle| whose tangent
3372 is~$1/2^k$. $\arctan2^{-k}$ times $2^{20}\cdot180/\pi$
3375 static const angle spec_atan[27] = { 0, 27855475, 14718068, 7471121, 3750058,
3376 1876857, 938658, 469357, 234682, 117342, 58671, 29335, 14668, 7334, 3667,
3377 1833, 917, 458, 229, 115, 57, 29, 14, 7, 4, 2, 1 };
3379 @ Given integers |x| and |y|, not both zero, the |n_arg| function
3380 returns the |angle| whose tangent points in the direction $(x,y)$.
3381 This subroutine first determines the correct octant, then solves the
3382 problem for |0<=y<=x|, then converts the result appropriately to
3383 return an answer in the range |-one_eighty_deg<=@t$\theta$@><=one_eighty_deg|.
3384 (The answer is |+one_eighty_deg| if |y=0| and |x<0|, but an answer of
3385 |-one_eighty_deg| is possible if, for example, |y=-1| and $x=-2^{30}$.)
3387 The octants are represented in a ``Gray code,'' since that turns out
3388 to be computationally simplest.
3394 @d second_octant (first_octant+switch_x_and_y)
3395 @d third_octant (first_octant+switch_x_and_y+negate_x)
3396 @d fourth_octant (first_octant+negate_x)
3397 @d fifth_octant (first_octant+negate_x+negate_y)
3398 @d sixth_octant (first_octant+switch_x_and_y+negate_x+negate_y)
3399 @d seventh_octant (first_octant+switch_x_and_y+negate_y)
3400 @d eighth_octant (first_octant+negate_y)
3403 angle mp_n_arg (MP mp,integer x, integer y) {
3404 angle z; /* auxiliary register */
3405 integer t; /* temporary storage */
3406 small_number k; /* loop counter */
3407 int octant; /* octant code */
3409 octant=first_octant;
3411 negate(x); octant=first_octant+negate_x;
3414 negate(y); octant=octant+negate_y;
3417 t=y; y=x; x=t; octant=octant+switch_x_and_y;
3420 @<Handle undefined arg@>;
3422 @<Set variable |z| to the arg of $(x,y)$@>;
3423 @<Return an appropriate answer based on |z| and |octant|@>;
3427 @ @<Handle undefined arg@>=
3429 print_err("angle(0,0) is taken as zero");
3430 @.angle(0,0)...zero@>
3431 help2("The `angle' between two identical points is undefined.")
3432 ("I'm zeroing this one. Proceed, with fingers crossed.");
3437 @ @<Return an appropriate answer...@>=
3439 case first_octant: return z;
3440 case second_octant: return (ninety_deg-z);
3441 case third_octant: return (ninety_deg+z);
3442 case fourth_octant: return (one_eighty_deg-z);
3443 case fifth_octant: return (z-one_eighty_deg);
3444 case sixth_octant: return (-z-ninety_deg);
3445 case seventh_octant: return (z-ninety_deg);
3446 case eighth_octant: return (-z);
3447 }; /* there are no other cases */
3450 @ At this point we have |x>=y>=0|, and |x>0|. The numbers are scaled up
3451 or down until $2^{28}\L x<2^{29}$, so that accurate fixed-point calculations
3454 @<Set variable |z| to the arg...@>=
3455 while ( x>=fraction_two ) {
3456 x=halfp(x); y=halfp(y);
3460 while ( x<fraction_one ) {
3463 @<Increase |z| to the arg of $(x,y)$@>;
3466 @ During the calculations of this section, variables |x| and~|y|
3467 represent actual coordinates $(x,2^{-k}y)$. We will maintain the
3468 condition |x>=y|, so that the tangent will be at most $2^{-k}$.
3469 If $x<2y$, the tangent is greater than $2^{-k-1}$. The transformation
3470 $(a,b)\mapsto(a+b\tan\phi,b-a\tan\phi)$ replaces $(a,b)$ by
3471 coordinates whose angle has decreased by~$\phi$; in the special case
3472 $a=x$, $b=2^{-k}y$, and $\tan\phi=2^{-k-1}$, this operation reduces
3473 to the particularly simple iteration shown here. [Cf.~John E. Meggitt,
3474 @^Meggitt, John E.@>
3475 {\sl IBM Journal of Research and Development\/ \bf6} (1962), 210--226.]
3477 The initial value of |x| will be multiplied by at most
3478 $(1+{1\over2})(1+{1\over8})(1+{1\over32})\cdots\approx 1.7584$; hence
3479 there is no chance of integer overflow.
3481 @<Increase |z|...@>=
3486 z=z+spec_atan[k]; t=x; x=x+(y / two_to_the(k+k)); y=y-t;
3491 if ( y>x ) { z=z+spec_atan[k]; y=y-x; };
3494 @ Conversely, the |n_sin_cos| routine takes an |angle| and produces the sine
3495 and cosine of that angle. The results of this routine are
3496 stored in global integer variables |n_sin| and |n_cos|.
3499 fraction n_sin;fraction n_cos; /* results computed by |n_sin_cos| */
3501 @ Given an integer |z| that is $2^{20}$ times an angle $\theta$ in degrees,
3502 the purpose of |n_sin_cos(z)| is to set
3503 |x=@t$r\cos\theta$@>| and |y=@t$r\sin\theta$@>| (approximately),
3504 for some rather large number~|r|. The maximum of |x| and |y|
3505 will be between $2^{28}$ and $2^{30}$, so that there will be hardly
3506 any loss of accuracy. Then |x| and~|y| are divided by~|r|.
3509 void mp_n_sin_cos (MP mp,angle z) { /* computes a multiple of the sine
3511 small_number k; /* loop control variable */
3512 int q; /* specifies the quadrant */
3513 fraction r; /* magnitude of |(x,y)| */
3514 integer x,y,t; /* temporary registers */
3515 while ( z<0 ) z=z+three_sixty_deg;
3516 z=z % three_sixty_deg; /* now |0<=z<three_sixty_deg| */
3517 q=z / forty_five_deg; z=z % forty_five_deg;
3518 x=fraction_one; y=x;
3519 if ( ! odd(q) ) z=forty_five_deg-z;
3520 @<Subtract angle |z| from |(x,y)|@>;
3521 @<Convert |(x,y)| to the octant determined by~|q|@>;
3522 r=mp_pyth_add(mp, x,y);
3523 mp->n_cos=mp_make_fraction(mp, x,r);
3524 mp->n_sin=mp_make_fraction(mp, y,r);
3527 @ In this case the octants are numbered sequentially.
3529 @<Convert |(x,...@>=
3532 case 1: t=x; x=y; y=t; break;
3533 case 2: t=x; x=-y; y=t; break;
3534 case 3: negate(x); break;
3535 case 4: negate(x); negate(y); break;
3536 case 5: t=x; x=-y; y=-t; break;
3537 case 6: t=x; x=y; y=-t; break;
3538 case 7: negate(y); break;
3539 } /* there are no other cases */
3541 @ The main iteration of |n_sin_cos| is similar to that of |n_arg| but
3542 applied in reverse. The values of |spec_atan[k]| decrease slowly enough
3543 that this loop is guaranteed to terminate before the (nonexistent) value
3544 |spec_atan[27]| would be required.
3546 @<Subtract angle |z|...@>=
3549 if ( z>=spec_atan[k] ) {
3550 z=z-spec_atan[k]; t=x;
3551 x=t+y / two_to_the(k);
3552 y=y-t / two_to_the(k);
3556 if ( y<0 ) y=0 /* this precaution may never be needed */
3558 @ And now let's complete our collection of numeric utility routines
3559 by considering random number generation.
3560 \MP\ generates pseudo-random numbers with the additive scheme recommended
3561 in Section 3.6 of {\sl The Art of Computer Programming}; however, the
3562 results are random fractions between 0 and |fraction_one-1|, inclusive.
3564 There's an auxiliary array |randoms| that contains 55 pseudo-random
3565 fractions. Using the recurrence $x_n=(x_{n-55}-x_{n-31})\bmod 2^{28}$,
3566 we generate batches of 55 new $x_n$'s at a time by calling |new_randoms|.
3567 The global variable |j_random| tells which element has most recently
3569 The global variable |random_seed| was introduced in version 0.9,
3570 for the sole reason of stressing the fact that the initial value of the
3571 random seed is system-dependant. The initialization code below will initialize
3572 this variable to |(internal[mp_time] div unity)+internal[mp_day]|, but this
3573 is not good enough on modern fast machines that are capable of running
3574 multiple MetaPost processes within the same second.
3575 @^system dependencies@>
3578 fraction randoms[55]; /* the last 55 random values generated */
3579 int j_random; /* the number of unused |randoms| */
3581 @ @<Option variables@>=
3582 int random_seed; /* the default random seed */
3584 @ @<Allocate or initialize ...@>=
3585 mp->random_seed = (scaled)opt->random_seed;
3587 @ To consume a random fraction, the program below will say `|next_random|'
3588 and then it will fetch |randoms[j_random]|.
3590 @d next_random { if ( mp->j_random==0 ) mp_new_randoms(mp);
3591 else decr(mp->j_random); }
3594 void mp_new_randoms (MP mp) {
3595 int k; /* index into |randoms| */
3596 fraction x; /* accumulator */
3597 for (k=0;k<=23;k++) {
3598 x=mp->randoms[k]-mp->randoms[k+31];
3599 if ( x<0 ) x=x+fraction_one;
3602 for (k=24;k<= 54;k++){
3603 x=mp->randoms[k]-mp->randoms[k-24];
3604 if ( x<0 ) x=x+fraction_one;
3611 void mp_init_randoms (MP mp,scaled seed);
3613 @ To initialize the |randoms| table, we call the following routine.
3616 void mp_init_randoms (MP mp,scaled seed) {
3617 fraction j,jj,k; /* more or less random integers */
3618 int i; /* index into |randoms| */
3620 while ( j>=fraction_one ) j=halfp(j);
3622 for (i=0;i<=54;i++ ){
3624 if ( k<0 ) k=k+fraction_one;
3625 mp->randoms[(i*21)% 55]=j;
3629 mp_new_randoms(mp); /* ``warm up'' the array */
3632 @ To produce a uniform random number in the range |0<=u<x| or |0>=u>x|
3633 or |0=u=x|, given a |scaled| value~|x|, we proceed as shown here.
3635 Note that the call of |take_fraction| will produce the values 0 and~|x|
3636 with about half the probability that it will produce any other particular
3637 values between 0 and~|x|, because it rounds its answers.
3640 scaled mp_unif_rand (MP mp,scaled x) {
3641 scaled y; /* trial value */
3642 next_random; y=mp_take_fraction(mp, abs(x),mp->randoms[mp->j_random]);
3643 if ( y==abs(x) ) return 0;
3644 else if ( x>0 ) return y;
3648 @ Finally, a normal deviate with mean zero and unit standard deviation
3649 can readily be obtained with the ratio method (Algorithm 3.4.1R in
3650 {\sl The Art of Computer Programming\/}).
3653 scaled mp_norm_rand (MP mp) {
3654 integer x,u,l; /* what the book would call $2^{16}X$, $2^{28}U$, and $-2^{24}\ln U$ */
3658 x=mp_take_fraction(mp, 112429,mp->randoms[mp->j_random]-fraction_half);
3659 /* $2^{16}\sqrt{8/e}\approx 112428.82793$ */
3660 next_random; u=mp->randoms[mp->j_random];
3661 } while (abs(x)>=u);
3662 x=mp_make_fraction(mp, x,u);
3663 l=139548960-mp_m_log(mp, u); /* $2^{24}\cdot12\ln2\approx139548959.6165$ */
3664 } while (mp_ab_vs_cd(mp, 1024,l,x,x)<0);
3668 @* \[9] Packed data.
3669 In order to make efficient use of storage space, \MP\ bases its major data
3670 structures on a |memory_word|, which contains either a (signed) integer,
3671 possibly scaled, or a small number of fields that are one half or one
3672 quarter of the size used for storing integers.
3674 If |x| is a variable of type |memory_word|, it contains up to four
3675 fields that can be referred to as follows:
3676 $$\vbox{\halign{\hfil#&#\hfil&#\hfil\cr
3677 |x|&.|int|&(an |integer|)\cr
3678 |x|&.|sc|\qquad&(a |scaled| integer)\cr
3679 |x.hh.lh|, |x.hh|&.|rh|&(two halfword fields)\cr
3680 |x.hh.b0|, |x.hh.b1|, |x.hh|&.|rh|&(two quarterword fields, one halfword
3682 |x.qqqq.b0|, |x.qqqq.b1|, |x.qqqq|&.|b2|, |x.qqqq.b3|\hskip-100pt
3683 &\qquad\qquad\qquad(four quarterword fields)\cr}}$$
3684 This is somewhat cumbersome to write, and not very readable either, but
3685 macros will be used to make the notation shorter and more transparent.
3686 The code below gives a formal definition of |memory_word| and
3687 its subsidiary types, using packed variant records. \MP\ makes no
3688 assumptions about the relative positions of the fields within a word.
3690 @d max_quarterword 0x3FFF /* largest allowable value in a |quarterword| */
3691 @d max_halfword 0xFFFFFFF /* largest allowable value in a |halfword| */
3693 @ Here are the inequalities that the quarterword and halfword values
3694 must satisfy (or rather, the inequalities that they mustn't satisfy):
3696 @<Check the ``constant''...@>=
3697 if (mp->ini_version) {
3698 if ( mp->mem_max!=mp->mem_top ) mp->bad=8;
3700 if ( mp->mem_max<mp->mem_top ) mp->bad=8;
3702 if ( mp->mem_max>=max_halfword ) mp->bad=12;
3703 if ( mp->max_strings>max_halfword ) mp->bad=13;
3705 @ The macros |qi| and |qo| are used for input to and output
3706 from quarterwords. These are legacy macros.
3707 @^system dependencies@>
3709 @d qo(A) (A) /* to read eight bits from a quarterword */
3710 @d qi(A) (A) /* to store eight bits in a quarterword */
3712 @ The reader should study the following definitions closely:
3713 @^system dependencies@>
3715 @d sc cint /* |scaled| data is equivalent to |integer| */
3718 typedef short quarterword; /* 1/4 of a word */
3719 typedef int halfword; /* 1/2 of a word */
3724 struct { /* Make B0,B1 overlap the most significant bytes of LH. */
3731 quarterword B2, B3, B0, B1;
3746 @ When debugging, we may want to print a |memory_word| without knowing
3747 what type it is; so we print it in all modes.
3751 void mp_print_word (MP mp,memory_word w) {
3752 /* prints |w| in all ways */
3753 mp_print_int(mp, w.cint); mp_print_char(mp, ' ');
3754 mp_print_scaled(mp, w.sc); mp_print_char(mp, ' ');
3755 mp_print_scaled(mp, w.sc / 010000); mp_print_ln(mp);
3756 mp_print_int(mp, w.hh.lh); mp_print_char(mp, '=');
3757 mp_print_int(mp, w.hh.b0); mp_print_char(mp, ':');
3758 mp_print_int(mp, w.hh.b1); mp_print_char(mp, ';');
3759 mp_print_int(mp, w.hh.rh); mp_print_char(mp, ' ');
3760 mp_print_int(mp, w.qqqq.b0); mp_print_char(mp, ':');
3761 mp_print_int(mp, w.qqqq.b1); mp_print_char(mp, ':');
3762 mp_print_int(mp, w.qqqq.b2); mp_print_char(mp, ':');
3763 mp_print_int(mp, w.qqqq.b3);
3767 @* \[10] Dynamic memory allocation.
3769 The \MP\ system does nearly all of its own memory allocation, so that it
3770 can readily be transported into environments that do not have automatic
3771 facilities for strings, garbage collection, etc., and so that it can be in
3772 control of what error messages the user receives. The dynamic storage
3773 requirements of \MP\ are handled by providing a large array |mem| in
3774 which consecutive blocks of words are used as nodes by the \MP\ routines.
3776 Pointer variables are indices into this array, or into another array
3777 called |eqtb| that will be explained later. A pointer variable might
3778 also be a special flag that lies outside the bounds of |mem|, so we
3779 allow pointers to assume any |halfword| value. The minimum memory
3780 index represents a null pointer.
3782 @d null 0 /* the null pointer */
3783 @d mp_void (null+1) /* a null pointer different from |null| */
3787 typedef halfword pointer; /* a flag or a location in |mem| or |eqtb| */
3789 @ The |mem| array is divided into two regions that are allocated separately,
3790 but the dividing line between these two regions is not fixed; they grow
3791 together until finding their ``natural'' size in a particular job.
3792 Locations less than or equal to |lo_mem_max| are used for storing
3793 variable-length records consisting of two or more words each. This region
3794 is maintained using an algorithm similar to the one described in exercise
3795 2.5--19 of {\sl The Art of Computer Programming}. However, no size field
3796 appears in the allocated nodes; the program is responsible for knowing the
3797 relevant size when a node is freed. Locations greater than or equal to
3798 |hi_mem_min| are used for storing one-word records; a conventional
3799 \.{AVAIL} stack is used for allocation in this region.
3801 Locations of |mem| between |0| and |mem_top| may be dumped as part
3802 of preloaded mem files, by the \.{INIMP} preprocessor.
3804 Production versions of \MP\ may extend the memory at the top end in order to
3805 provide more space; these locations, between |mem_top| and |mem_max|,
3806 are always used for single-word nodes.
3808 The key pointers that govern |mem| allocation have a prescribed order:
3809 $$\hbox{|null=0<lo_mem_max<hi_mem_min<mem_top<=mem_end<=mem_max|.}$$
3812 memory_word *mem; /* the big dynamic storage area */
3813 pointer lo_mem_max; /* the largest location of variable-size memory in use */
3814 pointer hi_mem_min; /* the smallest location of one-word memory in use */
3818 @d xfree(A) do { mp_xfree(A); A=NULL; } while (0)
3819 @d xrealloc(P,A,B) mp_xrealloc(mp,P,A,B)
3820 @d xmalloc(A,B) mp_xmalloc(mp,A,B)
3821 @d xstrdup(A) mp_xstrdup(mp,A)
3822 @d XREALLOC(a,b,c) a = xrealloc(a,(b+1),sizeof(c));
3824 @<Declare helpers@>=
3825 void mp_xfree (void *x);
3826 void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size) ;
3827 void *mp_xmalloc (MP mp, size_t nmem, size_t size) ;
3828 char *mp_xstrdup(MP mp, const char *s);
3829 void mp_do_snprintf(char *str, int size, const char *fmt, ...);
3831 @ The |max_size_test| guards against overflow, on the assumption that
3832 |size_t| is at least 31bits wide.
3834 @d max_size_test 0x7FFFFFFF
3837 void mp_xfree (void *x) {
3838 if (x!=NULL) free(x);
3840 void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size) {
3842 if ((max_size_test/size)<nmem) {
3843 do_fprintf(mp->err_out,"Memory size overflow!\n");
3844 mp->history =mp_fatal_error_stop; mp_jump_out(mp);
3846 w = realloc (p,(nmem*size));
3848 do_fprintf(mp->err_out,"Out of memory!\n");
3849 mp->history =mp_system_error_stop; mp_jump_out(mp);
3853 void *mp_xmalloc (MP mp, size_t nmem, size_t size) {
3855 if ((max_size_test/size)<nmem) {
3856 do_fprintf(mp->err_out,"Memory size overflow!\n");
3857 mp->history =mp_fatal_error_stop; mp_jump_out(mp);
3859 w = malloc (nmem*size);
3861 do_fprintf(mp->err_out,"Out of memory!\n");
3862 mp->history =mp_system_error_stop; mp_jump_out(mp);
3866 char *mp_xstrdup(MP mp, const char *s) {
3872 do_fprintf(mp->err_out,"Out of memory!\n");
3873 mp->history =mp_system_error_stop; mp_jump_out(mp);
3878 @ @<Internal library declarations@>=
3879 #ifdef HAVE_SNPRINTF
3880 #define mp_snprintf (void)snprintf
3882 #define mp_snprintf mp_do_snprintf
3885 @ This internal version is rather stupid, but good enough for its purpose.
3888 void mp_do_snprintf (char *str, int size, const char *format, ...) {
3893 work = (char *)workbuf;
3894 va_start(ap, format);
3896 for (fmt=format;*fmt!='\0';fmt++) {
3902 char *s = va_arg(ap, char *);
3905 if (size-->0) res++;
3912 sprintf(work,"%i",va_arg(ap, int));
3915 if (size-->0) res++;
3921 sprintf(work,"%g",va_arg(ap, double));
3924 if (size-->0) res++;
3930 if (size-->0) res++;
3938 if (size-->0) res++;
3946 @<Allocate or initialize ...@>=
3947 mp->mem = xmalloc ((mp->mem_max+1),sizeof (memory_word));
3948 memset(mp->mem,0,(mp->mem_max+1)*sizeof (memory_word));
3950 @ @<Dealloc variables@>=
3953 @ Users who wish to study the memory requirements of particular applications can
3954 can use optional special features that keep track of current and
3955 maximum memory usage. When code between the delimiters |stat| $\ldots$
3956 |tats| is not ``commented out,'' \MP\ will run a bit slower but it will
3957 report these statistics when |mp_tracing_stats| is positive.
3960 integer var_used; integer dyn_used; /* how much memory is in use */
3962 @ Let's consider the one-word memory region first, since it's the
3963 simplest. The pointer variable |mem_end| holds the highest-numbered location
3964 of |mem| that has ever been used. The free locations of |mem| that
3965 occur between |hi_mem_min| and |mem_end|, inclusive, are of type
3966 |two_halves|, and we write |info(p)| and |link(p)| for the |lh|
3967 and |rh| fields of |mem[p]| when it is of this type. The single-word
3968 free locations form a linked list
3969 $$|avail|,\;\hbox{|link(avail)|},\;\hbox{|link(link(avail))|},\;\ldots$$
3970 terminated by |null|.
3972 @d link(A) mp->mem[(A)].hh.rh /* the |link| field of a memory word */
3973 @d info(A) mp->mem[(A)].hh.lh /* the |info| field of a memory word */
3976 pointer avail; /* head of the list of available one-word nodes */
3977 pointer mem_end; /* the last one-word node used in |mem| */
3979 @ If one-word memory is exhausted, it might mean that the user has forgotten
3980 a token like `\&{enddef}' or `\&{endfor}'. We will define some procedures
3981 later that try to help pinpoint the trouble.
3984 @<Declare the procedure called |show_token_list|@>
3985 @<Declare the procedure called |runaway|@>
3987 @ The function |get_avail| returns a pointer to a new one-word node whose
3988 |link| field is null. However, \MP\ will halt if there is no more room left.
3992 pointer mp_get_avail (MP mp) { /* single-word node allocation */
3993 pointer p; /* the new node being got */
3994 p=mp->avail; /* get top location in the |avail| stack */
3996 mp->avail=link(mp->avail); /* and pop it off */
3997 } else if ( mp->mem_end<mp->mem_max ) { /* or go into virgin territory */
3998 incr(mp->mem_end); p=mp->mem_end;
4000 decr(mp->hi_mem_min); p=mp->hi_mem_min;
4001 if ( mp->hi_mem_min<=mp->lo_mem_max ) {
4002 mp_runaway(mp); /* if memory is exhausted, display possible runaway text */
4003 mp_overflow(mp, "main memory size",mp->mem_max);
4004 /* quit; all one-word nodes are busy */
4005 @:MetaPost capacity exceeded main memory size}{\quad main memory size@>
4008 link(p)=null; /* provide an oft-desired initialization of the new node */
4009 incr(mp->dyn_used);/* maintain statistics */
4013 @ Conversely, a one-word node is recycled by calling |free_avail|.
4015 @d free_avail(A) /* single-word node liberation */
4016 { link((A))=mp->avail; mp->avail=(A); decr(mp->dyn_used); }
4018 @ There's also a |fast_get_avail| routine, which saves the procedure-call
4019 overhead at the expense of extra programming. This macro is used in
4020 the places that would otherwise account for the most calls of |get_avail|.
4023 @d fast_get_avail(A) {
4024 (A)=mp->avail; /* avoid |get_avail| if possible, to save time */
4025 if ( (A)==null ) { (A)=mp_get_avail(mp); }
4026 else { mp->avail=link((A)); link((A))=null; incr(mp->dyn_used); }
4029 @ The available-space list that keeps track of the variable-size portion
4030 of |mem| is a nonempty, doubly-linked circular list of empty nodes,
4031 pointed to by the roving pointer |rover|.
4033 Each empty node has size 2 or more; the first word contains the special
4034 value |max_halfword| in its |link| field and the size in its |info| field;
4035 the second word contains the two pointers for double linking.
4037 Each nonempty node also has size 2 or more. Its first word is of type
4038 |two_halves|\kern-1pt, and its |link| field is never equal to |max_halfword|.
4039 Otherwise there is complete flexibility with respect to the contents
4040 of its other fields and its other words.
4042 (We require |mem_max<max_halfword| because terrible things can happen
4043 when |max_halfword| appears in the |link| field of a nonempty node.)
4045 @d empty_flag max_halfword /* the |link| of an empty variable-size node */
4046 @d is_empty(A) (link((A))==empty_flag) /* tests for empty node */
4047 @d node_size info /* the size field in empty variable-size nodes */
4048 @d llink(A) info((A)+1) /* left link in doubly-linked list of empty nodes */
4049 @d rlink(A) link((A)+1) /* right link in doubly-linked list of empty nodes */
4052 pointer rover; /* points to some node in the list of empties */
4054 @ A call to |get_node| with argument |s| returns a pointer to a new node
4055 of size~|s|, which must be 2~or more. The |link| field of the first word
4056 of this new node is set to null. An overflow stop occurs if no suitable
4059 If |get_node| is called with $s=2^{30}$, it simply merges adjacent free
4060 areas and returns the value |max_halfword|.
4062 @<Internal library declarations@>=
4063 pointer mp_get_node (MP mp,integer s) ;
4066 pointer mp_get_node (MP mp,integer s) { /* variable-size node allocation */
4067 pointer p; /* the node currently under inspection */
4068 pointer q; /* the node physically after node |p| */
4069 integer r; /* the newly allocated node, or a candidate for this honor */
4070 integer t,tt; /* temporary registers */
4073 p=mp->rover; /* start at some free node in the ring */
4075 @<Try to allocate within node |p| and its physical successors,
4076 and |goto found| if allocation was possible@>;
4077 if (rlink(p)==null || (rlink(p)==p && p!=mp->rover)) {
4078 print_err("Free list garbled");
4079 help3("I found an entry in the list of free nodes that links")
4080 ("badly. I will try to ignore the broken link, but something")
4081 ("is seriously amiss. It is wise to warn the maintainers.")
4085 p=rlink(p); /* move to the next node in the ring */
4086 } while (p!=mp->rover); /* repeat until the whole list has been traversed */
4087 if ( s==010000000000 ) {
4088 return max_halfword;
4090 if ( mp->lo_mem_max+2<mp->hi_mem_min ) {
4091 if ( mp->lo_mem_max+2<=max_halfword ) {
4092 @<Grow more variable-size memory and |goto restart|@>;
4095 mp_overflow(mp, "main memory size",mp->mem_max);
4096 /* sorry, nothing satisfactory is left */
4097 @:MetaPost capacity exceeded main memory size}{\quad main memory size@>
4099 link(r)=null; /* this node is now nonempty */
4100 mp->var_used+=s; /* maintain usage statistics */
4104 @ The lower part of |mem| grows by 1000 words at a time, unless
4105 we are very close to going under. When it grows, we simply link
4106 a new node into the available-space list. This method of controlled
4107 growth helps to keep the |mem| usage consecutive when \MP\ is
4108 implemented on ``virtual memory'' systems.
4111 @<Grow more variable-size memory and |goto restart|@>=
4113 if ( mp->hi_mem_min-mp->lo_mem_max>=1998 ) {
4114 t=mp->lo_mem_max+1000;
4116 t=mp->lo_mem_max+1+(mp->hi_mem_min-mp->lo_mem_max) / 2;
4117 /* |lo_mem_max+2<=t<hi_mem_min| */
4119 if ( t>max_halfword ) t=max_halfword;
4120 p=llink(mp->rover); q=mp->lo_mem_max; rlink(p)=q; llink(mp->rover)=q;
4121 rlink(q)=mp->rover; llink(q)=p; link(q)=empty_flag;
4122 node_size(q)=t-mp->lo_mem_max;
4123 mp->lo_mem_max=t; link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null;
4128 @ @<Try to allocate...@>=
4129 q=p+node_size(p); /* find the physical successor */
4130 while ( is_empty(q) ) { /* merge node |p| with node |q| */
4131 t=rlink(q); tt=llink(q);
4133 if ( q==mp->rover ) mp->rover=t;
4134 llink(t)=tt; rlink(tt)=t;
4139 @<Allocate from the top of node |p| and |goto found|@>;
4142 if ( rlink(p)!=p ) {
4143 @<Allocate entire node |p| and |goto found|@>;
4146 node_size(p)=q-p /* reset the size in case it grew */
4148 @ @<Allocate from the top...@>=
4150 node_size(p)=r-p; /* store the remaining size */
4151 mp->rover=p; /* start searching here next time */
4155 @ Here we delete node |p| from the ring, and let |rover| rove around.
4157 @<Allocate entire...@>=
4159 mp->rover=rlink(p); t=llink(p);
4160 llink(mp->rover)=t; rlink(t)=mp->rover;
4164 @ Conversely, when some variable-size node |p| of size |s| is no longer needed,
4165 the operation |free_node(p,s)| will make its words available, by inserting
4166 |p| as a new empty node just before where |rover| now points.
4168 @<Internal library declarations@>=
4169 void mp_free_node (MP mp, pointer p, halfword s) ;
4172 void mp_free_node (MP mp, pointer p, halfword s) { /* variable-size node
4174 pointer q; /* |llink(rover)| */
4175 node_size(p)=s; link(p)=empty_flag;
4177 q=llink(mp->rover); llink(p)=q; rlink(p)=mp->rover; /* set both links */
4178 llink(mp->rover)=p; rlink(q)=p; /* insert |p| into the ring */
4179 mp->var_used-=s; /* maintain statistics */
4182 @ Just before \.{INIMP} writes out the memory, it sorts the doubly linked
4183 available space list. The list is probably very short at such times, so a
4184 simple insertion sort is used. The smallest available location will be
4185 pointed to by |rover|, the next-smallest by |rlink(rover)|, etc.
4188 void mp_sort_avail (MP mp) { /* sorts the available variable-size nodes
4190 pointer p,q,r; /* indices into |mem| */
4191 pointer old_rover; /* initial |rover| setting */
4192 p=mp_get_node(mp, 010000000000); /* merge adjacent free areas */
4193 p=rlink(mp->rover); rlink(mp->rover)=max_halfword; old_rover=mp->rover;
4194 while ( p!=old_rover ) {
4195 @<Sort |p| into the list starting at |rover|
4196 and advance |p| to |rlink(p)|@>;
4199 while ( rlink(p)!=max_halfword ) {
4200 llink(rlink(p))=p; p=rlink(p);
4202 rlink(p)=mp->rover; llink(mp->rover)=p;
4205 @ The following |while| loop is guaranteed to
4206 terminate, since the list that starts at
4207 |rover| ends with |max_halfword| during the sorting procedure.
4210 if ( p<mp->rover ) {
4211 q=p; p=rlink(q); rlink(q)=mp->rover; mp->rover=q;
4214 while ( rlink(q)<p ) q=rlink(q);
4215 r=rlink(p); rlink(p)=rlink(q); rlink(q)=p; p=r;
4218 @* \[11] Memory layout.
4219 Some areas of |mem| are dedicated to fixed usage, since static allocation is
4220 more efficient than dynamic allocation when we can get away with it. For
4221 example, locations |0| to |1| are always used to store a
4222 two-word dummy token whose second word is zero.
4223 The following macro definitions accomplish the static allocation by giving
4224 symbolic names to the fixed positions. Static variable-size nodes appear
4225 in locations |0| through |lo_mem_stat_max|, and static single-word nodes
4226 appear in locations |hi_mem_stat_min| through |mem_top|, inclusive.
4228 @d null_dash (2) /* the first two words are reserved for a null value */
4229 @d dep_head (null_dash+3) /* we will define |dash_node_size=3| */
4230 @d zero_val (dep_head+2) /* two words for a permanently zero value */
4231 @d temp_val (zero_val+2) /* two words for a temporary value node */
4232 @d end_attr temp_val /* we use |end_attr+2| only */
4233 @d inf_val (end_attr+2) /* and |inf_val+1| only */
4234 @d test_pen (inf_val+2)
4235 /* nine words for a pen used when testing the turning number */
4236 @d bad_vardef (test_pen+9) /* two words for \&{vardef} error recovery */
4237 @d lo_mem_stat_max (bad_vardef+1) /* largest statically
4238 allocated word in the variable-size |mem| */
4240 @d sentinel mp->mem_top /* end of sorted lists */
4241 @d temp_head (mp->mem_top-1) /* head of a temporary list of some kind */
4242 @d hold_head (mp->mem_top-2) /* head of a temporary list of another kind */
4243 @d spec_head (mp->mem_top-3) /* head of a list of unprocessed \&{special} items */
4244 @d hi_mem_stat_min (mp->mem_top-3) /* smallest statically allocated word in
4245 the one-word |mem| */
4247 @ The following code gets the dynamic part of |mem| off to a good start,
4248 when \MP\ is initializing itself the slow way.
4250 @<Initialize table entries (done by \.{INIMP} only)@>=
4251 mp->rover=lo_mem_stat_max+1; /* initialize the dynamic memory */
4252 link(mp->rover)=empty_flag;
4253 node_size(mp->rover)=1000; /* which is a 1000-word available node */
4254 llink(mp->rover)=mp->rover; rlink(mp->rover)=mp->rover;
4255 mp->lo_mem_max=mp->rover+1000;
4256 link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null;
4257 for (k=hi_mem_stat_min;k<=(int)mp->mem_top;k++) {
4258 mp->mem[k]=mp->mem[mp->lo_mem_max]; /* clear list heads */
4260 mp->avail=null; mp->mem_end=mp->mem_top;
4261 mp->hi_mem_min=hi_mem_stat_min; /* initialize the one-word memory */
4262 mp->var_used=lo_mem_stat_max+1;
4263 mp->dyn_used=mp->mem_top+1-(hi_mem_stat_min); /* initialize statistics */
4264 @<Initialize a pen at |test_pen| so that it fits in nine words@>;
4266 @ The procedure |flush_list(p)| frees an entire linked list of one-word
4267 nodes that starts at a given position, until coming to |sentinel| or a
4268 pointer that is not in the one-word region. Another procedure,
4269 |flush_node_list|, frees an entire linked list of one-word and two-word
4270 nodes, until coming to a |null| pointer.
4274 void mp_flush_list (MP mp,pointer p) { /* makes list of single-word nodes available */
4275 pointer q,r; /* list traversers */
4276 if ( p>=mp->hi_mem_min ) if ( p!=sentinel ) {
4281 if ( r<mp->hi_mem_min ) break;
4282 } while (r!=sentinel);
4283 /* now |q| is the last node on the list */
4284 link(q)=mp->avail; mp->avail=p;
4288 void mp_flush_node_list (MP mp,pointer p) {
4289 pointer q; /* the node being recycled */
4292 if ( q<mp->hi_mem_min )
4293 mp_free_node(mp, q,2);
4299 @ If \MP\ is extended improperly, the |mem| array might get screwed up.
4300 For example, some pointers might be wrong, or some ``dead'' nodes might not
4301 have been freed when the last reference to them disappeared. Procedures
4302 |check_mem| and |search_mem| are available to help diagnose such
4303 problems. These procedures make use of two arrays called |free| and
4304 |was_free| that are present only if \MP's debugging routines have
4305 been included. (You may want to decrease the size of |mem| while you
4309 Because |boolean|s are typedef-d as ints, it is better to use
4310 unsigned chars here.
4313 unsigned char *free; /* free cells */
4314 unsigned char *was_free; /* previously free cells */
4315 pointer was_mem_end; pointer was_lo_max; pointer was_hi_min;
4316 /* previous |mem_end|, |lo_mem_max|,and |hi_mem_min| */
4317 boolean panicking; /* do we want to check memory constantly? */
4319 @ @<Allocate or initialize ...@>=
4320 mp->free = xmalloc ((mp->mem_max+1),sizeof (unsigned char));
4321 mp->was_free = xmalloc ((mp->mem_max+1), sizeof (unsigned char));
4323 @ @<Dealloc variables@>=
4325 xfree(mp->was_free);
4327 @ @<Allocate or ...@>=
4328 mp->was_hi_min=mp->mem_max;
4329 mp->panicking=false;
4331 @ @<Declare |mp_reallocate| functions@>=
4332 void mp_reallocate_memory(MP mp, int l) ;
4335 void mp_reallocate_memory(MP mp, int l) {
4336 XREALLOC(mp->free, l, unsigned char);
4337 XREALLOC(mp->was_free, l, unsigned char);
4339 int newarea = l-mp->mem_max;
4340 XREALLOC(mp->mem, l, memory_word);
4341 memset (mp->mem+(mp->mem_max+1),0,sizeof(memory_word)*(newarea));
4343 XREALLOC(mp->mem, l, memory_word);
4344 memset(mp->mem,0,sizeof(memory_word)*(l+1));
4347 if (mp->ini_version)
4353 @ Procedure |check_mem| makes sure that the available space lists of
4354 |mem| are well formed, and it optionally prints out all locations
4355 that are reserved now but were free the last time this procedure was called.
4358 void mp_check_mem (MP mp,boolean print_locs ) {
4359 pointer p,q,r; /* current locations of interest in |mem| */
4360 boolean clobbered; /* is something amiss? */
4361 for (p=0;p<=mp->lo_mem_max;p++) {
4362 mp->free[p]=false; /* you can probably do this faster */
4364 for (p=mp->hi_mem_min;p<= mp->mem_end;p++) {
4365 mp->free[p]=false; /* ditto */
4367 @<Check single-word |avail| list@>;
4368 @<Check variable-size |avail| list@>;
4369 @<Check flags of unavailable nodes@>;
4370 @<Check the list of linear dependencies@>;
4372 @<Print newly busy locations@>;
4374 memcpy(mp->was_free,mp->free, sizeof(char)*(mp->mem_end+1));
4375 mp->was_mem_end=mp->mem_end;
4376 mp->was_lo_max=mp->lo_mem_max;
4377 mp->was_hi_min=mp->hi_mem_min;
4380 @ @<Check single-word...@>=
4381 p=mp->avail; q=null; clobbered=false;
4383 if ( (p>mp->mem_end)||(p<mp->hi_mem_min) ) clobbered=true;
4384 else if ( mp->free[p] ) clobbered=true;
4386 mp_print_nl(mp, "AVAIL list clobbered at ");
4387 @.AVAIL list clobbered...@>
4388 mp_print_int(mp, q); break;
4390 mp->free[p]=true; q=p; p=link(q);
4393 @ @<Check variable-size...@>=
4394 p=mp->rover; q=null; clobbered=false;
4396 if ( (p>=mp->lo_mem_max)||(p<0) ) clobbered=true;
4397 else if ( (rlink(p)>=mp->lo_mem_max)||(rlink(p)<0) ) clobbered=true;
4398 else if ( !(is_empty(p))||(node_size(p)<2)||
4399 (p+node_size(p)>mp->lo_mem_max)|| (llink(rlink(p))!=p) ) clobbered=true;
4401 mp_print_nl(mp, "Double-AVAIL list clobbered at ");
4402 @.Double-AVAIL list clobbered...@>
4403 mp_print_int(mp, q); break;
4405 for (q=p;q<=p+node_size(p)-1;q++) { /* mark all locations free */
4406 if ( mp->free[q] ) {
4407 mp_print_nl(mp, "Doubly free location at ");
4408 @.Doubly free location...@>
4409 mp_print_int(mp, q); break;
4414 } while (p!=mp->rover)
4417 @ @<Check flags...@>=
4419 while ( p<=mp->lo_mem_max ) { /* node |p| should not be empty */
4420 if ( is_empty(p) ) {
4421 mp_print_nl(mp, "Bad flag at "); mp_print_int(mp, p);
4424 while ( (p<=mp->lo_mem_max) && ! mp->free[p] ) incr(p);
4425 while ( (p<=mp->lo_mem_max) && mp->free[p] ) incr(p);
4428 @ @<Print newly busy...@>=
4430 @<Do intialization required before printing new busy locations@>;
4431 mp_print_nl(mp, "New busy locs:");
4433 for (p=0;p<= mp->lo_mem_max;p++ ) {
4434 if ( ! mp->free[p] && ((p>mp->was_lo_max) || mp->was_free[p]) ) {
4435 @<Indicate that |p| is a new busy location@>;
4438 for (p=mp->hi_mem_min;p<=mp->mem_end;p++ ) {
4439 if ( ! mp->free[p] &&
4440 ((p<mp->was_hi_min) || (p>mp->was_mem_end) || mp->was_free[p]) ) {
4441 @<Indicate that |p| is a new busy location@>;
4444 @<Finish printing new busy locations@>;
4447 @ There might be many new busy locations so we are careful to print contiguous
4448 blocks compactly. During this operation |q| is the last new busy location and
4449 |r| is the start of the block containing |q|.
4451 @<Indicate that |p| is a new busy location@>=
4455 mp_print(mp, ".."); mp_print_int(mp, q);
4457 mp_print_char(mp, ' '); mp_print_int(mp, p);
4463 @ @<Do intialization required before printing new busy locations@>=
4464 q=mp->mem_max; r=mp->mem_max
4466 @ @<Finish printing new busy locations@>=
4468 mp_print(mp, ".."); mp_print_int(mp, q);
4471 @ The |search_mem| procedure attempts to answer the question ``Who points
4472 to node~|p|?'' In doing so, it fetches |link| and |info| fields of |mem|
4473 that might not be of type |two_halves|. Strictly speaking, this is
4474 undefined, and it can lead to ``false drops'' (words that seem to
4475 point to |p| purely by coincidence). But for debugging purposes, we want
4476 to rule out the places that do {\sl not\/} point to |p|, so a few false
4477 drops are tolerable.
4480 void mp_search_mem (MP mp, pointer p) { /* look for pointers to |p| */
4481 integer q; /* current position being searched */
4482 for (q=0;q<=mp->lo_mem_max;q++) {
4484 mp_print_nl(mp, "LINK("); mp_print_int(mp, q); mp_print_char(mp, ')');
4487 mp_print_nl(mp, "INFO("); mp_print_int(mp, q); mp_print_char(mp, ')');
4490 for (q=mp->hi_mem_min;q<=mp->mem_end;q++) {
4492 mp_print_nl(mp, "LINK("); mp_print_int(mp, q); mp_print_char(mp, ')');
4495 mp_print_nl(mp, "INFO("); mp_print_int(mp, q); mp_print_char(mp, ')');
4498 @<Search |eqtb| for equivalents equal to |p|@>;
4501 @* \[12] The command codes.
4502 Before we can go much further, we need to define symbolic names for the internal
4503 code numbers that represent the various commands obeyed by \MP. These codes
4504 are somewhat arbitrary, but not completely so. For example,
4505 some codes have been made adjacent so that |case| statements in the
4506 program need not consider cases that are widely spaced, or so that |case|
4507 statements can be replaced by |if| statements. A command can begin an
4508 expression if and only if its code lies between |min_primary_command| and
4509 |max_primary_command|, inclusive. The first token of a statement that doesn't
4510 begin with an expression has a command code between |min_command| and
4511 |max_statement_command|, inclusive. Anything less than |min_command| is
4512 eliminated during macro expansions, and anything no more than |max_pre_command|
4513 is eliminated when expanding \TeX\ material. Ranges such as
4514 |min_secondary_command..max_secondary_command| are used when parsing
4515 expressions, but the relative ordering within such a range is generally not
4518 The ordering of the highest-numbered commands
4519 (|comma<semicolon<end_group<stop|) is crucial for the parsing and
4520 error-recovery methods of this program as is the ordering |if_test<fi_or_else|
4521 for the smallest two commands. The ordering is also important in the ranges
4522 |numeric_token..plus_or_minus| and |left_brace..ampersand|.
4524 At any rate, here is the list, for future reference.
4526 @d start_tex 1 /* begin \TeX\ material (\&{btex}, \&{verbatimtex}) */
4527 @d etex_marker 2 /* end \TeX\ material (\&{etex}) */
4528 @d mpx_break 3 /* stop reading an \.{MPX} file (\&{mpxbreak}) */
4529 @d max_pre_command mpx_break
4530 @d if_test 4 /* conditional text (\&{if}) */
4531 @d fi_or_else 5 /* delimiters for conditionals (\&{elseif}, \&{else}, \&{fi}) */
4532 @d input 6 /* input a source file (\&{input}, \&{endinput}) */
4533 @d iteration 7 /* iterate (\&{for}, \&{forsuffixes}, \&{forever}, \&{endfor}) */
4534 @d repeat_loop 8 /* special command substituted for \&{endfor} */
4535 @d exit_test 9 /* premature exit from a loop (\&{exitif}) */
4536 @d relax 10 /* do nothing (\.{\char`\\}) */
4537 @d scan_tokens 11 /* put a string into the input buffer */
4538 @d expand_after 12 /* look ahead one token */
4539 @d defined_macro 13 /* a macro defined by the user */
4540 @d min_command (defined_macro+1)
4541 @d save_command 14 /* save a list of tokens (\&{save}) */
4542 @d interim_command 15 /* save an internal quantity (\&{interim}) */
4543 @d let_command 16 /* redefine a symbolic token (\&{let}) */
4544 @d new_internal 17 /* define a new internal quantity (\&{newinternal}) */
4545 @d macro_def 18 /* define a macro (\&{def}, \&{vardef}, etc.) */
4546 @d ship_out_command 19 /* output a character (\&{shipout}) */
4547 @d add_to_command 20 /* add to edges (\&{addto}) */
4548 @d bounds_command 21 /* add bounding path to edges (\&{setbounds}, \&{clip}) */
4549 @d tfm_command 22 /* command for font metric info (\&{ligtable}, etc.) */
4550 @d protection_command 23 /* set protection flag (\&{outer}, \&{inner}) */
4551 @d show_command 24 /* diagnostic output (\&{show}, \&{showvariable}, etc.) */
4552 @d mode_command 25 /* set interaction level (\&{batchmode}, etc.) */
4553 @d mp_random_seed 26 /* initialize random number generator (\&{randomseed}) */
4554 @d message_command 27 /* communicate to user (\&{message}, \&{errmessage}) */
4555 @d every_job_command 28 /* designate a starting token (\&{everyjob}) */
4556 @d delimiters 29 /* define a pair of delimiters (\&{delimiters}) */
4557 @d special_command 30 /* output special info (\&{special})
4558 or font map info (\&{fontmapfile}, \&{fontmapline}) */
4559 @d write_command 31 /* write text to a file (\&{write}) */
4560 @d type_name 32 /* declare a type (\&{numeric}, \&{pair}, etc.) */
4561 @d max_statement_command type_name
4562 @d min_primary_command type_name
4563 @d left_delimiter 33 /* the left delimiter of a matching pair */
4564 @d begin_group 34 /* beginning of a group (\&{begingroup}) */
4565 @d nullary 35 /* an operator without arguments (e.g., \&{normaldeviate}) */
4566 @d unary 36 /* an operator with one argument (e.g., \&{sqrt}) */
4567 @d str_op 37 /* convert a suffix to a string (\&{str}) */
4568 @d cycle 38 /* close a cyclic path (\&{cycle}) */
4569 @d primary_binary 39 /* binary operation taking `\&{of}' (e.g., \&{point}) */
4570 @d capsule_token 40 /* a value that has been put into a token list */
4571 @d string_token 41 /* a string constant (e.g., |"hello"|) */
4572 @d internal_quantity 42 /* internal numeric parameter (e.g., \&{pausing}) */
4573 @d min_suffix_token internal_quantity
4574 @d tag_token 43 /* a symbolic token without a primitive meaning */
4575 @d numeric_token 44 /* a numeric constant (e.g., \.{3.14159}) */
4576 @d max_suffix_token numeric_token
4577 @d plus_or_minus 45 /* either `\.+' or `\.-' */
4578 @d max_primary_command plus_or_minus /* should also be |numeric_token+1| */
4579 @d min_tertiary_command plus_or_minus
4580 @d tertiary_secondary_macro 46 /* a macro defined by \&{secondarydef} */
4581 @d tertiary_binary 47 /* an operator at the tertiary level (e.g., `\.{++}') */
4582 @d max_tertiary_command tertiary_binary
4583 @d left_brace 48 /* the operator `\.{\char`\{}' */
4584 @d min_expression_command left_brace
4585 @d path_join 49 /* the operator `\.{..}' */
4586 @d ampersand 50 /* the operator `\.\&' */
4587 @d expression_tertiary_macro 51 /* a macro defined by \&{tertiarydef} */
4588 @d expression_binary 52 /* an operator at the expression level (e.g., `\.<') */
4589 @d equals 53 /* the operator `\.=' */
4590 @d max_expression_command equals
4591 @d and_command 54 /* the operator `\&{and}' */
4592 @d min_secondary_command and_command
4593 @d secondary_primary_macro 55 /* a macro defined by \&{primarydef} */
4594 @d slash 56 /* the operator `\./' */
4595 @d secondary_binary 57 /* an operator at the binary level (e.g., \&{shifted}) */
4596 @d max_secondary_command secondary_binary
4597 @d param_type 58 /* type of parameter (\&{primary}, \&{expr}, \&{suffix}, etc.) */
4598 @d controls 59 /* specify control points explicitly (\&{controls}) */
4599 @d tension 60 /* specify tension between knots (\&{tension}) */
4600 @d at_least 61 /* bounded tension value (\&{atleast}) */
4601 @d curl_command 62 /* specify curl at an end knot (\&{curl}) */
4602 @d macro_special 63 /* special macro operators (\&{quote}, \.{\#\AT!}, etc.) */
4603 @d right_delimiter 64 /* the right delimiter of a matching pair */
4604 @d left_bracket 65 /* the operator `\.[' */
4605 @d right_bracket 66 /* the operator `\.]' */
4606 @d right_brace 67 /* the operator `\.{\char`\}}' */
4607 @d with_option 68 /* option for filling (\&{withpen}, \&{withweight}, etc.) */
4609 /* variant of \&{addto} (\&{contour}, \&{doublepath}, \&{also}) */
4610 @d of_token 70 /* the operator `\&{of}' */
4611 @d to_token 71 /* the operator `\&{to}' */
4612 @d step_token 72 /* the operator `\&{step}' */
4613 @d until_token 73 /* the operator `\&{until}' */
4614 @d within_token 74 /* the operator `\&{within}' */
4615 @d lig_kern_token 75
4616 /* the operators `\&{kern}' and `\.{=:}' and `\.{=:\char'174}', etc. */
4617 @d assignment 76 /* the operator `\.{:=}' */
4618 @d skip_to 77 /* the operation `\&{skipto}' */
4619 @d bchar_label 78 /* the operator `\.{\char'174\char'174:}' */
4620 @d double_colon 79 /* the operator `\.{::}' */
4621 @d colon 80 /* the operator `\.:' */
4623 @d comma 81 /* the operator `\.,', must be |colon+1| */
4624 @d end_of_statement (mp->cur_cmd>comma)
4625 @d semicolon 82 /* the operator `\.;', must be |comma+1| */
4626 @d end_group 83 /* end a group (\&{endgroup}), must be |semicolon+1| */
4627 @d stop 84 /* end a job (\&{end}, \&{dump}), must be |end_group+1| */
4628 @d max_command_code stop
4629 @d outer_tag (max_command_code+1) /* protection code added to command code */
4632 typedef int command_code;
4634 @ Variables and capsules in \MP\ have a variety of ``types,''
4635 distinguished by the code numbers defined here. These numbers are also
4636 not completely arbitrary. Things that get expanded must have types
4637 |>mp_independent|; a type remaining after expansion is numeric if and only if
4638 its code number is at least |numeric_type|; objects containing numeric
4639 parts must have types between |transform_type| and |pair_type|;
4640 all other types must be smaller than |transform_type|; and among the types
4641 that are not unknown or vacuous, the smallest two must be |boolean_type|
4642 and |string_type| in that order.
4644 @d undefined 0 /* no type has been declared */
4645 @d unknown_tag 1 /* this constant is added to certain type codes below */
4646 @d unknown_types mp_unknown_boolean: case mp_unknown_string:
4647 case mp_unknown_pen: case mp_unknown_picture: case mp_unknown_path
4650 enum mp_variable_type {
4651 mp_vacuous=1, /* no expression was present */
4652 mp_boolean_type, /* \&{boolean} with a known value */
4654 mp_string_type, /* \&{string} with a known value */
4656 mp_pen_type, /* \&{pen} with a known value */
4658 mp_path_type, /* \&{path} with a known value */
4660 mp_picture_type, /* \&{picture} with a known value */
4662 mp_transform_type, /* \&{transform} variable or capsule */
4663 mp_color_type, /* \&{color} variable or capsule */
4664 mp_cmykcolor_type, /* \&{cmykcolor} variable or capsule */
4665 mp_pair_type, /* \&{pair} variable or capsule */
4666 mp_numeric_type, /* variable that has been declared \&{numeric} but not used */
4667 mp_known, /* \&{numeric} with a known value */
4668 mp_dependent, /* a linear combination with |fraction| coefficients */
4669 mp_proto_dependent, /* a linear combination with |scaled| coefficients */
4670 mp_independent, /* \&{numeric} with unknown value */
4671 mp_token_list, /* variable name or suffix argument or text argument */
4672 mp_structured, /* variable with subscripts and attributes */
4673 mp_unsuffixed_macro, /* variable defined with \&{vardef} but no \.{\AT!\#} */
4674 mp_suffixed_macro /* variable defined with \&{vardef} and \.{\AT!\#} */
4678 void mp_print_type (MP mp,small_number t) ;
4680 @ @<Basic printing procedures@>=
4681 void mp_print_type (MP mp,small_number t) {
4683 case mp_vacuous:mp_print(mp, "mp_vacuous"); break;
4684 case mp_boolean_type:mp_print(mp, "boolean"); break;
4685 case mp_unknown_boolean:mp_print(mp, "unknown boolean"); break;
4686 case mp_string_type:mp_print(mp, "string"); break;
4687 case mp_unknown_string:mp_print(mp, "unknown string"); break;
4688 case mp_pen_type:mp_print(mp, "pen"); break;
4689 case mp_unknown_pen:mp_print(mp, "unknown pen"); break;
4690 case mp_path_type:mp_print(mp, "path"); break;
4691 case mp_unknown_path:mp_print(mp, "unknown path"); break;
4692 case mp_picture_type:mp_print(mp, "picture"); break;
4693 case mp_unknown_picture:mp_print(mp, "unknown picture"); break;
4694 case mp_transform_type:mp_print(mp, "transform"); break;
4695 case mp_color_type:mp_print(mp, "color"); break;
4696 case mp_cmykcolor_type:mp_print(mp, "cmykcolor"); break;
4697 case mp_pair_type:mp_print(mp, "pair"); break;
4698 case mp_known:mp_print(mp, "known numeric"); break;
4699 case mp_dependent:mp_print(mp, "dependent"); break;
4700 case mp_proto_dependent:mp_print(mp, "proto-dependent"); break;
4701 case mp_numeric_type:mp_print(mp, "numeric"); break;
4702 case mp_independent:mp_print(mp, "independent"); break;
4703 case mp_token_list:mp_print(mp, "token list"); break;
4704 case mp_structured:mp_print(mp, "mp_structured"); break;
4705 case mp_unsuffixed_macro:mp_print(mp, "unsuffixed macro"); break;
4706 case mp_suffixed_macro:mp_print(mp, "suffixed macro"); break;
4707 default: mp_print(mp, "undefined"); break;
4711 @ Values inside \MP\ are stored in two-word nodes that have a |name_type|
4712 as well as a |type|. The possibilities for |name_type| are defined
4713 here; they will be explained in more detail later.
4717 mp_root=0, /* |name_type| at the top level of a variable */
4718 mp_saved_root, /* same, when the variable has been saved */
4719 mp_structured_root, /* |name_type| where a |mp_structured| branch occurs */
4720 mp_subscr, /* |name_type| in a subscript node */
4721 mp_attr, /* |name_type| in an attribute node */
4722 mp_x_part_sector, /* |name_type| in the \&{xpart} of a node */
4723 mp_y_part_sector, /* |name_type| in the \&{ypart} of a node */
4724 mp_xx_part_sector, /* |name_type| in the \&{xxpart} of a node */
4725 mp_xy_part_sector, /* |name_type| in the \&{xypart} of a node */
4726 mp_yx_part_sector, /* |name_type| in the \&{yxpart} of a node */
4727 mp_yy_part_sector, /* |name_type| in the \&{yypart} of a node */
4728 mp_red_part_sector, /* |name_type| in the \&{redpart} of a node */
4729 mp_green_part_sector, /* |name_type| in the \&{greenpart} of a node */
4730 mp_blue_part_sector, /* |name_type| in the \&{bluepart} of a node */
4731 mp_cyan_part_sector, /* |name_type| in the \&{redpart} of a node */
4732 mp_magenta_part_sector, /* |name_type| in the \&{greenpart} of a node */
4733 mp_yellow_part_sector, /* |name_type| in the \&{bluepart} of a node */
4734 mp_black_part_sector, /* |name_type| in the \&{greenpart} of a node */
4735 mp_grey_part_sector, /* |name_type| in the \&{bluepart} of a node */
4736 mp_capsule, /* |name_type| in stashed-away subexpressions */
4737 mp_token /* |name_type| in a numeric token or string token */
4740 @ Primitive operations that produce values have a secondary identification
4741 code in addition to their command code; it's something like genera and species.
4742 For example, `\.*' has the command code |primary_binary|, and its
4743 secondary identification is |times|. The secondary codes start at 30 so that
4744 they don't overlap with the type codes; some type codes (e.g., |mp_string_type|)
4745 are used as operators as well as type identifications. The relative values
4746 are not critical, except for |true_code..false_code|, |or_op..and_op|,
4747 and |filled_op..bounded_op|. The restrictions are that
4748 |and_op-false_code=or_op-true_code|, that the ordering of
4749 |x_part...blue_part| must match that of |x_part_sector..mp_blue_part_sector|,
4750 and the ordering of |filled_op..bounded_op| must match that of the code
4751 values they test for.
4753 @d true_code 30 /* operation code for \.{true} */
4754 @d false_code 31 /* operation code for \.{false} */
4755 @d null_picture_code 32 /* operation code for \.{nullpicture} */
4756 @d null_pen_code 33 /* operation code for \.{nullpen} */
4757 @d job_name_op 34 /* operation code for \.{jobname} */
4758 @d read_string_op 35 /* operation code for \.{readstring} */
4759 @d pen_circle 36 /* operation code for \.{pencircle} */
4760 @d normal_deviate 37 /* operation code for \.{normaldeviate} */
4761 @d read_from_op 38 /* operation code for \.{readfrom} */
4762 @d close_from_op 39 /* operation code for \.{closefrom} */
4763 @d odd_op 40 /* operation code for \.{odd} */
4764 @d known_op 41 /* operation code for \.{known} */
4765 @d unknown_op 42 /* operation code for \.{unknown} */
4766 @d not_op 43 /* operation code for \.{not} */
4767 @d decimal 44 /* operation code for \.{decimal} */
4768 @d reverse 45 /* operation code for \.{reverse} */
4769 @d make_path_op 46 /* operation code for \.{makepath} */
4770 @d make_pen_op 47 /* operation code for \.{makepen} */
4771 @d oct_op 48 /* operation code for \.{oct} */
4772 @d hex_op 49 /* operation code for \.{hex} */
4773 @d ASCII_op 50 /* operation code for \.{ASCII} */
4774 @d char_op 51 /* operation code for \.{char} */
4775 @d length_op 52 /* operation code for \.{length} */
4776 @d turning_op 53 /* operation code for \.{turningnumber} */
4777 @d color_model_part 54 /* operation code for \.{colormodel} */
4778 @d x_part 55 /* operation code for \.{xpart} */
4779 @d y_part 56 /* operation code for \.{ypart} */
4780 @d xx_part 57 /* operation code for \.{xxpart} */
4781 @d xy_part 58 /* operation code for \.{xypart} */
4782 @d yx_part 59 /* operation code for \.{yxpart} */
4783 @d yy_part 60 /* operation code for \.{yypart} */
4784 @d red_part 61 /* operation code for \.{redpart} */
4785 @d green_part 62 /* operation code for \.{greenpart} */
4786 @d blue_part 63 /* operation code for \.{bluepart} */
4787 @d cyan_part 64 /* operation code for \.{cyanpart} */
4788 @d magenta_part 65 /* operation code for \.{magentapart} */
4789 @d yellow_part 66 /* operation code for \.{yellowpart} */
4790 @d black_part 67 /* operation code for \.{blackpart} */
4791 @d grey_part 68 /* operation code for \.{greypart} */
4792 @d font_part 69 /* operation code for \.{fontpart} */
4793 @d text_part 70 /* operation code for \.{textpart} */
4794 @d path_part 71 /* operation code for \.{pathpart} */
4795 @d pen_part 72 /* operation code for \.{penpart} */
4796 @d dash_part 73 /* operation code for \.{dashpart} */
4797 @d sqrt_op 74 /* operation code for \.{sqrt} */
4798 @d m_exp_op 75 /* operation code for \.{mexp} */
4799 @d m_log_op 76 /* operation code for \.{mlog} */
4800 @d sin_d_op 77 /* operation code for \.{sind} */
4801 @d cos_d_op 78 /* operation code for \.{cosd} */
4802 @d floor_op 79 /* operation code for \.{floor} */
4803 @d uniform_deviate 80 /* operation code for \.{uniformdeviate} */
4804 @d char_exists_op 81 /* operation code for \.{charexists} */
4805 @d font_size 82 /* operation code for \.{fontsize} */
4806 @d ll_corner_op 83 /* operation code for \.{llcorner} */
4807 @d lr_corner_op 84 /* operation code for \.{lrcorner} */
4808 @d ul_corner_op 85 /* operation code for \.{ulcorner} */
4809 @d ur_corner_op 86 /* operation code for \.{urcorner} */
4810 @d arc_length 87 /* operation code for \.{arclength} */
4811 @d angle_op 88 /* operation code for \.{angle} */
4812 @d cycle_op 89 /* operation code for \.{cycle} */
4813 @d filled_op 90 /* operation code for \.{filled} */
4814 @d stroked_op 91 /* operation code for \.{stroked} */
4815 @d textual_op 92 /* operation code for \.{textual} */
4816 @d clipped_op 93 /* operation code for \.{clipped} */
4817 @d bounded_op 94 /* operation code for \.{bounded} */
4818 @d plus 95 /* operation code for \.+ */
4819 @d minus 96 /* operation code for \.- */
4820 @d times 97 /* operation code for \.* */
4821 @d over 98 /* operation code for \./ */
4822 @d pythag_add 99 /* operation code for \.{++} */
4823 @d pythag_sub 100 /* operation code for \.{+-+} */
4824 @d or_op 101 /* operation code for \.{or} */
4825 @d and_op 102 /* operation code for \.{and} */
4826 @d less_than 103 /* operation code for \.< */
4827 @d less_or_equal 104 /* operation code for \.{<=} */
4828 @d greater_than 105 /* operation code for \.> */
4829 @d greater_or_equal 106 /* operation code for \.{>=} */
4830 @d equal_to 107 /* operation code for \.= */
4831 @d unequal_to 108 /* operation code for \.{<>} */
4832 @d concatenate 109 /* operation code for \.\& */
4833 @d rotated_by 110 /* operation code for \.{rotated} */
4834 @d slanted_by 111 /* operation code for \.{slanted} */
4835 @d scaled_by 112 /* operation code for \.{scaled} */
4836 @d shifted_by 113 /* operation code for \.{shifted} */
4837 @d transformed_by 114 /* operation code for \.{transformed} */
4838 @d x_scaled 115 /* operation code for \.{xscaled} */
4839 @d y_scaled 116 /* operation code for \.{yscaled} */
4840 @d z_scaled 117 /* operation code for \.{zscaled} */
4841 @d in_font 118 /* operation code for \.{infont} */
4842 @d intersect 119 /* operation code for \.{intersectiontimes} */
4843 @d double_dot 120 /* operation code for improper \.{..} */
4844 @d substring_of 121 /* operation code for \.{substring} */
4845 @d min_of substring_of
4846 @d subpath_of 122 /* operation code for \.{subpath} */
4847 @d direction_time_of 123 /* operation code for \.{directiontime} */
4848 @d point_of 124 /* operation code for \.{point} */
4849 @d precontrol_of 125 /* operation code for \.{precontrol} */
4850 @d postcontrol_of 126 /* operation code for \.{postcontrol} */
4851 @d pen_offset_of 127 /* operation code for \.{penoffset} */
4852 @d arc_time_of 128 /* operation code for \.{arctime} */
4853 @d mp_version 129 /* operation code for \.{mpversion} */
4854 @d envelope_of 130 /* operation code for \.{envelope} */
4856 @c void mp_print_op (MP mp,quarterword c) {
4857 if (c<=mp_numeric_type ) {
4858 mp_print_type(mp, c);
4861 case true_code:mp_print(mp, "true"); break;
4862 case false_code:mp_print(mp, "false"); break;
4863 case null_picture_code:mp_print(mp, "nullpicture"); break;
4864 case null_pen_code:mp_print(mp, "nullpen"); break;
4865 case job_name_op:mp_print(mp, "jobname"); break;
4866 case read_string_op:mp_print(mp, "readstring"); break;
4867 case pen_circle:mp_print(mp, "pencircle"); break;
4868 case normal_deviate:mp_print(mp, "normaldeviate"); break;
4869 case read_from_op:mp_print(mp, "readfrom"); break;
4870 case close_from_op:mp_print(mp, "closefrom"); break;
4871 case odd_op:mp_print(mp, "odd"); break;
4872 case known_op:mp_print(mp, "known"); break;
4873 case unknown_op:mp_print(mp, "unknown"); break;
4874 case not_op:mp_print(mp, "not"); break;
4875 case decimal:mp_print(mp, "decimal"); break;
4876 case reverse:mp_print(mp, "reverse"); break;
4877 case make_path_op:mp_print(mp, "makepath"); break;
4878 case make_pen_op:mp_print(mp, "makepen"); break;
4879 case oct_op:mp_print(mp, "oct"); break;
4880 case hex_op:mp_print(mp, "hex"); break;
4881 case ASCII_op:mp_print(mp, "ASCII"); break;
4882 case char_op:mp_print(mp, "char"); break;
4883 case length_op:mp_print(mp, "length"); break;
4884 case turning_op:mp_print(mp, "turningnumber"); break;
4885 case x_part:mp_print(mp, "xpart"); break;
4886 case y_part:mp_print(mp, "ypart"); break;
4887 case xx_part:mp_print(mp, "xxpart"); break;
4888 case xy_part:mp_print(mp, "xypart"); break;
4889 case yx_part:mp_print(mp, "yxpart"); break;
4890 case yy_part:mp_print(mp, "yypart"); break;
4891 case red_part:mp_print(mp, "redpart"); break;
4892 case green_part:mp_print(mp, "greenpart"); break;
4893 case blue_part:mp_print(mp, "bluepart"); break;
4894 case cyan_part:mp_print(mp, "cyanpart"); break;
4895 case magenta_part:mp_print(mp, "magentapart"); break;
4896 case yellow_part:mp_print(mp, "yellowpart"); break;
4897 case black_part:mp_print(mp, "blackpart"); break;
4898 case grey_part:mp_print(mp, "greypart"); break;
4899 case color_model_part:mp_print(mp, "colormodel"); break;
4900 case font_part:mp_print(mp, "fontpart"); break;
4901 case text_part:mp_print(mp, "textpart"); break;
4902 case path_part:mp_print(mp, "pathpart"); break;
4903 case pen_part:mp_print(mp, "penpart"); break;
4904 case dash_part:mp_print(mp, "dashpart"); break;
4905 case sqrt_op:mp_print(mp, "sqrt"); break;
4906 case m_exp_op:mp_print(mp, "mexp"); break;
4907 case m_log_op:mp_print(mp, "mlog"); break;
4908 case sin_d_op:mp_print(mp, "sind"); break;
4909 case cos_d_op:mp_print(mp, "cosd"); break;
4910 case floor_op:mp_print(mp, "floor"); break;
4911 case uniform_deviate:mp_print(mp, "uniformdeviate"); break;
4912 case char_exists_op:mp_print(mp, "charexists"); break;
4913 case font_size:mp_print(mp, "fontsize"); break;
4914 case ll_corner_op:mp_print(mp, "llcorner"); break;
4915 case lr_corner_op:mp_print(mp, "lrcorner"); break;
4916 case ul_corner_op:mp_print(mp, "ulcorner"); break;
4917 case ur_corner_op:mp_print(mp, "urcorner"); break;
4918 case arc_length:mp_print(mp, "arclength"); break;
4919 case angle_op:mp_print(mp, "angle"); break;
4920 case cycle_op:mp_print(mp, "cycle"); break;
4921 case filled_op:mp_print(mp, "filled"); break;
4922 case stroked_op:mp_print(mp, "stroked"); break;
4923 case textual_op:mp_print(mp, "textual"); break;
4924 case clipped_op:mp_print(mp, "clipped"); break;
4925 case bounded_op:mp_print(mp, "bounded"); break;
4926 case plus:mp_print_char(mp, '+'); break;
4927 case minus:mp_print_char(mp, '-'); break;
4928 case times:mp_print_char(mp, '*'); break;
4929 case over:mp_print_char(mp, '/'); break;
4930 case pythag_add:mp_print(mp, "++"); break;
4931 case pythag_sub:mp_print(mp, "+-+"); break;
4932 case or_op:mp_print(mp, "or"); break;
4933 case and_op:mp_print(mp, "and"); break;
4934 case less_than:mp_print_char(mp, '<'); break;
4935 case less_or_equal:mp_print(mp, "<="); break;
4936 case greater_than:mp_print_char(mp, '>'); break;
4937 case greater_or_equal:mp_print(mp, ">="); break;
4938 case equal_to:mp_print_char(mp, '='); break;
4939 case unequal_to:mp_print(mp, "<>"); break;
4940 case concatenate:mp_print(mp, "&"); break;
4941 case rotated_by:mp_print(mp, "rotated"); break;
4942 case slanted_by:mp_print(mp, "slanted"); break;
4943 case scaled_by:mp_print(mp, "scaled"); break;
4944 case shifted_by:mp_print(mp, "shifted"); break;
4945 case transformed_by:mp_print(mp, "transformed"); break;
4946 case x_scaled:mp_print(mp, "xscaled"); break;
4947 case y_scaled:mp_print(mp, "yscaled"); break;
4948 case z_scaled:mp_print(mp, "zscaled"); break;
4949 case in_font:mp_print(mp, "infont"); break;
4950 case intersect:mp_print(mp, "intersectiontimes"); break;
4951 case substring_of:mp_print(mp, "substring"); break;
4952 case subpath_of:mp_print(mp, "subpath"); break;
4953 case direction_time_of:mp_print(mp, "directiontime"); break;
4954 case point_of:mp_print(mp, "point"); break;
4955 case precontrol_of:mp_print(mp, "precontrol"); break;
4956 case postcontrol_of:mp_print(mp, "postcontrol"); break;
4957 case pen_offset_of:mp_print(mp, "penoffset"); break;
4958 case arc_time_of:mp_print(mp, "arctime"); break;
4959 case mp_version:mp_print(mp, "mpversion"); break;
4960 case envelope_of:mp_print(mp, "envelope"); break;
4961 default: mp_print(mp, ".."); break;
4966 @ \MP\ also has a bunch of internal parameters that a user might want to
4967 fuss with. Every such parameter has an identifying code number, defined here.
4970 enum mp_given_internal {
4971 mp_tracing_titles=1, /* show titles online when they appear */
4972 mp_tracing_equations, /* show each variable when it becomes known */
4973 mp_tracing_capsules, /* show capsules too */
4974 mp_tracing_choices, /* show the control points chosen for paths */
4975 mp_tracing_specs, /* show path subdivision prior to filling with polygonal a pen */
4976 mp_tracing_commands, /* show commands and operations before they are performed */
4977 mp_tracing_restores, /* show when a variable or internal is restored */
4978 mp_tracing_macros, /* show macros before they are expanded */
4979 mp_tracing_output, /* show digitized edges as they are output */
4980 mp_tracing_stats, /* show memory usage at end of job */
4981 mp_tracing_lost_chars, /* show characters that aren't \&{infont} */
4982 mp_tracing_online, /* show long diagnostics on terminal and in the log file */
4983 mp_year, /* the current year (e.g., 1984) */
4984 mp_month, /* the current month (e.g., 3 $\equiv$ March) */
4985 mp_day, /* the current day of the month */
4986 mp_time, /* the number of minutes past midnight when this job started */
4987 mp_char_code, /* the number of the next character to be output */
4988 mp_char_ext, /* the extension code of the next character to be output */
4989 mp_char_wd, /* the width of the next character to be output */
4990 mp_char_ht, /* the height of the next character to be output */
4991 mp_char_dp, /* the depth of the next character to be output */
4992 mp_char_ic, /* the italic correction of the next character to be output */
4993 mp_design_size, /* the unit of measure used for |mp_char_wd..mp_char_ic|, in points */
4994 mp_pausing, /* positive to display lines on the terminal before they are read */
4995 mp_showstopping, /* positive to stop after each \&{show} command */
4996 mp_fontmaking, /* positive if font metric output is to be produced */
4997 mp_linejoin, /* as in \ps: 0 for mitered, 1 for round, 2 for beveled */
4998 mp_linecap, /* as in \ps: 0 for butt, 1 for round, 2 for square */
4999 mp_miterlimit, /* controls miter length as in \ps */
5000 mp_warning_check, /* controls error message when variable value is large */
5001 mp_boundary_char, /* the right boundary character for ligatures */
5002 mp_prologues, /* positive to output conforming PostScript using built-in fonts */
5003 mp_true_corners, /* positive to make \&{llcorner} etc. ignore \&{setbounds} */
5004 mp_default_color_model, /* the default color model for unspecified items */
5005 mp_restore_clip_color,
5006 mp_procset, /* wether or not create PostScript command shortcuts */
5007 mp_gtroffmode /* whether the user specified |-troff| on the command line */
5012 @d max_given_internal mp_gtroffmode
5015 scaled *internal; /* the values of internal quantities */
5016 char **int_name; /* their names */
5017 int int_ptr; /* the maximum internal quantity defined so far */
5018 int max_internal; /* current maximum number of internal quantities */
5020 @ @<Option variables@>=
5023 @ @<Allocate or initialize ...@>=
5024 mp->max_internal=2*max_given_internal;
5025 mp->internal = xmalloc ((mp->max_internal+1), sizeof(scaled));
5026 memset(mp->internal,0,(mp->max_internal+1)* sizeof(scaled));
5027 mp->int_name = xmalloc ((mp->max_internal+1), sizeof(char *));
5028 memset(mp->int_name,0,(mp->max_internal+1) * sizeof(char *));
5029 mp->troff_mode=(opt->troff_mode>0 ? true : false);
5031 @ @<Exported function ...@>=
5032 int mp_troff_mode(MP mp);
5035 int mp_troff_mode(MP mp) { return mp->troff_mode; }
5037 @ @<Set initial ...@>=
5038 mp->int_ptr=max_given_internal;
5040 @ The symbolic names for internal quantities are put into \MP's hash table
5041 by using a routine called |primitive|, which will be defined later. Let us
5042 enter them now, so that we don't have to list all those names again
5045 @<Put each of \MP's primitives into the hash table@>=
5046 mp_primitive(mp, "tracingtitles",internal_quantity,mp_tracing_titles);
5047 @:tracingtitles_}{\&{tracingtitles} primitive@>
5048 mp_primitive(mp, "tracingequations",internal_quantity,mp_tracing_equations);
5049 @:mp_tracing_equations_}{\&{tracingequations} primitive@>
5050 mp_primitive(mp, "tracingcapsules",internal_quantity,mp_tracing_capsules);
5051 @:mp_tracing_capsules_}{\&{tracingcapsules} primitive@>
5052 mp_primitive(mp, "tracingchoices",internal_quantity,mp_tracing_choices);
5053 @:mp_tracing_choices_}{\&{tracingchoices} primitive@>
5054 mp_primitive(mp, "tracingspecs",internal_quantity,mp_tracing_specs);
5055 @:mp_tracing_specs_}{\&{tracingspecs} primitive@>
5056 mp_primitive(mp, "tracingcommands",internal_quantity,mp_tracing_commands);
5057 @:mp_tracing_commands_}{\&{tracingcommands} primitive@>
5058 mp_primitive(mp, "tracingrestores",internal_quantity,mp_tracing_restores);
5059 @:mp_tracing_restores_}{\&{tracingrestores} primitive@>
5060 mp_primitive(mp, "tracingmacros",internal_quantity,mp_tracing_macros);
5061 @:mp_tracing_macros_}{\&{tracingmacros} primitive@>
5062 mp_primitive(mp, "tracingoutput",internal_quantity,mp_tracing_output);
5063 @:mp_tracing_output_}{\&{tracingoutput} primitive@>
5064 mp_primitive(mp, "tracingstats",internal_quantity,mp_tracing_stats);
5065 @:mp_tracing_stats_}{\&{tracingstats} primitive@>
5066 mp_primitive(mp, "tracinglostchars",internal_quantity,mp_tracing_lost_chars);
5067 @:mp_tracing_lost_chars_}{\&{tracinglostchars} primitive@>
5068 mp_primitive(mp, "tracingonline",internal_quantity,mp_tracing_online);
5069 @:mp_tracing_online_}{\&{tracingonline} primitive@>
5070 mp_primitive(mp, "year",internal_quantity,mp_year);
5071 @:mp_year_}{\&{year} primitive@>
5072 mp_primitive(mp, "month",internal_quantity,mp_month);
5073 @:mp_month_}{\&{month} primitive@>
5074 mp_primitive(mp, "day",internal_quantity,mp_day);
5075 @:mp_day_}{\&{day} primitive@>
5076 mp_primitive(mp, "time",internal_quantity,mp_time);
5077 @:time_}{\&{time} primitive@>
5078 mp_primitive(mp, "charcode",internal_quantity,mp_char_code);
5079 @:mp_char_code_}{\&{charcode} primitive@>
5080 mp_primitive(mp, "charext",internal_quantity,mp_char_ext);
5081 @:mp_char_ext_}{\&{charext} primitive@>
5082 mp_primitive(mp, "charwd",internal_quantity,mp_char_wd);
5083 @:mp_char_wd_}{\&{charwd} primitive@>
5084 mp_primitive(mp, "charht",internal_quantity,mp_char_ht);
5085 @:mp_char_ht_}{\&{charht} primitive@>
5086 mp_primitive(mp, "chardp",internal_quantity,mp_char_dp);
5087 @:mp_char_dp_}{\&{chardp} primitive@>
5088 mp_primitive(mp, "charic",internal_quantity,mp_char_ic);
5089 @:mp_char_ic_}{\&{charic} primitive@>
5090 mp_primitive(mp, "designsize",internal_quantity,mp_design_size);
5091 @:mp_design_size_}{\&{designsize} primitive@>
5092 mp_primitive(mp, "pausing",internal_quantity,mp_pausing);
5093 @:mp_pausing_}{\&{pausing} primitive@>
5094 mp_primitive(mp, "showstopping",internal_quantity,mp_showstopping);
5095 @:mp_showstopping_}{\&{showstopping} primitive@>
5096 mp_primitive(mp, "fontmaking",internal_quantity,mp_fontmaking);
5097 @:mp_fontmaking_}{\&{fontmaking} primitive@>
5098 mp_primitive(mp, "linejoin",internal_quantity,mp_linejoin);
5099 @:mp_linejoin_}{\&{linejoin} primitive@>
5100 mp_primitive(mp, "linecap",internal_quantity,mp_linecap);
5101 @:mp_linecap_}{\&{linecap} primitive@>
5102 mp_primitive(mp, "miterlimit",internal_quantity,mp_miterlimit);
5103 @:mp_miterlimit_}{\&{miterlimit} primitive@>
5104 mp_primitive(mp, "warningcheck",internal_quantity,mp_warning_check);
5105 @:mp_warning_check_}{\&{warningcheck} primitive@>
5106 mp_primitive(mp, "boundarychar",internal_quantity,mp_boundary_char);
5107 @:mp_boundary_char_}{\&{boundarychar} primitive@>
5108 mp_primitive(mp, "prologues",internal_quantity,mp_prologues);
5109 @:mp_prologues_}{\&{prologues} primitive@>
5110 mp_primitive(mp, "truecorners",internal_quantity,mp_true_corners);
5111 @:mp_true_corners_}{\&{truecorners} primitive@>
5112 mp_primitive(mp, "mpprocset",internal_quantity,mp_procset);
5113 @:mp_procset_}{\&{mpprocset} primitive@>
5114 mp_primitive(mp, "troffmode",internal_quantity,mp_gtroffmode);
5115 @:troffmode_}{\&{troffmode} primitive@>
5116 mp_primitive(mp, "defaultcolormodel",internal_quantity,mp_default_color_model);
5117 @:mp_default_color_model_}{\&{defaultcolormodel} primitive@>
5118 mp_primitive(mp, "restoreclipcolor",internal_quantity,mp_restore_clip_color);
5119 @:mp_restore_clip_color_}{\&{restoreclipcolor} primitive@>
5121 @ Colors can be specified in four color models. In the special
5122 case of |no_model|, MetaPost does not output any color operator to
5123 the postscript output.
5125 Note: these values are passed directly on to |with_option|. This only
5126 works because the other possible values passed to |with_option| are
5127 8 and 10 respectively (from |with_pen| and |with_picture|).
5129 There is a first state, that is only used for |gs_colormodel|. It flags
5130 the fact that there has not been any kind of color specification by
5131 the user so far in the game.
5134 enum mp_color_model {
5139 mp_uninitialized_model=9
5143 @ @<Initialize table entries (done by \.{INIMP} only)@>=
5144 mp->internal[mp_default_color_model]=(mp_rgb_model*unity);
5145 mp->internal[mp_restore_clip_color]=unity;
5147 @ Well, we do have to list the names one more time, for use in symbolic
5150 @<Initialize table...@>=
5151 mp->int_name[mp_tracing_titles]=xstrdup("tracingtitles");
5152 mp->int_name[mp_tracing_equations]=xstrdup("tracingequations");
5153 mp->int_name[mp_tracing_capsules]=xstrdup("tracingcapsules");
5154 mp->int_name[mp_tracing_choices]=xstrdup("tracingchoices");
5155 mp->int_name[mp_tracing_specs]=xstrdup("tracingspecs");
5156 mp->int_name[mp_tracing_commands]=xstrdup("tracingcommands");
5157 mp->int_name[mp_tracing_restores]=xstrdup("tracingrestores");
5158 mp->int_name[mp_tracing_macros]=xstrdup("tracingmacros");
5159 mp->int_name[mp_tracing_output]=xstrdup("tracingoutput");
5160 mp->int_name[mp_tracing_stats]=xstrdup("tracingstats");
5161 mp->int_name[mp_tracing_lost_chars]=xstrdup("tracinglostchars");
5162 mp->int_name[mp_tracing_online]=xstrdup("tracingonline");
5163 mp->int_name[mp_year]=xstrdup("year");
5164 mp->int_name[mp_month]=xstrdup("month");
5165 mp->int_name[mp_day]=xstrdup("day");
5166 mp->int_name[mp_time]=xstrdup("time");
5167 mp->int_name[mp_char_code]=xstrdup("charcode");
5168 mp->int_name[mp_char_ext]=xstrdup("charext");
5169 mp->int_name[mp_char_wd]=xstrdup("charwd");
5170 mp->int_name[mp_char_ht]=xstrdup("charht");
5171 mp->int_name[mp_char_dp]=xstrdup("chardp");
5172 mp->int_name[mp_char_ic]=xstrdup("charic");
5173 mp->int_name[mp_design_size]=xstrdup("designsize");
5174 mp->int_name[mp_pausing]=xstrdup("pausing");
5175 mp->int_name[mp_showstopping]=xstrdup("showstopping");
5176 mp->int_name[mp_fontmaking]=xstrdup("fontmaking");
5177 mp->int_name[mp_linejoin]=xstrdup("linejoin");
5178 mp->int_name[mp_linecap]=xstrdup("linecap");
5179 mp->int_name[mp_miterlimit]=xstrdup("miterlimit");
5180 mp->int_name[mp_warning_check]=xstrdup("warningcheck");
5181 mp->int_name[mp_boundary_char]=xstrdup("boundarychar");
5182 mp->int_name[mp_prologues]=xstrdup("prologues");
5183 mp->int_name[mp_true_corners]=xstrdup("truecorners");
5184 mp->int_name[mp_default_color_model]=xstrdup("defaultcolormodel");
5185 mp->int_name[mp_procset]=xstrdup("mpprocset");
5186 mp->int_name[mp_gtroffmode]=xstrdup("troffmode");
5187 mp->int_name[mp_restore_clip_color]=xstrdup("restoreclipcolor");
5189 @ The following procedure, which is called just before \MP\ initializes its
5190 input and output, establishes the initial values of the date and time.
5191 @^system dependencies@>
5193 Note that the values are |scaled| integers. Hence \MP\ can no longer
5194 be used after the year 32767.
5197 void mp_fix_date_and_time (MP mp) {
5198 time_t aclock = time ((time_t *) 0);
5199 struct tm *tmptr = localtime (&aclock);
5200 mp->internal[mp_time]=
5201 (tmptr->tm_hour*60+tmptr->tm_min)*unity; /* minutes since midnight */
5202 mp->internal[mp_day]=(tmptr->tm_mday)*unity; /* fourth day of the month */
5203 mp->internal[mp_month]=(tmptr->tm_mon+1)*unity; /* seventh month of the year */
5204 mp->internal[mp_year]=(tmptr->tm_year+1900)*unity; /* Anno Domini */
5208 void mp_fix_date_and_time (MP mp) ;
5210 @ \MP\ is occasionally supposed to print diagnostic information that
5211 goes only into the transcript file, unless |mp_tracing_online| is positive.
5212 Now that we have defined |mp_tracing_online| we can define
5213 two routines that adjust the destination of print commands:
5216 void mp_begin_diagnostic (MP mp) ;
5217 void mp_end_diagnostic (MP mp,boolean blank_line);
5218 void mp_print_diagnostic (MP mp, const char *s, const char *t, boolean nuline) ;
5220 @ @<Basic printing...@>=
5221 @<Declare a function called |true_line|@>
5222 void mp_begin_diagnostic (MP mp) { /* prepare to do some tracing */
5223 mp->old_setting=mp->selector;
5224 if ((mp->internal[mp_tracing_online]<=0)&&(mp->selector==term_and_log)){
5226 if ( mp->history==mp_spotless ) mp->history=mp_warning_issued;
5230 void mp_end_diagnostic (MP mp,boolean blank_line) {
5231 /* restore proper conditions after tracing */
5232 mp_print_nl(mp, "");
5233 if ( blank_line ) mp_print_ln(mp);
5234 mp->selector=mp->old_setting;
5240 unsigned int old_setting;
5242 @ We will occasionally use |begin_diagnostic| in connection with line-number
5243 printing, as follows. (The parameter |s| is typically |"Path"| or
5244 |"Cycle spec"|, etc.)
5246 @<Basic printing...@>=
5247 void mp_print_diagnostic (MP mp, const char *s, const char *t, boolean nuline) {
5248 mp_begin_diagnostic(mp);
5249 if ( nuline ) mp_print_nl(mp, s); else mp_print(mp, s);
5250 mp_print(mp, " at line ");
5251 mp_print_int(mp, mp_true_line(mp));
5252 mp_print(mp, t); mp_print_char(mp, ':');
5255 @ The 256 |ASCII_code| characters are grouped into classes by means of
5256 the |char_class| table. Individual class numbers have no semantic
5257 or syntactic significance, except in a few instances defined here.
5258 There's also |max_class|, which can be used as a basis for additional
5259 class numbers in nonstandard extensions of \MP.
5261 @d digit_class 0 /* the class number of \.{0123456789} */
5262 @d period_class 1 /* the class number of `\..' */
5263 @d space_class 2 /* the class number of spaces and nonstandard characters */
5264 @d percent_class 3 /* the class number of `\.\%' */
5265 @d string_class 4 /* the class number of `\."' */
5266 @d right_paren_class 8 /* the class number of `\.)' */
5267 @d isolated_classes 5: case 6: case 7: case 8 /* characters that make length-one tokens only */
5268 @d letter_class 9 /* letters and the underline character */
5269 @d left_bracket_class 17 /* `\.[' */
5270 @d right_bracket_class 18 /* `\.]' */
5271 @d invalid_class 20 /* bad character in the input */
5272 @d max_class 20 /* the largest class number */
5275 int char_class[256]; /* the class numbers */
5277 @ If changes are made to accommodate non-ASCII character sets, they should
5278 follow the guidelines in Appendix~C of {\sl The {\logos METAFONT\/}book}.
5279 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
5280 @^system dependencies@>
5282 @<Set initial ...@>=
5283 for (k='0';k<='9';k++)
5284 mp->char_class[k]=digit_class;
5285 mp->char_class['.']=period_class;
5286 mp->char_class[' ']=space_class;
5287 mp->char_class['%']=percent_class;
5288 mp->char_class['"']=string_class;
5289 mp->char_class[',']=5;
5290 mp->char_class[';']=6;
5291 mp->char_class['(']=7;
5292 mp->char_class[')']=right_paren_class;
5293 for (k='A';k<= 'Z';k++ )
5294 mp->char_class[k]=letter_class;
5295 for (k='a';k<='z';k++)
5296 mp->char_class[k]=letter_class;
5297 mp->char_class['_']=letter_class;
5298 mp->char_class['<']=10;
5299 mp->char_class['=']=10;
5300 mp->char_class['>']=10;
5301 mp->char_class[':']=10;
5302 mp->char_class['|']=10;
5303 mp->char_class['`']=11;
5304 mp->char_class['\'']=11;
5305 mp->char_class['+']=12;
5306 mp->char_class['-']=12;
5307 mp->char_class['/']=13;
5308 mp->char_class['*']=13;
5309 mp->char_class['\\']=13;
5310 mp->char_class['!']=14;
5311 mp->char_class['?']=14;
5312 mp->char_class['#']=15;
5313 mp->char_class['&']=15;
5314 mp->char_class['@@']=15;
5315 mp->char_class['$']=15;
5316 mp->char_class['^']=16;
5317 mp->char_class['~']=16;
5318 mp->char_class['[']=left_bracket_class;
5319 mp->char_class[']']=right_bracket_class;
5320 mp->char_class['{']=19;
5321 mp->char_class['}']=19;
5323 mp->char_class[k]=invalid_class;
5324 mp->char_class['\t']=space_class;
5325 mp->char_class['\f']=space_class;
5326 for (k=127;k<=255;k++)
5327 mp->char_class[k]=invalid_class;
5329 @* \[13] The hash table.
5330 Symbolic tokens are stored and retrieved by means of a fairly standard hash
5331 table algorithm called the method of ``coalescing lists'' (cf.\ Algorithm 6.4C
5332 in {\sl The Art of Computer Programming\/}). Once a symbolic token enters the
5333 table, it is never removed.
5335 The actual sequence of characters forming a symbolic token is
5336 stored in the |str_pool| array together with all the other strings. An
5337 auxiliary array |hash| consists of items with two halfword fields per
5338 word. The first of these, called |next(p)|, points to the next identifier
5339 belonging to the same coalesced list as the identifier corresponding to~|p|;
5340 and the other, called |text(p)|, points to the |str_start| entry for
5341 |p|'s identifier. If position~|p| of the hash table is empty, we have
5342 |text(p)=0|; if position |p| is either empty or the end of a coalesced
5343 hash list, we have |next(p)=0|.
5345 An auxiliary pointer variable called |hash_used| is maintained in such a
5346 way that all locations |p>=hash_used| are nonempty. The global variable
5347 |st_count| tells how many symbolic tokens have been defined, if statistics
5350 The first 256 locations of |hash| are reserved for symbols of length one.
5352 There's a parallel array called |eqtb| that contains the current equivalent
5353 values of each symbolic token. The entries of this array consist of
5354 two halfwords called |eq_type| (a command code) and |equiv| (a secondary
5355 piece of information that qualifies the |eq_type|).
5357 @d next(A) mp->hash[(A)].lh /* link for coalesced lists */
5358 @d text(A) mp->hash[(A)].rh /* string number for symbolic token name */
5359 @d eq_type(A) mp->eqtb[(A)].lh /* the current ``meaning'' of a symbolic token */
5360 @d equiv(A) mp->eqtb[(A)].rh /* parametric part of a token's meaning */
5361 @d hash_base 257 /* hashing actually starts here */
5362 @d hash_is_full (mp->hash_used==hash_base) /* are all positions occupied? */
5365 pointer hash_used; /* allocation pointer for |hash| */
5366 integer st_count; /* total number of known identifiers */
5368 @ Certain entries in the hash table are ``frozen'' and not redefinable,
5369 since they are used in error recovery.
5371 @d hash_top (hash_base+mp->hash_size) /* the first location of the frozen area */
5372 @d frozen_inaccessible hash_top /* |hash| location to protect the frozen area */
5373 @d frozen_repeat_loop (hash_top+1) /* |hash| location of a loop-repeat token */
5374 @d frozen_right_delimiter (hash_top+2) /* |hash| location of a permanent `\.)' */
5375 @d frozen_left_bracket (hash_top+3) /* |hash| location of a permanent `\.[' */
5376 @d frozen_slash (hash_top+4) /* |hash| location of a permanent `\./' */
5377 @d frozen_colon (hash_top+5) /* |hash| location of a permanent `\.:' */
5378 @d frozen_semicolon (hash_top+6) /* |hash| location of a permanent `\.;' */
5379 @d frozen_end_for (hash_top+7) /* |hash| location of a permanent \&{endfor} */
5380 @d frozen_end_def (hash_top+8) /* |hash| location of a permanent \&{enddef} */
5381 @d frozen_fi (hash_top+9) /* |hash| location of a permanent \&{fi} */
5382 @d frozen_end_group (hash_top+10) /* |hash| location of a permanent `\.{endgroup}' */
5383 @d frozen_etex (hash_top+11) /* |hash| location of a permanent \&{etex} */
5384 @d frozen_mpx_break (hash_top+12) /* |hash| location of a permanent \&{mpxbreak} */
5385 @d frozen_bad_vardef (hash_top+13) /* |hash| location of `\.{a bad variable}' */
5386 @d frozen_undefined (hash_top+14) /* |hash| location that never gets defined */
5387 @d hash_end (hash_top+14) /* the actual size of the |hash| and |eqtb| arrays */
5390 two_halves *hash; /* the hash table */
5391 two_halves *eqtb; /* the equivalents */
5393 @ @<Allocate or initialize ...@>=
5394 mp->hash = xmalloc((hash_end+1),sizeof(two_halves));
5395 mp->eqtb = xmalloc((hash_end+1),sizeof(two_halves));
5397 @ @<Dealloc variables@>=
5402 next(1)=0; text(1)=0; eq_type(1)=tag_token; equiv(1)=null;
5403 for (k=2;k<=hash_end;k++) {
5404 mp->hash[k]=mp->hash[1]; mp->eqtb[k]=mp->eqtb[1];
5407 @ @<Initialize table entries...@>=
5408 mp->hash_used=frozen_inaccessible; /* nothing is used */
5410 text(frozen_bad_vardef)=intern("a bad variable");
5411 text(frozen_etex)=intern("etex");
5412 text(frozen_mpx_break)=intern("mpxbreak");
5413 text(frozen_fi)=intern("fi");
5414 text(frozen_end_group)=intern("endgroup");
5415 text(frozen_end_def)=intern("enddef");
5416 text(frozen_end_for)=intern("endfor");
5417 text(frozen_semicolon)=intern(";");
5418 text(frozen_colon)=intern(":");
5419 text(frozen_slash)=intern("/");
5420 text(frozen_left_bracket)=intern("[");
5421 text(frozen_right_delimiter)=intern(")");
5422 text(frozen_inaccessible)=intern(" INACCESSIBLE");
5423 eq_type(frozen_right_delimiter)=right_delimiter;
5425 @ @<Check the ``constant'' values...@>=
5426 if ( hash_end+mp->max_internal>max_halfword ) mp->bad=17;
5428 @ Here is the subroutine that searches the hash table for an identifier
5429 that matches a given string of length~|l| appearing in |buffer[j..
5430 (j+l-1)]|. If the identifier is not found, it is inserted; hence it
5431 will always be found, and the corresponding hash table address
5435 pointer mp_id_lookup (MP mp,integer j, integer l) { /* search the hash table */
5436 integer h; /* hash code */
5437 pointer p; /* index in |hash| array */
5438 pointer k; /* index in |buffer| array */
5440 @<Treat special case of length 1 and |break|@>;
5442 @<Compute the hash code |h|@>;
5443 p=h+hash_base; /* we start searching here; note that |0<=h<hash_prime| */
5445 if (text(p)>0 && length(text(p))==l && mp_str_eq_buf(mp, text(p),j))
5448 @<Insert a new symbolic token after |p|, then
5449 make |p| point to it and |break|@>;
5456 @ @<Treat special case of length 1...@>=
5457 p=mp->buffer[j]+1; text(p)=p-1; return p;
5460 @ @<Insert a new symbolic...@>=
5465 mp_overflow(mp, "hash size",mp->hash_size);
5466 @:MetaPost capacity exceeded hash size}{\quad hash size@>
5467 decr(mp->hash_used);
5468 } while (text(mp->hash_used)!=0); /* search for an empty location in |hash| */
5469 next(p)=mp->hash_used;
5473 for (k=j;k<=j+l-1;k++) {
5474 append_char(mp->buffer[k]);
5476 text(p)=mp_make_string(mp);
5477 mp->str_ref[text(p)]=max_str_ref;
5483 @ The value of |hash_prime| should be roughly 85\pct! of |hash_size|, and it
5484 should be a prime number. The theory of hashing tells us to expect fewer
5485 than two table probes, on the average, when the search is successful.
5486 [See J.~S. Vitter, {\sl Journal of the ACM\/ \bf30} (1983), 231--258.]
5487 @^Vitter, Jeffrey Scott@>
5489 @<Compute the hash code |h|@>=
5491 for (k=j+1;k<=j+l-1;k++){
5492 h=h+h+mp->buffer[k];
5493 while ( h>=mp->hash_prime ) h=h-mp->hash_prime;
5496 @ @<Search |eqtb| for equivalents equal to |p|@>=
5497 for (q=1;q<=hash_end;q++) {
5498 if ( equiv(q)==p ) {
5499 mp_print_nl(mp, "EQUIV(");
5500 mp_print_int(mp, q);
5501 mp_print_char(mp, ')');
5505 @ We need to put \MP's ``primitive'' symbolic tokens into the hash
5506 table, together with their command code (which will be the |eq_type|)
5507 and an operand (which will be the |equiv|). The |primitive| procedure
5508 does this, in a way that no \MP\ user can. The global value |cur_sym|
5509 contains the new |eqtb| pointer after |primitive| has acted.
5512 void mp_primitive (MP mp, const char *ss, halfword c, halfword o) {
5513 pool_pointer k; /* index into |str_pool| */
5514 small_number j; /* index into |buffer| */
5515 small_number l; /* length of the string */
5518 k=mp->str_start[s]; l=str_stop(s)-k;
5519 /* we will move |s| into the (empty) |buffer| */
5520 for (j=0;j<=l-1;j++) {
5521 mp->buffer[j]=mp->str_pool[k+j];
5523 mp->cur_sym=mp_id_lookup(mp, 0,l);
5524 if ( s>=256 ) { /* we don't want to have the string twice */
5525 mp_flush_string(mp, text(mp->cur_sym)); text(mp->cur_sym)=s;
5527 eq_type(mp->cur_sym)=c;
5528 equiv(mp->cur_sym)=o;
5532 @ Many of \MP's primitives need no |equiv|, since they are identifiable
5533 by their |eq_type| alone. These primitives are loaded into the hash table
5536 @<Put each of \MP's primitives into the hash table@>=
5537 mp_primitive(mp, "..",path_join,0);
5538 @:.._}{\.{..} primitive@>
5539 mp_primitive(mp, "[",left_bracket,0); mp->eqtb[frozen_left_bracket]=mp->eqtb[mp->cur_sym];
5540 @:[ }{\.{[} primitive@>
5541 mp_primitive(mp, "]",right_bracket,0);
5542 @:] }{\.{]} primitive@>
5543 mp_primitive(mp, "}",right_brace,0);
5544 @:]]}{\.{\char`\}} primitive@>
5545 mp_primitive(mp, "{",left_brace,0);
5546 @:][}{\.{\char`\{} primitive@>
5547 mp_primitive(mp, ":",colon,0); mp->eqtb[frozen_colon]=mp->eqtb[mp->cur_sym];
5548 @:: }{\.{:} primitive@>
5549 mp_primitive(mp, "::",double_colon,0);
5550 @::: }{\.{::} primitive@>
5551 mp_primitive(mp, "||:",bchar_label,0);
5552 @:::: }{\.{\char'174\char'174:} primitive@>
5553 mp_primitive(mp, ":=",assignment,0);
5554 @::=_}{\.{:=} primitive@>
5555 mp_primitive(mp, ",",comma,0);
5556 @:, }{\., primitive@>
5557 mp_primitive(mp, ";",semicolon,0); mp->eqtb[frozen_semicolon]=mp->eqtb[mp->cur_sym];
5558 @:; }{\.; primitive@>
5559 mp_primitive(mp, "\\",relax,0);
5560 @:]]\\}{\.{\char`\\} primitive@>
5562 mp_primitive(mp, "addto",add_to_command,0);
5563 @:add_to_}{\&{addto} primitive@>
5564 mp_primitive(mp, "atleast",at_least,0);
5565 @:at_least_}{\&{atleast} primitive@>
5566 mp_primitive(mp, "begingroup",begin_group,0); mp->bg_loc=mp->cur_sym;
5567 @:begin_group_}{\&{begingroup} primitive@>
5568 mp_primitive(mp, "controls",controls,0);
5569 @:controls_}{\&{controls} primitive@>
5570 mp_primitive(mp, "curl",curl_command,0);
5571 @:curl_}{\&{curl} primitive@>
5572 mp_primitive(mp, "delimiters",delimiters,0);
5573 @:delimiters_}{\&{delimiters} primitive@>
5574 mp_primitive(mp, "endgroup",end_group,0);
5575 mp->eqtb[frozen_end_group]=mp->eqtb[mp->cur_sym]; mp->eg_loc=mp->cur_sym;
5576 @:endgroup_}{\&{endgroup} primitive@>
5577 mp_primitive(mp, "everyjob",every_job_command,0);
5578 @:every_job_}{\&{everyjob} primitive@>
5579 mp_primitive(mp, "exitif",exit_test,0);
5580 @:exit_if_}{\&{exitif} primitive@>
5581 mp_primitive(mp, "expandafter",expand_after,0);
5582 @:expand_after_}{\&{expandafter} primitive@>
5583 mp_primitive(mp, "interim",interim_command,0);
5584 @:interim_}{\&{interim} primitive@>
5585 mp_primitive(mp, "let",let_command,0);
5586 @:let_}{\&{let} primitive@>
5587 mp_primitive(mp, "newinternal",new_internal,0);
5588 @:new_internal_}{\&{newinternal} primitive@>
5589 mp_primitive(mp, "of",of_token,0);
5590 @:of_}{\&{of} primitive@>
5591 mp_primitive(mp, "randomseed",mp_random_seed,0);
5592 @:mp_random_seed_}{\&{randomseed} primitive@>
5593 mp_primitive(mp, "save",save_command,0);
5594 @:save_}{\&{save} primitive@>
5595 mp_primitive(mp, "scantokens",scan_tokens,0);
5596 @:scan_tokens_}{\&{scantokens} primitive@>
5597 mp_primitive(mp, "shipout",ship_out_command,0);
5598 @:ship_out_}{\&{shipout} primitive@>
5599 mp_primitive(mp, "skipto",skip_to,0);
5600 @:skip_to_}{\&{skipto} primitive@>
5601 mp_primitive(mp, "special",special_command,0);
5602 @:special}{\&{special} primitive@>
5603 mp_primitive(mp, "fontmapfile",special_command,1);
5604 @:fontmapfile}{\&{fontmapfile} primitive@>
5605 mp_primitive(mp, "fontmapline",special_command,2);
5606 @:fontmapline}{\&{fontmapline} primitive@>
5607 mp_primitive(mp, "step",step_token,0);
5608 @:step_}{\&{step} primitive@>
5609 mp_primitive(mp, "str",str_op,0);
5610 @:str_}{\&{str} primitive@>
5611 mp_primitive(mp, "tension",tension,0);
5612 @:tension_}{\&{tension} primitive@>
5613 mp_primitive(mp, "to",to_token,0);
5614 @:to_}{\&{to} primitive@>
5615 mp_primitive(mp, "until",until_token,0);
5616 @:until_}{\&{until} primitive@>
5617 mp_primitive(mp, "within",within_token,0);
5618 @:within_}{\&{within} primitive@>
5619 mp_primitive(mp, "write",write_command,0);
5620 @:write_}{\&{write} primitive@>
5622 @ Each primitive has a corresponding inverse, so that it is possible to
5623 display the cryptic numeric contents of |eqtb| in symbolic form.
5624 Every call of |primitive| in this program is therefore accompanied by some
5625 straightforward code that forms part of the |print_cmd_mod| routine
5628 @<Cases of |print_cmd_mod| for symbolic printing of primitives@>=
5629 case add_to_command:mp_print(mp, "addto"); break;
5630 case assignment:mp_print(mp, ":="); break;
5631 case at_least:mp_print(mp, "atleast"); break;
5632 case bchar_label:mp_print(mp, "||:"); break;
5633 case begin_group:mp_print(mp, "begingroup"); break;
5634 case colon:mp_print(mp, ":"); break;
5635 case comma:mp_print(mp, ","); break;
5636 case controls:mp_print(mp, "controls"); break;
5637 case curl_command:mp_print(mp, "curl"); break;
5638 case delimiters:mp_print(mp, "delimiters"); break;
5639 case double_colon:mp_print(mp, "::"); break;
5640 case end_group:mp_print(mp, "endgroup"); break;
5641 case every_job_command:mp_print(mp, "everyjob"); break;
5642 case exit_test:mp_print(mp, "exitif"); break;
5643 case expand_after:mp_print(mp, "expandafter"); break;
5644 case interim_command:mp_print(mp, "interim"); break;
5645 case left_brace:mp_print(mp, "{"); break;
5646 case left_bracket:mp_print(mp, "["); break;
5647 case let_command:mp_print(mp, "let"); break;
5648 case new_internal:mp_print(mp, "newinternal"); break;
5649 case of_token:mp_print(mp, "of"); break;
5650 case path_join:mp_print(mp, ".."); break;
5651 case mp_random_seed:mp_print(mp, "randomseed"); break;
5652 case relax:mp_print_char(mp, '\\'); break;
5653 case right_brace:mp_print(mp, "}"); break;
5654 case right_bracket:mp_print(mp, "]"); break;
5655 case save_command:mp_print(mp, "save"); break;
5656 case scan_tokens:mp_print(mp, "scantokens"); break;
5657 case semicolon:mp_print(mp, ";"); break;
5658 case ship_out_command:mp_print(mp, "shipout"); break;
5659 case skip_to:mp_print(mp, "skipto"); break;
5660 case special_command: if ( m==2 ) mp_print(mp, "fontmapline"); else
5661 if ( m==1 ) mp_print(mp, "fontmapfile"); else
5662 mp_print(mp, "special"); break;
5663 case step_token:mp_print(mp, "step"); break;
5664 case str_op:mp_print(mp, "str"); break;
5665 case tension:mp_print(mp, "tension"); break;
5666 case to_token:mp_print(mp, "to"); break;
5667 case until_token:mp_print(mp, "until"); break;
5668 case within_token:mp_print(mp, "within"); break;
5669 case write_command:mp_print(mp, "write"); break;
5671 @ We will deal with the other primitives later, at some point in the program
5672 where their |eq_type| and |equiv| values are more meaningful. For example,
5673 the primitives for macro definitions will be loaded when we consider the
5674 routines that define macros.
5675 It is easy to find where each particular
5676 primitive was treated by looking in the index at the end; for example, the
5677 section where |"def"| entered |eqtb| is listed under `\&{def} primitive'.
5679 @* \[14] Token lists.
5680 A \MP\ token is either symbolic or numeric or a string, or it denotes
5681 a macro parameter or capsule; so there are five corresponding ways to encode it
5683 internally: (1)~A symbolic token whose hash code is~|p|
5684 is represented by the number |p|, in the |info| field of a single-word
5685 node in~|mem|. (2)~A numeric token whose |scaled| value is~|v| is
5686 represented in a two-word node of~|mem|; the |type| field is |known|,
5687 the |name_type| field is |token|, and the |value| field holds~|v|.
5688 The fact that this token appears in a two-word node rather than a
5689 one-word node is, of course, clear from the node address.
5690 (3)~A string token is also represented in a two-word node; the |type|
5691 field is |mp_string_type|, the |name_type| field is |token|, and the
5692 |value| field holds the corresponding |str_number|. (4)~Capsules have
5693 |name_type=capsule|, and their |type| and |value| fields represent
5694 arbitrary values (in ways to be explained later). (5)~Macro parameters
5695 are like symbolic tokens in that they appear in |info| fields of
5696 one-word nodes. The $k$th parameter is represented by |expr_base+k| if it
5697 is of type \&{expr}, or by |suffix_base+k| if it is of type \&{suffix}, or
5698 by |text_base+k| if it is of type \&{text}. (Here |0<=k<param_size|.)
5699 Actual values of these parameters are kept in a separate stack, as we will
5700 see later. The constants |expr_base|, |suffix_base|, and |text_base| are,
5701 of course, chosen so that there will be no confusion between symbolic
5702 tokens and parameters of various types.
5705 the `\\{type}' field of a node has nothing to do with ``type'' in a
5706 printer's sense. It's curious that the same word is used in such different ways.
5708 @d type(A) mp->mem[(A)].hh.b0 /* identifies what kind of value this is */
5709 @d name_type(A) mp->mem[(A)].hh.b1 /* a clue to the name of this value */
5710 @d token_node_size 2 /* the number of words in a large token node */
5711 @d value_loc(A) ((A)+1) /* the word that contains the |value| field */
5712 @d value(A) mp->mem[value_loc((A))].cint /* the value stored in a large token node */
5713 @d expr_base (hash_end+1) /* code for the zeroth \&{expr} parameter */
5714 @d suffix_base (expr_base+mp->param_size) /* code for the zeroth \&{suffix} parameter */
5715 @d text_base (suffix_base+mp->param_size) /* code for the zeroth \&{text} parameter */
5717 @<Check the ``constant''...@>=
5718 if ( text_base+mp->param_size>max_halfword ) mp->bad=18;
5720 @ We have set aside a two word node beginning at |null| so that we can have
5721 |value(null)=0|. We will make use of this coincidence later.
5723 @<Initialize table entries...@>=
5724 link(null)=null; value(null)=0;
5726 @ A numeric token is created by the following trivial routine.
5729 pointer mp_new_num_tok (MP mp,scaled v) {
5730 pointer p; /* the new node */
5731 p=mp_get_node(mp, token_node_size); value(p)=v;
5732 type(p)=mp_known; name_type(p)=mp_token;
5736 @ A token list is a singly linked list of nodes in |mem|, where
5737 each node contains a token and a link. Here's a subroutine that gets rid
5738 of a token list when it is no longer needed.
5740 @c void mp_flush_token_list (MP mp,pointer p) {
5741 pointer q; /* the node being recycled */
5744 if ( q>=mp->hi_mem_min ) {
5748 case mp_vacuous: case mp_boolean_type: case mp_known:
5750 case mp_string_type:
5751 delete_str_ref(value(q));
5753 case unknown_types: case mp_pen_type: case mp_path_type:
5754 case mp_picture_type: case mp_pair_type: case mp_color_type:
5755 case mp_cmykcolor_type: case mp_transform_type: case mp_dependent:
5756 case mp_proto_dependent: case mp_independent:
5757 mp_recycle_value(mp,q);
5759 default: mp_confusion(mp, "token");
5760 @:this can't happen token}{\quad token@>
5762 mp_free_node(mp, q,token_node_size);
5767 @ The procedure |show_token_list|, which prints a symbolic form of
5768 the token list that starts at a given node |p|, illustrates these
5769 conventions. The token list being displayed should not begin with a reference
5770 count. However, the procedure is intended to be fairly robust, so that if the
5771 memory links are awry or if |p| is not really a pointer to a token list,
5772 almost nothing catastrophic can happen.
5774 An additional parameter |q| is also given; this parameter is either null
5775 or it points to a node in the token list where a certain magic computation
5776 takes place that will be explained later. (Basically, |q| is non-null when
5777 we are printing the two-line context information at the time of an error
5778 message; |q| marks the place corresponding to where the second line
5781 The generation will stop, and `\.{\char`\ ETC.}' will be printed, if the length
5782 of printing exceeds a given limit~|l|; the length of printing upon entry is
5783 assumed to be a given amount called |null_tally|. (Note that
5784 |show_token_list| sometimes uses itself recursively to print
5785 variable names within a capsule.)
5788 Unusual entries are printed in the form of all-caps tokens
5789 preceded by a space, e.g., `\.{\char`\ BAD}'.
5791 @<Declare the procedure called |show_token_list|@>=
5792 void mp_show_token_list (MP mp, integer p, integer q, integer l,
5793 integer null_tally) ;
5796 void mp_show_token_list (MP mp, integer p, integer q, integer l,
5797 integer null_tally) {
5798 small_number class,c; /* the |char_class| of previous and new tokens */
5799 integer r,v; /* temporary registers */
5800 class=percent_class;
5801 mp->tally=null_tally;
5802 while ( (p!=null) && (mp->tally<l) ) {
5804 @<Do magic computation@>;
5805 @<Display token |p| and set |c| to its class;
5806 but |return| if there are problems@>;
5810 mp_print(mp, " ETC.");
5815 @ @<Display token |p| and set |c| to its class...@>=
5816 c=letter_class; /* the default */
5817 if ( (p<0)||(p>mp->mem_end) ) {
5818 mp_print(mp, " CLOBBERED"); return;
5821 if ( p<mp->hi_mem_min ) {
5822 @<Display two-word token@>;
5825 if ( r>=expr_base ) {
5826 @<Display a parameter token@>;
5830 @<Display a collective subscript@>
5832 mp_print(mp, " IMPOSSIBLE");
5837 if ( (r<0)||(r>mp->max_str_ptr) ) {
5838 mp_print(mp, " NONEXISTENT");
5841 @<Print string |r| as a symbolic token
5842 and set |c| to its class@>;
5848 @ @<Display two-word token@>=
5849 if ( name_type(p)==mp_token ) {
5850 if ( type(p)==mp_known ) {
5851 @<Display a numeric token@>;
5852 } else if ( type(p)!=mp_string_type ) {
5853 mp_print(mp, " BAD");
5856 mp_print_char(mp, '"'); mp_print_str(mp, value(p)); mp_print_char(mp, '"');
5859 } else if ((name_type(p)!=mp_capsule)||(type(p)<mp_vacuous)||(type(p)>mp_independent) ) {
5860 mp_print(mp, " BAD");
5862 mp_print_capsule(mp,p); c=right_paren_class;
5865 @ @<Display a numeric token@>=
5866 if ( class==digit_class )
5867 mp_print_char(mp, ' ');
5870 if ( class==left_bracket_class )
5871 mp_print_char(mp, ' ');
5872 mp_print_char(mp, '['); mp_print_scaled(mp, v); mp_print_char(mp, ']');
5873 c=right_bracket_class;
5875 mp_print_scaled(mp, v); c=digit_class;
5879 @ Strictly speaking, a genuine token will never have |info(p)=0|.
5880 But we will see later (in the |print_variable_name| routine) that
5881 it is convenient to let |info(p)=0| stand for `\.{[]}'.
5883 @<Display a collective subscript@>=
5885 if ( class==left_bracket_class )
5886 mp_print_char(mp, ' ');
5887 mp_print(mp, "[]"); c=right_bracket_class;
5890 @ @<Display a parameter token@>=
5892 if ( r<suffix_base ) {
5893 mp_print(mp, "(EXPR"); r=r-(expr_base);
5895 } else if ( r<text_base ) {
5896 mp_print(mp, "(SUFFIX"); r=r-(suffix_base);
5899 mp_print(mp, "(TEXT"); r=r-(text_base);
5902 mp_print_int(mp, r); mp_print_char(mp, ')'); c=right_paren_class;
5906 @ @<Print string |r| as a symbolic token...@>=
5908 c=mp->char_class[mp->str_pool[mp->str_start[r]]];
5911 case letter_class:mp_print_char(mp, '.'); break;
5912 case isolated_classes: break;
5913 default: mp_print_char(mp, ' '); break;
5916 mp_print_str(mp, r);
5920 void mp_print_capsule (MP mp, pointer p);
5922 @ @<Declare miscellaneous procedures that were declared |forward|@>=
5923 void mp_print_capsule (MP mp, pointer p) {
5924 mp_print_char(mp, '('); mp_print_exp(mp,p,0); mp_print_char(mp, ')');
5927 @ Macro definitions are kept in \MP's memory in the form of token lists
5928 that have a few extra one-word nodes at the beginning.
5930 The first node contains a reference count that is used to tell when the
5931 list is no longer needed. To emphasize the fact that a reference count is
5932 present, we shall refer to the |info| field of this special node as the
5934 @^reference counts@>
5936 The next node or nodes after the reference count serve to describe the
5937 formal parameters. They consist of zero or more parameter tokens followed
5938 by a code for the type of macro.
5941 /* reference count preceding a macro definition or picture header */
5942 @d add_mac_ref(A) incr(ref_count((A))) /* make a new reference to a macro list */
5943 @d general_macro 0 /* preface to a macro defined with a parameter list */
5944 @d primary_macro 1 /* preface to a macro with a \&{primary} parameter */
5945 @d secondary_macro 2 /* preface to a macro with a \&{secondary} parameter */
5946 @d tertiary_macro 3 /* preface to a macro with a \&{tertiary} parameter */
5947 @d expr_macro 4 /* preface to a macro with an undelimited \&{expr} parameter */
5948 @d of_macro 5 /* preface to a macro with
5949 undelimited `\&{expr} |x| \&{of}~|y|' parameters */
5950 @d suffix_macro 6 /* preface to a macro with an undelimited \&{suffix} parameter */
5951 @d text_macro 7 /* preface to a macro with an undelimited \&{text} parameter */
5954 void mp_delete_mac_ref (MP mp,pointer p) {
5955 /* |p| points to the reference count of a macro list that is
5956 losing one reference */
5957 if ( ref_count(p)==null ) mp_flush_token_list(mp, p);
5958 else decr(ref_count(p));
5961 @ The following subroutine displays a macro, given a pointer to its
5965 @<Declare the procedure called |print_cmd_mod|@>
5966 void mp_show_macro (MP mp, pointer p, integer q, integer l) {
5967 pointer r; /* temporary storage */
5968 p=link(p); /* bypass the reference count */
5969 while ( info(p)>text_macro ){
5970 r=link(p); link(p)=null;
5971 mp_show_token_list(mp, p,null,l,0); link(p)=r; p=r;
5972 if ( l>0 ) l=l-mp->tally; else return;
5973 } /* control printing of `\.{ETC.}' */
5977 case general_macro:mp_print(mp, "->"); break;
5979 case primary_macro: case secondary_macro: case tertiary_macro:
5980 mp_print_char(mp, '<');
5981 mp_print_cmd_mod(mp, param_type,info(p));
5982 mp_print(mp, ">->");
5984 case expr_macro:mp_print(mp, "<expr>->"); break;
5985 case of_macro:mp_print(mp, "<expr>of<primary>->"); break;
5986 case suffix_macro:mp_print(mp, "<suffix>->"); break;
5987 case text_macro:mp_print(mp, "<text>->"); break;
5988 } /* there are no other cases */
5989 mp_show_token_list(mp, link(p),q,l-mp->tally,0);
5992 @* \[15] Data structures for variables.
5993 The variables of \MP\ programs can be simple, like `\.x', or they can
5994 combine the structural properties of arrays and records, like `\.{x20a.b}'.
5995 A \MP\ user assigns a type to a variable like \.{x20a.b} by saying, for
5996 example, `\.{boolean} \.{x[]a.b}'. It's time for us to study how such
5997 things are represented inside of the computer.
5999 Each variable value occupies two consecutive words, either in a two-word
6000 node called a value node, or as a two-word subfield of a larger node. One
6001 of those two words is called the |value| field; it is an integer,
6002 containing either a |scaled| numeric value or the representation of some
6003 other type of quantity. (It might also be subdivided into halfwords, in
6004 which case it is referred to by other names instead of |value|.) The other
6005 word is broken into subfields called |type|, |name_type|, and |link|. The
6006 |type| field is a quarterword that specifies the variable's type, and
6007 |name_type| is a quarterword from which \MP\ can reconstruct the
6008 variable's name (sometimes by using the |link| field as well). Thus, only
6009 1.25 words are actually devoted to the value itself; the other
6010 three-quarters of a word are overhead, but they aren't wasted because they
6011 allow \MP\ to deal with sparse arrays and to provide meaningful diagnostics.
6013 In this section we shall be concerned only with the structural aspects of
6014 variables, not their values. Later parts of the program will change the
6015 |type| and |value| fields, but we shall treat those fields as black boxes
6016 whose contents should not be touched.
6018 However, if the |type| field is |mp_structured|, there is no |value| field,
6019 and the second word is broken into two pointer fields called |attr_head|
6020 and |subscr_head|. Those fields point to additional nodes that
6021 contain structural information, as we shall see.
6023 @d subscr_head_loc(A) (A)+1 /* where |value|, |subscr_head| and |attr_head| are */
6024 @d attr_head(A) info(subscr_head_loc((A))) /* pointer to attribute info */
6025 @d subscr_head(A) link(subscr_head_loc((A))) /* pointer to subscript info */
6026 @d value_node_size 2 /* the number of words in a value node */
6028 @ An attribute node is three words long. Two of these words contain |type|
6029 and |value| fields as described above, and the third word contains
6030 additional information: There is an |attr_loc| field, which contains the
6031 hash address of the token that names this attribute; and there's also a
6032 |parent| field, which points to the value node of |mp_structured| type at the
6033 next higher level (i.e., at the level to which this attribute is
6034 subsidiary). The |name_type| in an attribute node is `|attr|'. The
6035 |link| field points to the next attribute with the same parent; these are
6036 arranged in increasing order, so that |attr_loc(link(p))>attr_loc(p)|. The
6037 final attribute node links to the constant |end_attr|, whose |attr_loc|
6038 field is greater than any legal hash address. The |attr_head| in the
6039 parent points to a node whose |name_type| is |mp_structured_root|; this
6040 node represents the null attribute, i.e., the variable that is relevant
6041 when no attributes are attached to the parent. The |attr_head| node
6042 has the fields of either
6043 a value node, a subscript node, or an attribute node, depending on what
6044 the parent would be if it were not structured; but the subscript and
6045 attribute fields are ignored, so it effectively contains only the data of
6046 a value node. The |link| field in this special node points to an attribute
6047 node whose |attr_loc| field is zero; the latter node represents a collective
6048 subscript `\.{[]}' attached to the parent, and its |link| field points to
6049 the first non-special attribute node (or to |end_attr| if there are none).
6051 A subscript node likewise occupies three words, with |type| and |value| fields
6052 plus extra information; its |name_type| is |subscr|. In this case the
6053 third word is called the |subscript| field, which is a |scaled| integer.
6054 The |link| field points to the subscript node with the next larger
6055 subscript, if any; otherwise the |link| points to the attribute node
6056 for collective subscripts at this level. We have seen that the latter node
6057 contains an upward pointer, so that the parent can be deduced.
6059 The |name_type| in a parent-less value node is |root|, and the |link|
6060 is the hash address of the token that names this value.
6062 In other words, variables have a hierarchical structure that includes
6063 enough threads running around so that the program is able to move easily
6064 between siblings, parents, and children. An example should be helpful:
6065 (The reader is advised to draw a picture while reading the following
6066 description, since that will help to firm up the ideas.)
6067 Suppose that `\.x' and `\.{x.a}' and `\.{x[]b}' and `\.{x5}'
6068 and `\.{x20b}' have been mentioned in a user's program, where
6069 \.{x[]b} has been declared to be of \&{boolean} type. Let |h(x)|, |h(a)|,
6070 and |h(b)| be the hash addresses of \.x, \.a, and~\.b. Then
6071 |eq_type(h(x))=name| and |equiv(h(x))=p|, where |p|~is a two-word value
6072 node with |name_type(p)=root| and |link(p)=h(x)|. We have |type(p)=mp_structured|,
6073 |attr_head(p)=q|, and |subscr_head(p)=r|, where |q| points to a value
6074 node and |r| to a subscript node. (Are you still following this? Use
6075 a pencil to draw a diagram.) The lone variable `\.x' is represented by
6076 |type(q)| and |value(q)|; furthermore
6077 |name_type(q)=mp_structured_root| and |link(q)=q1|, where |q1| points
6078 to an attribute node representing `\.{x[]}'. Thus |name_type(q1)=attr|,
6079 |attr_loc(q1)=collective_subscript=0|, |parent(q1)=p|,
6080 |type(q1)=mp_structured|, |attr_head(q1)=qq|, and |subscr_head(q1)=qq1|;
6081 |qq| is a three-word ``attribute-as-value'' node with |type(qq)=numeric_type|
6082 (assuming that \.{x5} is numeric, because |qq| represents `\.{x[]}'
6083 with no further attributes), |name_type(qq)=structured_root|,
6084 |attr_loc(qq)=0|, |parent(qq)=p|, and
6085 |link(qq)=qq1|. (Now pay attention to the next part.) Node |qq1| is
6086 an attribute node representing `\.{x[][]}', which has never yet
6087 occurred; its |type| field is |undefined|, and its |value| field is
6088 undefined. We have |name_type(qq1)=attr|, |attr_loc(qq1)=collective_subscript|,
6089 |parent(qq1)=q1|, and |link(qq1)=qq2|. Since |qq2| represents
6090 `\.{x[]b}', |type(qq2)=mp_unknown_boolean|; also |attr_loc(qq2)=h(b)|,
6091 |parent(qq2)=q1|, |name_type(qq2)=attr|, |link(qq2)=end_attr|.
6092 (Maybe colored lines will help untangle your picture.)
6093 Node |r| is a subscript node with |type| and |value|
6094 representing `\.{x5}'; |name_type(r)=subscr|, |subscript(r)=5.0|,
6095 and |link(r)=r1| is another subscript node. To complete the picture,
6096 see if you can guess what |link(r1)| is; give up? It's~|q1|.
6097 Furthermore |subscript(r1)=20.0|, |name_type(r1)=subscr|,
6098 |type(r1)=mp_structured|, |attr_head(r1)=qqq|, |subscr_head(r1)=qqq1|,
6099 and we finish things off with three more nodes
6100 |qqq|, |qqq1|, and |qqq2| hung onto~|r1|. (Perhaps you should start again
6101 with a larger sheet of paper.) The value of variable \.{x20b}
6102 appears in node~|qqq2|, as you can well imagine.
6104 If the example in the previous paragraph doesn't make things crystal
6105 clear, a glance at some of the simpler subroutines below will reveal how
6106 things work out in practice.
6108 The only really unusual thing about these conventions is the use of
6109 collective subscript attributes. The idea is to avoid repeating a lot of
6110 type information when many elements of an array are identical macros
6111 (for which distinct values need not be stored) or when they don't have
6112 all of the possible attributes. Branches of the structure below collective
6113 subscript attributes do not carry actual values except for macro identifiers;
6114 branches of the structure below subscript nodes do not carry significant
6115 information in their collective subscript attributes.
6117 @d attr_loc_loc(A) ((A)+2) /* where the |attr_loc| and |parent| fields are */
6118 @d attr_loc(A) info(attr_loc_loc((A))) /* hash address of this attribute */
6119 @d parent(A) link(attr_loc_loc((A))) /* pointer to |mp_structured| variable */
6120 @d subscript_loc(A) ((A)+2) /* where the |subscript| field lives */
6121 @d subscript(A) mp->mem[subscript_loc((A))].sc /* subscript of this variable */
6122 @d attr_node_size 3 /* the number of words in an attribute node */
6123 @d subscr_node_size 3 /* the number of words in a subscript node */
6124 @d collective_subscript 0 /* code for the attribute `\.{[]}' */
6126 @<Initialize table...@>=
6127 attr_loc(end_attr)=hash_end+1; parent(end_attr)=null;
6129 @ Variables of type \&{pair} will have values that point to four-word
6130 nodes containing two numeric values. The first of these values has
6131 |name_type=mp_x_part_sector| and the second has |name_type=mp_y_part_sector|;
6132 the |link| in the first points back to the node whose |value| points
6133 to this four-word node.
6135 Variables of type \&{transform} are similar, but in this case their
6136 |value| points to a 12-word node containing six values, identified by
6137 |x_part_sector|, |y_part_sector|, |mp_xx_part_sector|, |mp_xy_part_sector|,
6138 |mp_yx_part_sector|, and |mp_yy_part_sector|.
6139 Finally, variables of type \&{color} have 3~values in 6~words
6140 identified by |mp_red_part_sector|, |mp_green_part_sector|, and |mp_blue_part_sector|.
6142 When an entire structured variable is saved, the |root| indication
6143 is temporarily replaced by |saved_root|.
6145 Some variables have no name; they just are used for temporary storage
6146 while expressions are being evaluated. We call them {\sl capsules}.
6148 @d x_part_loc(A) (A) /* where the \&{xpart} is found in a pair or transform node */
6149 @d y_part_loc(A) ((A)+2) /* where the \&{ypart} is found in a pair or transform node */
6150 @d xx_part_loc(A) ((A)+4) /* where the \&{xxpart} is found in a transform node */
6151 @d xy_part_loc(A) ((A)+6) /* where the \&{xypart} is found in a transform node */
6152 @d yx_part_loc(A) ((A)+8) /* where the \&{yxpart} is found in a transform node */
6153 @d yy_part_loc(A) ((A)+10) /* where the \&{yypart} is found in a transform node */
6154 @d red_part_loc(A) (A) /* where the \&{redpart} is found in a color node */
6155 @d green_part_loc(A) ((A)+2) /* where the \&{greenpart} is found in a color node */
6156 @d blue_part_loc(A) ((A)+4) /* where the \&{bluepart} is found in a color node */
6157 @d cyan_part_loc(A) (A) /* where the \&{cyanpart} is found in a color node */
6158 @d magenta_part_loc(A) ((A)+2) /* where the \&{magentapart} is found in a color node */
6159 @d yellow_part_loc(A) ((A)+4) /* where the \&{yellowpart} is found in a color node */
6160 @d black_part_loc(A) ((A)+6) /* where the \&{blackpart} is found in a color node */
6161 @d grey_part_loc(A) (A) /* where the \&{greypart} is found in a color node */
6163 @d pair_node_size 4 /* the number of words in a pair node */
6164 @d transform_node_size 12 /* the number of words in a transform node */
6165 @d color_node_size 6 /* the number of words in a color node */
6166 @d cmykcolor_node_size 8 /* the number of words in a color node */
6169 small_number big_node_size[mp_pair_type+1];
6170 small_number sector0[mp_pair_type+1];
6171 small_number sector_offset[mp_black_part_sector+1];
6173 @ The |sector0| array gives for each big node type, |name_type| values
6174 for its first subfield; the |sector_offset| array gives for each
6175 |name_type| value, the offset from the first subfield in words;
6176 and the |big_node_size| array gives the size in words for each type of
6180 mp->big_node_size[mp_transform_type]=transform_node_size;
6181 mp->big_node_size[mp_pair_type]=pair_node_size;
6182 mp->big_node_size[mp_color_type]=color_node_size;
6183 mp->big_node_size[mp_cmykcolor_type]=cmykcolor_node_size;
6184 mp->sector0[mp_transform_type]=mp_x_part_sector;
6185 mp->sector0[mp_pair_type]=mp_x_part_sector;
6186 mp->sector0[mp_color_type]=mp_red_part_sector;
6187 mp->sector0[mp_cmykcolor_type]=mp_cyan_part_sector;
6188 for (k=mp_x_part_sector;k<= mp_yy_part_sector;k++ ) {
6189 mp->sector_offset[k]=2*(k-mp_x_part_sector);
6191 for (k=mp_red_part_sector;k<= mp_blue_part_sector ; k++) {
6192 mp->sector_offset[k]=2*(k-mp_red_part_sector);
6194 for (k=mp_cyan_part_sector;k<= mp_black_part_sector;k++ ) {
6195 mp->sector_offset[k]=2*(k-mp_cyan_part_sector);
6198 @ If |type(p)=mp_pair_type| or |mp_transform_type| and if |value(p)=null|, the
6199 procedure call |init_big_node(p)| will allocate a pair or transform node
6200 for~|p|. The individual parts of such nodes are initially of type
6204 void mp_init_big_node (MP mp,pointer p) {
6205 pointer q; /* the new node */
6206 small_number s; /* its size */
6207 s=mp->big_node_size[type(p)]; q=mp_get_node(mp, s);
6210 @<Make variable |q+s| newly independent@>;
6211 name_type(q+s)=halfp(s)+mp->sector0[type(p)];
6214 link(q)=p; value(p)=q;
6217 @ The |id_transform| function creates a capsule for the
6218 identity transformation.
6221 pointer mp_id_transform (MP mp) {
6222 pointer p,q,r; /* list manipulation registers */
6223 p=mp_get_node(mp, value_node_size); type(p)=mp_transform_type;
6224 name_type(p)=mp_capsule; value(p)=null; mp_init_big_node(mp, p); q=value(p);
6225 r=q+transform_node_size;
6228 type(r)=mp_known; value(r)=0;
6230 value(xx_part_loc(q))=unity;
6231 value(yy_part_loc(q))=unity;
6235 @ Tokens are of type |tag_token| when they first appear, but they point
6236 to |null| until they are first used as the root of a variable.
6237 The following subroutine establishes the root node on such grand occasions.
6240 void mp_new_root (MP mp,pointer x) {
6241 pointer p; /* the new node */
6242 p=mp_get_node(mp, value_node_size); type(p)=undefined; name_type(p)=mp_root;
6243 link(p)=x; equiv(x)=p;
6246 @ These conventions for variable representation are illustrated by the
6247 |print_variable_name| routine, which displays the full name of a
6248 variable given only a pointer to its two-word value packet.
6251 void mp_print_variable_name (MP mp, pointer p);
6254 void mp_print_variable_name (MP mp, pointer p) {
6255 pointer q; /* a token list that will name the variable's suffix */
6256 pointer r; /* temporary for token list creation */
6257 while ( name_type(p)>=mp_x_part_sector ) {
6258 @<Preface the output with a part specifier; |return| in the
6259 case of a capsule@>;
6262 while ( name_type(p)>mp_saved_root ) {
6263 @<Ascend one level, pushing a token onto list |q|
6264 and replacing |p| by its parent@>;
6266 r=mp_get_avail(mp); info(r)=link(p); link(r)=q;
6267 if ( name_type(p)==mp_saved_root ) mp_print(mp, "(SAVED)");
6269 mp_show_token_list(mp, r,null,el_gordo,mp->tally);
6270 mp_flush_token_list(mp, r);
6273 @ @<Ascend one level, pushing a token onto list |q|...@>=
6275 if ( name_type(p)==mp_subscr ) {
6276 r=mp_new_num_tok(mp, subscript(p));
6279 } while (name_type(p)!=mp_attr);
6280 } else if ( name_type(p)==mp_structured_root ) {
6281 p=link(p); goto FOUND;
6283 if ( name_type(p)!=mp_attr ) mp_confusion(mp, "var");
6284 @:this can't happen var}{\quad var@>
6285 r=mp_get_avail(mp); info(r)=attr_loc(p);
6292 @ @<Preface the output with a part specifier...@>=
6293 { switch (name_type(p)) {
6294 case mp_x_part_sector: mp_print_char(mp, 'x'); break;
6295 case mp_y_part_sector: mp_print_char(mp, 'y'); break;
6296 case mp_xx_part_sector: mp_print(mp, "xx"); break;
6297 case mp_xy_part_sector: mp_print(mp, "xy"); break;
6298 case mp_yx_part_sector: mp_print(mp, "yx"); break;
6299 case mp_yy_part_sector: mp_print(mp, "yy"); break;
6300 case mp_red_part_sector: mp_print(mp, "red"); break;
6301 case mp_green_part_sector: mp_print(mp, "green"); break;
6302 case mp_blue_part_sector: mp_print(mp, "blue"); break;
6303 case mp_cyan_part_sector: mp_print(mp, "cyan"); break;
6304 case mp_magenta_part_sector: mp_print(mp, "magenta"); break;
6305 case mp_yellow_part_sector: mp_print(mp, "yellow"); break;
6306 case mp_black_part_sector: mp_print(mp, "black"); break;
6307 case mp_grey_part_sector: mp_print(mp, "grey"); break;
6309 mp_print(mp, "%CAPSULE"); mp_print_int(mp, p-null); return;
6312 } /* there are no other cases */
6313 mp_print(mp, "part ");
6314 p=link(p-mp->sector_offset[name_type(p)]);
6317 @ The |interesting| function returns |true| if a given variable is not
6318 in a capsule, or if the user wants to trace capsules.
6321 boolean mp_interesting (MP mp,pointer p) {
6322 small_number t; /* a |name_type| */
6323 if ( mp->internal[mp_tracing_capsules]>0 ) {
6327 if ( t>=mp_x_part_sector ) if ( t!=mp_capsule )
6328 t=name_type(link(p-mp->sector_offset[t]));
6329 return (t!=mp_capsule);
6333 @ Now here is a subroutine that converts an unstructured type into an
6334 equivalent structured type, by inserting a |mp_structured| node that is
6335 capable of growing. This operation is done only when |name_type(p)=root|,
6336 |subscr|, or |attr|.
6338 The procedure returns a pointer to the new node that has taken node~|p|'s
6339 place in the structure. Node~|p| itself does not move, nor are its
6340 |value| or |type| fields changed in any way.
6343 pointer mp_new_structure (MP mp,pointer p) {
6344 pointer q,r=0; /* list manipulation registers */
6345 switch (name_type(p)) {
6347 q=link(p); r=mp_get_node(mp, value_node_size); equiv(q)=r;
6350 @<Link a new subscript node |r| in place of node |p|@>;
6353 @<Link a new attribute node |r| in place of node |p|@>;
6356 mp_confusion(mp, "struct");
6357 @:this can't happen struct}{\quad struct@>
6360 link(r)=link(p); type(r)=mp_structured; name_type(r)=name_type(p);
6361 attr_head(r)=p; name_type(p)=mp_structured_root;
6362 q=mp_get_node(mp, attr_node_size); link(p)=q; subscr_head(r)=q;
6363 parent(q)=r; type(q)=undefined; name_type(q)=mp_attr; link(q)=end_attr;
6364 attr_loc(q)=collective_subscript;
6368 @ @<Link a new subscript node |r| in place of node |p|@>=
6373 } while (name_type(q)!=mp_attr);
6374 q=parent(q); r=subscr_head_loc(q); /* |link(r)=subscr_head(q)| */
6378 r=mp_get_node(mp, subscr_node_size);
6379 link(q)=r; subscript(r)=subscript(p);
6382 @ If the attribute is |collective_subscript|, there are two pointers to
6383 node~|p|, so we must change both of them.
6385 @<Link a new attribute node |r| in place of node |p|@>=
6387 q=parent(p); r=attr_head(q);
6391 r=mp_get_node(mp, attr_node_size); link(q)=r;
6392 mp->mem[attr_loc_loc(r)]=mp->mem[attr_loc_loc(p)]; /* copy |attr_loc| and |parent| */
6393 if ( attr_loc(p)==collective_subscript ) {
6394 q=subscr_head_loc(parent(p));
6395 while ( link(q)!=p ) q=link(q);
6400 @ The |find_variable| routine is given a pointer~|t| to a nonempty token
6401 list of suffixes; it returns a pointer to the corresponding two-word
6402 value. For example, if |t| points to token \.x followed by a numeric
6403 token containing the value~7, |find_variable| finds where the value of
6404 \.{x7} is stored in memory. This may seem a simple task, and it
6405 usually is, except when \.{x7} has never been referenced before.
6406 Indeed, \.x may never have even been subscripted before; complexities
6407 arise with respect to updating the collective subscript information.
6409 If a macro type is detected anywhere along path~|t|, or if the first
6410 item on |t| isn't a |tag_token|, the value |null| is returned.
6411 Otherwise |p| will be a non-null pointer to a node such that
6412 |undefined<type(p)<mp_structured|.
6414 @d abort_find { return null; }
6417 pointer mp_find_variable (MP mp,pointer t) {
6418 pointer p,q,r,s; /* nodes in the ``value'' line */
6419 pointer pp,qq,rr,ss; /* nodes in the ``collective'' line */
6420 integer n; /* subscript or attribute */
6421 memory_word save_word; /* temporary storage for a word of |mem| */
6423 p=info(t); t=link(t);
6424 if ( (eq_type(p) % outer_tag) != tag_token ) abort_find;
6425 if ( equiv(p)==null ) mp_new_root(mp, p);
6428 @<Make sure that both nodes |p| and |pp| are of |mp_structured| type@>;
6429 if ( t<mp->hi_mem_min ) {
6430 @<Descend one level for the subscript |value(t)|@>
6432 @<Descend one level for the attribute |info(t)|@>;
6436 if ( type(pp)>=mp_structured ) {
6437 if ( type(pp)==mp_structured ) pp=attr_head(pp); else abort_find;
6439 if ( type(p)==mp_structured ) p=attr_head(p);
6440 if ( type(p)==undefined ) {
6441 if ( type(pp)==undefined ) { type(pp)=mp_numeric_type; value(pp)=null; };
6442 type(p)=type(pp); value(p)=null;
6447 @ Although |pp| and |p| begin together, they diverge when a subscript occurs;
6448 |pp|~stays in the collective line while |p|~goes through actual subscript
6451 @<Make sure that both nodes |p| and |pp|...@>=
6452 if ( type(pp)!=mp_structured ) {
6453 if ( type(pp)>mp_structured ) abort_find;
6454 ss=mp_new_structure(mp, pp);
6457 }; /* now |type(pp)=mp_structured| */
6458 if ( type(p)!=mp_structured ) /* it cannot be |>mp_structured| */
6459 p=mp_new_structure(mp, p) /* now |type(p)=mp_structured| */
6461 @ We want this part of the program to be reasonably fast, in case there are
6463 lots of subscripts at the same level of the data structure. Therefore
6464 we store an ``infinite'' value in the word that appears at the end of the
6465 subscript list, even though that word isn't part of a subscript node.
6467 @<Descend one level for the subscript |value(t)|@>=
6470 pp=link(attr_head(pp)); /* now |attr_loc(pp)=collective_subscript| */
6471 q=link(attr_head(p)); save_word=mp->mem[subscript_loc(q)];
6472 subscript(q)=el_gordo; s=subscr_head_loc(p); /* |link(s)=subscr_head(p)| */
6475 } while (n>subscript(s));
6476 if ( n==subscript(s) ) {
6479 p=mp_get_node(mp, subscr_node_size); link(r)=p; link(p)=s;
6480 subscript(p)=n; name_type(p)=mp_subscr; type(p)=undefined;
6482 mp->mem[subscript_loc(q)]=save_word;
6485 @ @<Descend one level for the attribute |info(t)|@>=
6491 } while (n>attr_loc(ss));
6492 if ( n<attr_loc(ss) ) {
6493 qq=mp_get_node(mp, attr_node_size); link(rr)=qq; link(qq)=ss;
6494 attr_loc(qq)=n; name_type(qq)=mp_attr; type(qq)=undefined;
6495 parent(qq)=pp; ss=qq;
6500 pp=ss; s=attr_head(p);
6503 } while (n>attr_loc(s));
6504 if ( n==attr_loc(s) ) {
6507 q=mp_get_node(mp, attr_node_size); link(r)=q; link(q)=s;
6508 attr_loc(q)=n; name_type(q)=mp_attr; type(q)=undefined;
6514 @ Variables lose their former values when they appear in a type declaration,
6515 or when they are defined to be macros or \&{let} equal to something else.
6516 A subroutine will be defined later that recycles the storage associated
6517 with any particular |type| or |value|; our goal now is to study a higher
6518 level process called |flush_variable|, which selectively frees parts of a
6521 This routine has some complexity because of examples such as
6522 `\hbox{\tt numeric x[]a[]b}'
6523 which recycles all variables of the form \.{x[i]a[j]b} (and no others), while
6524 `\hbox{\tt vardef x[]a[]=...}'
6525 discards all variables of the form \.{x[i]a[j]} followed by an arbitrary
6526 suffix, except for the collective node \.{x[]a[]} itself. The obvious way
6527 to handle such examples is to use recursion; so that's what we~do.
6530 Parameter |p| points to the root information of the variable;
6531 parameter |t| points to a list of one-word nodes that represent
6532 suffixes, with |info=collective_subscript| for subscripts.
6535 @<Declare subroutines for printing expressions@>
6536 @<Declare basic dependency-list subroutines@>
6537 @<Declare the recycling subroutines@>
6538 void mp_flush_cur_exp (MP mp,scaled v) ;
6539 @<Declare the procedure called |flush_below_variable|@>
6542 void mp_flush_variable (MP mp,pointer p, pointer t, boolean discard_suffixes) {
6543 pointer q,r; /* list manipulation */
6544 halfword n; /* attribute to match */
6546 if ( type(p)!=mp_structured ) return;
6547 n=info(t); t=link(t);
6548 if ( n==collective_subscript ) {
6549 r=subscr_head_loc(p); q=link(r); /* |q=subscr_head(p)| */
6550 while ( name_type(q)==mp_subscr ){
6551 mp_flush_variable(mp, q,t,discard_suffixes);
6553 if ( type(q)==mp_structured ) r=q;
6554 else { link(r)=link(q); mp_free_node(mp, q,subscr_node_size); }
6564 } while (attr_loc(p)<n);
6565 if ( attr_loc(p)!=n ) return;
6567 if ( discard_suffixes ) {
6568 mp_flush_below_variable(mp, p);
6570 if ( type(p)==mp_structured ) p=attr_head(p);
6571 mp_recycle_value(mp, p);
6575 @ The next procedure is simpler; it wipes out everything but |p| itself,
6576 which becomes undefined.
6578 @<Declare the procedure called |flush_below_variable|@>=
6579 void mp_flush_below_variable (MP mp, pointer p);
6582 void mp_flush_below_variable (MP mp,pointer p) {
6583 pointer q,r; /* list manipulation registers */
6584 if ( type(p)!=mp_structured ) {
6585 mp_recycle_value(mp, p); /* this sets |type(p)=undefined| */
6588 while ( name_type(q)==mp_subscr ) {
6589 mp_flush_below_variable(mp, q); r=q; q=link(q);
6590 mp_free_node(mp, r,subscr_node_size);
6592 r=attr_head(p); q=link(r); mp_recycle_value(mp, r);
6593 if ( name_type(p)<=mp_saved_root ) mp_free_node(mp, r,value_node_size);
6594 else mp_free_node(mp, r,subscr_node_size);
6595 /* we assume that |subscr_node_size=attr_node_size| */
6597 mp_flush_below_variable(mp, q); r=q; q=link(q); mp_free_node(mp, r,attr_node_size);
6598 } while (q!=end_attr);
6603 @ Just before assigning a new value to a variable, we will recycle the
6604 old value and make the old value undefined. The |und_type| routine
6605 determines what type of undefined value should be given, based on
6606 the current type before recycling.
6609 small_number mp_und_type (MP mp,pointer p) {
6611 case undefined: case mp_vacuous:
6613 case mp_boolean_type: case mp_unknown_boolean:
6614 return mp_unknown_boolean;
6615 case mp_string_type: case mp_unknown_string:
6616 return mp_unknown_string;
6617 case mp_pen_type: case mp_unknown_pen:
6618 return mp_unknown_pen;
6619 case mp_path_type: case mp_unknown_path:
6620 return mp_unknown_path;
6621 case mp_picture_type: case mp_unknown_picture:
6622 return mp_unknown_picture;
6623 case mp_transform_type: case mp_color_type: case mp_cmykcolor_type:
6624 case mp_pair_type: case mp_numeric_type:
6626 case mp_known: case mp_dependent: case mp_proto_dependent: case mp_independent:
6627 return mp_numeric_type;
6628 } /* there are no other cases */
6632 @ The |clear_symbol| routine is used when we want to redefine the equivalent
6633 of a symbolic token. It must remove any variable structure or macro
6634 definition that is currently attached to that symbol. If the |saving|
6635 parameter is true, a subsidiary structure is saved instead of destroyed.
6638 void mp_clear_symbol (MP mp,pointer p, boolean saving) {
6639 pointer q; /* |equiv(p)| */
6641 switch (eq_type(p) % outer_tag) {
6643 case secondary_primary_macro:
6644 case tertiary_secondary_macro:
6645 case expression_tertiary_macro:
6646 if ( ! saving ) mp_delete_mac_ref(mp, q);
6651 name_type(q)=mp_saved_root;
6653 mp_flush_below_variable(mp, q);
6654 mp_free_node(mp,q,value_node_size);
6661 mp->eqtb[p]=mp->eqtb[frozen_undefined];
6664 @* \[16] Saving and restoring equivalents.
6665 The nested structure given by \&{begingroup} and \&{endgroup}
6666 allows |eqtb| entries to be saved and restored, so that temporary changes
6667 can be made without difficulty. When the user requests a current value to
6668 be saved, \MP\ puts that value into its ``save stack.'' An appearance of
6669 \&{endgroup} ultimately causes the old values to be removed from the save
6670 stack and put back in their former places.
6672 The save stack is a linked list containing three kinds of entries,
6673 distinguished by their |info| fields. If |p| points to a saved item,
6677 |info(p)=0| stands for a group boundary; each \&{begingroup} contributes
6678 such an item to the save stack and each \&{endgroup} cuts back the stack
6679 until the most recent such entry has been removed.
6682 |info(p)=q|, where |1<=q<=hash_end|, means that |mem[p+1]| holds the former
6683 contents of |eqtb[q]|. Such save stack entries are generated by \&{save}
6687 |info(p)=hash_end+q|, where |q>0|, means that |value(p)| is a |scaled|
6688 integer to be restored to internal parameter number~|q|. Such entries
6689 are generated by \&{interim} commands.
6692 The global variable |save_ptr| points to the top item on the save stack.
6694 @d save_node_size 2 /* number of words per non-boundary save-stack node */
6695 @d saved_equiv(A) mp->mem[(A)+1].hh /* where an |eqtb| entry gets saved */
6696 @d save_boundary_item(A) { (A)=mp_get_avail(mp); info((A))=0;
6697 link((A))=mp->save_ptr; mp->save_ptr=(A);
6701 pointer save_ptr; /* the most recently saved item */
6703 @ @<Set init...@>=mp->save_ptr=null;
6705 @ The |save_variable| routine is given a hash address |q|; it salts this
6706 address in the save stack, together with its current equivalent,
6707 then makes token~|q| behave as though it were brand new.
6709 Nothing is stacked when |save_ptr=null|, however; there's no way to remove
6710 things from the stack when the program is not inside a group, so there's
6711 no point in wasting the space.
6713 @c void mp_save_variable (MP mp,pointer q) {
6714 pointer p; /* temporary register */
6715 if ( mp->save_ptr!=null ){
6716 p=mp_get_node(mp, save_node_size); info(p)=q; link(p)=mp->save_ptr;
6717 saved_equiv(p)=mp->eqtb[q]; mp->save_ptr=p;
6719 mp_clear_symbol(mp, q,(mp->save_ptr!=null));
6722 @ Similarly, |save_internal| is given the location |q| of an internal
6723 quantity like |mp_tracing_pens|. It creates a save stack entry of the
6726 @c void mp_save_internal (MP mp,halfword q) {
6727 pointer p; /* new item for the save stack */
6728 if ( mp->save_ptr!=null ){
6729 p=mp_get_node(mp, save_node_size); info(p)=hash_end+q;
6730 link(p)=mp->save_ptr; value(p)=mp->internal[q]; mp->save_ptr=p;
6734 @ At the end of a group, the |unsave| routine restores all of the saved
6735 equivalents in reverse order. This routine will be called only when there
6736 is at least one boundary item on the save stack.
6739 void mp_unsave (MP mp) {
6740 pointer q; /* index to saved item */
6741 pointer p; /* temporary register */
6742 while ( info(mp->save_ptr)!=0 ) {
6743 q=info(mp->save_ptr);
6745 if ( mp->internal[mp_tracing_restores]>0 ) {
6746 mp_begin_diagnostic(mp); mp_print_nl(mp, "{restoring ");
6747 mp_print(mp, mp->int_name[q-(hash_end)]); mp_print_char(mp, '=');
6748 mp_print_scaled(mp, value(mp->save_ptr)); mp_print_char(mp, '}');
6749 mp_end_diagnostic(mp, false);
6751 mp->internal[q-(hash_end)]=value(mp->save_ptr);
6753 if ( mp->internal[mp_tracing_restores]>0 ) {
6754 mp_begin_diagnostic(mp); mp_print_nl(mp, "{restoring ");
6755 mp_print_text(q); mp_print_char(mp, '}');
6756 mp_end_diagnostic(mp, false);
6758 mp_clear_symbol(mp, q,false);
6759 mp->eqtb[q]=saved_equiv(mp->save_ptr);
6760 if ( eq_type(q) % outer_tag==tag_token ) {
6762 if ( p!=null ) name_type(p)=mp_root;
6765 p=link(mp->save_ptr);
6766 mp_free_node(mp, mp->save_ptr,save_node_size); mp->save_ptr=p;
6768 p=link(mp->save_ptr); free_avail(mp->save_ptr); mp->save_ptr=p;
6771 @* \[17] Data structures for paths.
6772 When a \MP\ user specifies a path, \MP\ will create a list of knots
6773 and control points for the associated cubic spline curves. If the
6774 knots are $z_0$, $z_1$, \dots, $z_n$, there are control points
6775 $z_k^+$ and $z_{k+1}^-$ such that the cubic splines between knots
6776 $z_k$ and $z_{k+1}$ are defined by B\'ezier's formula
6777 @:Bezier}{B\'ezier, Pierre Etienne@>
6778 $$\eqalign{z(t)&=B(z_k,z_k^+,z_{k+1}^-,z_{k+1};t)\cr
6779 &=(1-t)^3z_k+3(1-t)^2tz_k^++3(1-t)t^2z_{k+1}^-+t^3z_{k+1}\cr}$$
6782 There is a 8-word node for each knot $z_k$, containing one word of
6783 control information and six words for the |x| and |y| coordinates of
6784 $z_k^-$ and $z_k$ and~$z_k^+$. The control information appears in the
6785 |left_type| and |right_type| fields, which each occupy a quarter of
6786 the first word in the node; they specify properties of the curve as it
6787 enters and leaves the knot. There's also a halfword |link| field,
6788 which points to the following knot, and a final supplementary word (of
6789 which only a quarter is used).
6791 If the path is a closed contour, knots 0 and |n| are identical;
6792 i.e., the |link| in knot |n-1| points to knot~0. But if the path
6793 is not closed, the |left_type| of knot~0 and the |right_type| of knot~|n|
6794 are equal to |endpoint|. In the latter case the |link| in knot~|n| points
6795 to knot~0, and the control points $z_0^-$ and $z_n^+$ are not used.
6797 @d left_type(A) mp->mem[(A)].hh.b0 /* characterizes the path entering this knot */
6798 @d right_type(A) mp->mem[(A)].hh.b1 /* characterizes the path leaving this knot */
6799 @d x_coord(A) mp->mem[(A)+1].sc /* the |x| coordinate of this knot */
6800 @d y_coord(A) mp->mem[(A)+2].sc /* the |y| coordinate of this knot */
6801 @d left_x(A) mp->mem[(A)+3].sc /* the |x| coordinate of previous control point */
6802 @d left_y(A) mp->mem[(A)+4].sc /* the |y| coordinate of previous control point */
6803 @d right_x(A) mp->mem[(A)+5].sc /* the |x| coordinate of next control point */
6804 @d right_y(A) mp->mem[(A)+6].sc /* the |y| coordinate of next control point */
6805 @d x_loc(A) ((A)+1) /* where the |x| coordinate is stored in a knot */
6806 @d y_loc(A) ((A)+2) /* where the |y| coordinate is stored in a knot */
6807 @d knot_coord(A) mp->mem[(A)].sc /* |x| or |y| coordinate given |x_loc| or |y_loc| */
6808 @d left_coord(A) mp->mem[(A)+2].sc
6809 /* coordinate of previous control point given |x_loc| or |y_loc| */
6810 @d right_coord(A) mp->mem[(A)+4].sc
6811 /* coordinate of next control point given |x_loc| or |y_loc| */
6812 @d knot_node_size 8 /* number of words in a knot node */
6816 mp_endpoint=0, /* |left_type| at path beginning and |right_type| at path end */
6817 mp_explicit, /* |left_type| or |right_type| when control points are known */
6818 mp_given, /* |left_type| or |right_type| when a direction is given */
6819 mp_curl, /* |left_type| or |right_type| when a curl is desired */
6820 mp_open, /* |left_type| or |right_type| when \MP\ should choose the direction */
6824 @ Before the B\'ezier control points have been calculated, the memory
6825 space they will ultimately occupy is taken up by information that can be
6826 used to compute them. There are four cases:
6829 \textindent{$\bullet$} If |right_type=mp_open|, the curve should leave
6830 the knot in the same direction it entered; \MP\ will figure out a
6834 \textindent{$\bullet$} If |right_type=mp_curl|, the curve should leave the
6835 knot in a direction depending on the angle at which it enters the next
6836 knot and on the curl parameter stored in |right_curl|.
6839 \textindent{$\bullet$} If |right_type=mp_given|, the curve should leave the
6840 knot in a nonzero direction stored as an |angle| in |right_given|.
6843 \textindent{$\bullet$} If |right_type=mp_explicit|, the B\'ezier control
6844 point for leaving this knot has already been computed; it is in the
6845 |right_x| and |right_y| fields.
6848 The rules for |left_type| are similar, but they refer to the curve entering
6849 the knot, and to \\{left} fields instead of \\{right} fields.
6851 Non-|explicit| control points will be chosen based on ``tension'' parameters
6852 in the |left_tension| and |right_tension| fields. The
6853 `\&{atleast}' option is represented by negative tension values.
6854 @:at_least_}{\&{atleast} primitive@>
6856 For example, the \MP\ path specification
6857 $$\.{z0..z1..tension atleast 1..\{curl 2\}z2..z3\{-1,-2\}..tension
6859 where \.p is the path `\.{z4..controls z45 and z54..z5}', will be represented
6861 \def\lodash{\hbox to 1.1em{\thinspace\hrulefill\thinspace}}
6862 $$\vbox{\halign{#\hfil&&\qquad#\hfil\cr
6863 |left_type|&\\{left} info&|x_coord,y_coord|&|right_type|&\\{right} info\cr
6865 |endpoint|&\lodash$,\,$\lodash&$x_0,y_0$&|curl|&$1.0,1.0$\cr
6866 |open|&\lodash$,1.0$&$x_1,y_1$&|open|&\lodash$,-1.0$\cr
6867 |curl|&$2.0,-1.0$&$x_2,y_2$&|curl|&$2.0,1.0$\cr
6868 |given|&$d,1.0$&$x_3,y_3$&|given|&$d,3.0$\cr
6869 |open|&\lodash$,4.0$&$x_4,y_4$&|explicit|&$x_{45},y_{45}$\cr
6870 |explicit|&$x_{54},y_{54}$&$x_5,y_5$&|endpoint|&\lodash$,\,$\lodash\cr}}$$
6871 Here |d| is the |angle| obtained by calling |n_arg(-unity,-two)|.
6872 Of course, this example is more complicated than anything a normal user
6875 These types must satisfy certain restrictions because of the form of \MP's
6877 (i)~|open| type never appears in the same node together with |endpoint|,
6879 (ii)~The |right_type| of a node is |explicit| if and only if the
6880 |left_type| of the following node is |explicit|.
6881 (iii)~|endpoint| types occur only at the ends, as mentioned above.
6883 @d left_curl left_x /* curl information when entering this knot */
6884 @d left_given left_x /* given direction when entering this knot */
6885 @d left_tension left_y /* tension information when entering this knot */
6886 @d right_curl right_x /* curl information when leaving this knot */
6887 @d right_given right_x /* given direction when leaving this knot */
6888 @d right_tension right_y /* tension information when leaving this knot */
6890 @ Knots can be user-supplied, or they can be created by program code,
6891 like the |split_cubic| function, or |copy_path|. The distinction is
6892 needed for the cleanup routine that runs after |split_cubic|, because
6893 it should only delete knots it has previously inserted, and never
6894 anything that was user-supplied. In order to be able to differentiate
6895 one knot from another, we will set |originator(p):=mp_metapost_user| when
6896 it appeared in the actual metapost program, and
6897 |originator(p):=mp_program_code| in all other cases.
6899 @d originator(A) mp->mem[(A)+7].hh.b0 /* the creator of this knot */
6903 mp_program_code=0, /* not created by a user */
6904 mp_metapost_user /* created by a user */
6907 @ Here is a routine that prints a given knot list
6908 in symbolic form. It illustrates the conventions discussed above,
6909 and checks for anomalies that might arise while \MP\ is being debugged.
6911 @<Declare subroutines for printing expressions@>=
6912 void mp_pr_path (MP mp,pointer h);
6915 void mp_pr_path (MP mp,pointer h) {
6916 pointer p,q; /* for list traversal */
6920 if ( (p==null)||(q==null) ) {
6921 mp_print_nl(mp, "???"); return; /* this won't happen */
6924 @<Print information for adjacent knots |p| and |q|@>;
6927 if ( (p!=h)||(left_type(h)!=mp_endpoint) ) {
6928 @<Print two dots, followed by |given| or |curl| if present@>;
6931 if ( left_type(h)!=mp_endpoint )
6932 mp_print(mp, "cycle");
6935 @ @<Print information for adjacent knots...@>=
6936 mp_print_two(mp, x_coord(p),y_coord(p));
6937 switch (right_type(p)) {
6939 if ( left_type(p)==mp_open ) mp_print(mp, "{open?}"); /* can't happen */
6941 if ( (left_type(q)!=mp_endpoint)||(q!=h) ) q=null; /* force an error */
6945 @<Print control points between |p| and |q|, then |goto done1|@>;
6948 @<Print information for a curve that begins |open|@>;
6952 @<Print information for a curve that begins |curl| or |given|@>;
6955 mp_print(mp, "???"); /* can't happen */
6959 if ( left_type(q)<=mp_explicit ) {
6960 mp_print(mp, "..control?"); /* can't happen */
6962 } else if ( (right_tension(p)!=unity)||(left_tension(q)!=unity) ) {
6963 @<Print tension between |p| and |q|@>;
6966 @ Since |n_sin_cos| produces |fraction| results, which we will print as if they
6967 were |scaled|, the magnitude of a |given| direction vector will be~4096.
6969 @<Print two dots...@>=
6971 mp_print_nl(mp, " ..");
6972 if ( left_type(p)==mp_given ) {
6973 mp_n_sin_cos(mp, left_given(p)); mp_print_char(mp, '{');
6974 mp_print_scaled(mp, mp->n_cos); mp_print_char(mp, ',');
6975 mp_print_scaled(mp, mp->n_sin); mp_print_char(mp, '}');
6976 } else if ( left_type(p)==mp_curl ){
6977 mp_print(mp, "{curl ");
6978 mp_print_scaled(mp, left_curl(p)); mp_print_char(mp, '}');
6982 @ @<Print tension between |p| and |q|@>=
6984 mp_print(mp, "..tension ");
6985 if ( right_tension(p)<0 ) mp_print(mp, "atleast");
6986 mp_print_scaled(mp, abs(right_tension(p)));
6987 if ( right_tension(p)!=left_tension(q) ){
6988 mp_print(mp, " and ");
6989 if ( left_tension(q)<0 ) mp_print(mp, "atleast");
6990 mp_print_scaled(mp, abs(left_tension(q)));
6994 @ @<Print control points between |p| and |q|, then |goto done1|@>=
6996 mp_print(mp, "..controls ");
6997 mp_print_two(mp, right_x(p),right_y(p));
6998 mp_print(mp, " and ");
6999 if ( left_type(q)!=mp_explicit ) {
7000 mp_print(mp, "??"); /* can't happen */
7003 mp_print_two(mp, left_x(q),left_y(q));
7008 @ @<Print information for a curve that begins |open|@>=
7009 if ( (left_type(p)!=mp_explicit)&&(left_type(p)!=mp_open) ) {
7010 mp_print(mp, "{open?}"); /* can't happen */
7014 @ A curl of 1 is shown explicitly, so that the user sees clearly that
7015 \MP's default curl is present.
7017 @<Print information for a curve that begins |curl|...@>=
7019 if ( left_type(p)==mp_open )
7020 mp_print(mp, "??"); /* can't happen */
7022 if ( right_type(p)==mp_curl ) {
7023 mp_print(mp, "{curl "); mp_print_scaled(mp, right_curl(p));
7025 mp_n_sin_cos(mp, right_given(p)); mp_print_char(mp, '{');
7026 mp_print_scaled(mp, mp->n_cos); mp_print_char(mp, ',');
7027 mp_print_scaled(mp, mp->n_sin);
7029 mp_print_char(mp, '}');
7032 @ It is convenient to have another version of |pr_path| that prints the path
7033 as a diagnostic message.
7035 @<Declare subroutines for printing expressions@>=
7036 void mp_print_path (MP mp,pointer h, const char *s, boolean nuline) {
7037 mp_print_diagnostic(mp, "Path", s, nuline); mp_print_ln(mp);
7040 mp_end_diagnostic(mp, true);
7043 @ If we want to duplicate a knot node, we can say |copy_knot|:
7046 pointer mp_copy_knot (MP mp,pointer p) {
7047 pointer q; /* the copy */
7048 int k; /* runs through the words of a knot node */
7049 q=mp_get_node(mp, knot_node_size);
7050 for (k=0;k<knot_node_size;k++) {
7051 mp->mem[q+k]=mp->mem[p+k];
7053 originator(q)=originator(p);
7057 @ The |copy_path| routine makes a clone of a given path.
7060 pointer mp_copy_path (MP mp, pointer p) {
7061 pointer q,pp,qq; /* for list manipulation */
7062 q=mp_copy_knot(mp, p);
7065 link(qq)=mp_copy_knot(mp, pp);
7074 @ Just before |ship_out|, knot lists are exported for printing.
7076 The |gr_XXXX| macros are defined in |mppsout.h|.
7079 mp_knot *mp_export_knot (MP mp,pointer p) {
7080 mp_knot *q; /* the copy */
7083 q = mp_xmalloc(mp, 1, sizeof (mp_knot));
7084 memset(q,0,sizeof (mp_knot));
7085 gr_left_type(q) = left_type(p);
7086 gr_right_type(q) = right_type(p);
7087 gr_x_coord(q) = x_coord(p);
7088 gr_y_coord(q) = y_coord(p);
7089 gr_left_x(q) = left_x(p);
7090 gr_left_y(q) = left_y(p);
7091 gr_right_x(q) = right_x(p);
7092 gr_right_y(q) = right_y(p);
7093 gr_originator(q) = originator(p);
7097 @ The |export_knot_list| routine therefore also makes a clone
7101 mp_knot *mp_export_knot_list (MP mp, pointer p) {
7102 mp_knot *q, *qq; /* for list manipulation */
7103 pointer pp; /* for list manipulation */
7106 q=mp_export_knot(mp, p);
7109 gr_next_knot(qq)=mp_export_knot(mp, pp);
7110 qq=gr_next_knot(qq);
7118 @ Similarly, there's a way to copy the {\sl reverse\/} of a path. This procedure
7119 returns a pointer to the first node of the copy, if the path is a cycle,
7120 but to the final node of a non-cyclic copy. The global
7121 variable |path_tail| will point to the final node of the original path;
7122 this trick makes it easier to implement `\&{doublepath}'.
7124 All node types are assumed to be |endpoint| or |explicit| only.
7127 pointer mp_htap_ypoc (MP mp,pointer p) {
7128 pointer q,pp,qq,rr; /* for list manipulation */
7129 q=mp_get_node(mp, knot_node_size); /* this will correspond to |p| */
7132 right_type(qq)=left_type(pp); left_type(qq)=right_type(pp);
7133 x_coord(qq)=x_coord(pp); y_coord(qq)=y_coord(pp);
7134 right_x(qq)=left_x(pp); right_y(qq)=left_y(pp);
7135 left_x(qq)=right_x(pp); left_y(qq)=right_y(pp);
7136 originator(qq)=originator(pp);
7137 if ( link(pp)==p ) {
7138 link(q)=qq; mp->path_tail=pp; return q;
7140 rr=mp_get_node(mp, knot_node_size); link(rr)=qq; qq=rr; pp=link(pp);
7145 pointer path_tail; /* the node that links to the beginning of a path */
7147 @ When a cyclic list of knot nodes is no longer needed, it can be recycled by
7148 calling the following subroutine.
7150 @<Declare the recycling subroutines@>=
7151 void mp_toss_knot_list (MP mp,pointer p) ;
7154 void mp_toss_knot_list (MP mp,pointer p) {
7155 pointer q; /* the node being freed */
7156 pointer r; /* the next node */
7160 mp_free_node(mp, q,knot_node_size); q=r;
7164 @* \[18] Choosing control points.
7165 Now we must actually delve into one of \MP's more difficult routines,
7166 the |make_choices| procedure that chooses angles and control points for
7167 the splines of a curve when the user has not specified them explicitly.
7168 The parameter to |make_choices| points to a list of knots and
7169 path information, as described above.
7171 A path decomposes into independent segments at ``breakpoint'' knots,
7172 which are knots whose left and right angles are both prespecified in
7173 some way (i.e., their |left_type| and |right_type| aren't both open).
7176 @<Declare the procedure called |solve_choices|@>
7177 void mp_make_choices (MP mp,pointer knots) {
7178 pointer h; /* the first breakpoint */
7179 pointer p,q; /* consecutive breakpoints being processed */
7180 @<Other local variables for |make_choices|@>;
7181 check_arith; /* make sure that |arith_error=false| */
7182 if ( mp->internal[mp_tracing_choices]>0 )
7183 mp_print_path(mp, knots,", before choices",true);
7184 @<If consecutive knots are equal, join them explicitly@>;
7185 @<Find the first breakpoint, |h|, on the path;
7186 insert an artificial breakpoint if the path is an unbroken cycle@>;
7189 @<Fill in the control points between |p| and the next breakpoint,
7190 then advance |p| to that breakpoint@>;
7192 if ( mp->internal[mp_tracing_choices]>0 )
7193 mp_print_path(mp, knots,", after choices",true);
7194 if ( mp->arith_error ) {
7195 @<Report an unexpected problem during the choice-making@>;
7199 @ @<Report an unexpected problem during the choice...@>=
7201 print_err("Some number got too big");
7202 @.Some number got too big@>
7203 help2("The path that I just computed is out of range.")
7204 ("So it will probably look funny. Proceed, for a laugh.");
7205 mp_put_get_error(mp); mp->arith_error=false;
7208 @ Two knots in a row with the same coordinates will always be joined
7209 by an explicit ``curve'' whose control points are identical with the
7212 @<If consecutive knots are equal, join them explicitly@>=
7216 if ( x_coord(p)==x_coord(q) && y_coord(p)==y_coord(q) && right_type(p)>mp_explicit ) {
7217 right_type(p)=mp_explicit;
7218 if ( left_type(p)==mp_open ) {
7219 left_type(p)=mp_curl; left_curl(p)=unity;
7221 left_type(q)=mp_explicit;
7222 if ( right_type(q)==mp_open ) {
7223 right_type(q)=mp_curl; right_curl(q)=unity;
7225 right_x(p)=x_coord(p); left_x(q)=x_coord(p);
7226 right_y(p)=y_coord(p); left_y(q)=y_coord(p);
7231 @ If there are no breakpoints, it is necessary to compute the direction
7232 angles around an entire cycle. In this case the |left_type| of the first
7233 node is temporarily changed to |end_cycle|.
7235 @<Find the first breakpoint, |h|, on the path...@>=
7238 if ( left_type(h)!=mp_open ) break;
7239 if ( right_type(h)!=mp_open ) break;
7242 left_type(h)=mp_end_cycle; break;
7246 @ If |right_type(p)<given| and |q=link(p)|, we must have
7247 |right_type(p)=left_type(q)=mp_explicit| or |endpoint|.
7249 @<Fill in the control points between |p| and the next breakpoint...@>=
7251 if ( right_type(p)>=mp_given ) {
7252 while ( (left_type(q)==mp_open)&&(right_type(q)==mp_open) ) q=link(q);
7253 @<Fill in the control information between
7254 consecutive breakpoints |p| and |q|@>;
7255 } else if ( right_type(p)==mp_endpoint ) {
7256 @<Give reasonable values for the unused control points between |p| and~|q|@>;
7260 @ This step makes it possible to transform an explicitly computed path without
7261 checking the |left_type| and |right_type| fields.
7263 @<Give reasonable values for the unused control points between |p| and~|q|@>=
7265 right_x(p)=x_coord(p); right_y(p)=y_coord(p);
7266 left_x(q)=x_coord(q); left_y(q)=y_coord(q);
7269 @ Before we can go further into the way choices are made, we need to
7270 consider the underlying theory. The basic ideas implemented in |make_choices|
7271 are due to John Hobby, who introduced the notion of ``mock curvature''
7272 @^Hobby, John Douglas@>
7273 at a knot. Angles are chosen so that they preserve mock curvature when
7274 a knot is passed, and this has been found to produce excellent results.
7276 It is convenient to introduce some notations that simplify the necessary
7277 formulas. Let $d_{k,k+1}=\vert z\k-z_k\vert$ be the (nonzero) distance
7278 between knots |k| and |k+1|; and let
7279 $${z\k-z_k\over z_k-z_{k-1}}={d_{k,k+1}\over d_{k-1,k}}e^{i\psi_k}$$
7280 so that a polygonal line from $z_{k-1}$ to $z_k$ to $z\k$ turns left
7281 through an angle of~$\psi_k$. We assume that $\vert\psi_k\vert\L180^\circ$.
7282 The control points for the spline from $z_k$ to $z\k$ will be denoted by
7283 $$\eqalign{z_k^+&=z_k+
7284 \textstyle{1\over3}\rho_k e^{i\theta_k}(z\k-z_k),\cr
7286 \textstyle{1\over3}\sigma\k e^{-i\phi\k}(z\k-z_k),\cr}$$
7287 where $\rho_k$ and $\sigma\k$ are nonnegative ``velocity ratios'' at the
7288 beginning and end of the curve, while $\theta_k$ and $\phi\k$ are the
7289 corresponding ``offset angles.'' These angles satisfy the condition
7290 $$\theta_k+\phi_k+\psi_k=0,\eqno(*)$$
7291 whenever the curve leaves an intermediate knot~|k| in the direction that
7294 @ Let $\alpha_k$ and $\beta\k$ be the reciprocals of the ``tension'' of
7295 the curve at its beginning and ending points. This means that
7296 $\rho_k=\alpha_k f(\theta_k,\phi\k)$ and $\sigma\k=\beta\k f(\phi\k,\theta_k)$,
7297 where $f(\theta,\phi)$ is \MP's standard velocity function defined in
7298 the |velocity| subroutine. The cubic spline $B(z_k^{\phantom+},z_k^+,
7299 z\k^-,z\k^{\phantom+};t)$
7302 $${2\sigma\k\sin(\theta_k+\phi\k)-6\sin\theta_k\over\rho_k^2d_{k,k+1}}
7303 \qquad{\rm and}\qquad
7304 {2\rho_k\sin(\theta_k+\phi\k)-6\sin\phi\k\over\sigma\k^2d_{k,k+1}}$$
7305 at |t=0| and |t=1|, respectively. The mock curvature is the linear
7307 approximation to this true curvature that arises in the limit for
7308 small $\theta_k$ and~$\phi\k$, if second-order terms are discarded.
7309 The standard velocity function satisfies
7310 $$f(\theta,\phi)=1+O(\theta^2+\theta\phi+\phi^2);$$
7311 hence the mock curvatures are respectively
7312 $${2\beta\k(\theta_k+\phi\k)-6\theta_k\over\alpha_k^2d_{k,k+1}}
7313 \qquad{\rm and}\qquad
7314 {2\alpha_k(\theta_k+\phi\k)-6\phi\k\over\beta\k^2d_{k,k+1}}.\eqno(**)$$
7316 @ The turning angles $\psi_k$ are given, and equation $(*)$ above
7317 determines $\phi_k$ when $\theta_k$ is known, so the task of
7318 angle selection is essentially to choose appropriate values for each
7319 $\theta_k$. When equation~$(*)$ is used to eliminate $\phi$~variables
7320 from $(**)$, we obtain a system of linear equations of the form
7321 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
7323 $$A_k={\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
7324 \qquad B_k={3-\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
7325 \qquad C_k={3-\beta\k\over\alpha_k^2d_{k,k+1}},
7326 \qquad D_k={\beta\k\over\alpha_k^2d_{k,k+1}}.$$
7327 The tensions are always $3\over4$ or more, hence each $\alpha$ and~$\beta$
7328 will be at most $4\over3$. It follows that $B_k\G{5\over4}A_k$ and
7329 $C_k\G{5\over4}D_k$; hence the equations are diagonally dominant;
7330 hence they have a unique solution. Moreover, in most cases the tensions
7331 are equal to~1, so that $B_k=2A_k$ and $C_k=2D_k$. This makes the
7332 solution numerically stable, and there is an exponential damping
7333 effect: The data at knot $k\pm j$ affects the angle at knot~$k$ by
7334 a factor of~$O(2^{-j})$.
7336 @ However, we still must consider the angles at the starting and ending
7337 knots of a non-cyclic path. These angles might be given explicitly, or
7338 they might be specified implicitly in terms of an amount of ``curl.''
7340 Let's assume that angles need to be determined for a non-cyclic path
7341 starting at $z_0$ and ending at~$z_n$. Then equations of the form
7342 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta_{k+1}=R_k$$
7343 have been given for $0<k<n$, and it will be convenient to introduce
7344 equations of the same form for $k=0$ and $k=n$, where
7345 $$A_0=B_0=C_n=D_n=0.$$
7346 If $\theta_0$ is supposed to have a given value $E_0$, we simply
7347 define $C_0=1$, $D_0=0$, and $R_0=E_0$. Otherwise a curl
7348 parameter, $\gamma_0$, has been specified at~$z_0$; this means
7349 that the mock curvature at $z_0$ should be $\gamma_0$ times the
7350 mock curvature at $z_1$; i.e.,
7351 $${2\beta_1(\theta_0+\phi_1)-6\theta_0\over\alpha_0^2d_{01}}
7352 =\gamma_0{2\alpha_0(\theta_0+\phi_1)-6\phi_1\over\beta_1^2d_{01}}.$$
7353 This equation simplifies to
7354 $$(\alpha_0\chi_0+3-\beta_1)\theta_0+
7355 \bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\theta_1=
7356 -\bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\psi_1,$$
7357 where $\chi_0=\alpha_0^2\gamma_0/\beta_1^2$; so we can set $C_0=
7358 \chi_0\alpha_0+3-\beta_1$, $D_0=(3-\alpha_0)\chi_0+\beta_1$, $R_0=-D_0\psi_1$.
7359 It can be shown that $C_0>0$ and $C_0B_1-A_1D_0>0$ when $\gamma_0\G0$,
7360 hence the linear equations remain nonsingular.
7362 Similar considerations apply at the right end, when the final angle $\phi_n$
7363 may or may not need to be determined. It is convenient to let $\psi_n=0$,
7364 hence $\theta_n=-\phi_n$. We either have an explicit equation $\theta_n=E_n$,
7366 $$\bigl((3-\beta_n)\chi_n+\alpha_{n-1}\bigr)\theta_{n-1}+
7367 (\beta_n\chi_n+3-\alpha_{n-1})\theta_n=0,\qquad
7368 \chi_n={\beta_n^2\gamma_n\over\alpha_{n-1}^2}.$$
7370 When |make_choices| chooses angles, it must compute the coefficients of
7371 these linear equations, then solve the equations. To compute the coefficients,
7372 it is necessary to compute arctangents of the given turning angles~$\psi_k$.
7373 When the equations are solved, the chosen directions $\theta_k$ are put
7374 back into the form of control points by essentially computing sines and
7377 @ OK, we are ready to make the hard choices of |make_choices|.
7378 Most of the work is relegated to an auxiliary procedure
7379 called |solve_choices|, which has been introduced to keep
7380 |make_choices| from being extremely long.
7382 @<Fill in the control information between...@>=
7383 @<Calculate the turning angles $\psi_k$ and the distances $d_{k,k+1}$;
7384 set $n$ to the length of the path@>;
7385 @<Remove |open| types at the breakpoints@>;
7386 mp_solve_choices(mp, p,q,n)
7388 @ It's convenient to precompute quantities that will be needed several
7389 times later. The values of |delta_x[k]| and |delta_y[k]| will be the
7390 coordinates of $z\k-z_k$, and the magnitude of this vector will be
7391 |delta[k]=@t$d_{k,k+1}$@>|. The path angle $\psi_k$ between $z_k-z_{k-1}$
7392 and $z\k-z_k$ will be stored in |psi[k]|.
7395 int path_size; /* maximum number of knots between breakpoints of a path */
7398 scaled *delta; /* knot differences */
7399 angle *psi; /* turning angles */
7401 @ @<Dealloc variables@>=
7407 @ @<Other local variables for |make_choices|@>=
7408 int k,n; /* current and final knot numbers */
7409 pointer s,t; /* registers for list traversal */
7410 scaled delx,dely; /* directions where |open| meets |explicit| */
7411 fraction sine,cosine; /* trig functions of various angles */
7413 @ @<Calculate the turning angles...@>=
7416 k=0; s=p; n=mp->path_size;
7419 mp->delta_x[k]=x_coord(t)-x_coord(s);
7420 mp->delta_y[k]=y_coord(t)-y_coord(s);
7421 mp->delta[k]=mp_pyth_add(mp, mp->delta_x[k],mp->delta_y[k]);
7423 sine=mp_make_fraction(mp, mp->delta_y[k-1],mp->delta[k-1]);
7424 cosine=mp_make_fraction(mp, mp->delta_x[k-1],mp->delta[k-1]);
7425 mp->psi[k]=mp_n_arg(mp, mp_take_fraction(mp, mp->delta_x[k],cosine)+
7426 mp_take_fraction(mp, mp->delta_y[k],sine),
7427 mp_take_fraction(mp, mp->delta_y[k],cosine)-
7428 mp_take_fraction(mp, mp->delta_x[k],sine));
7431 if ( k==mp->path_size ) {
7432 mp_reallocate_paths(mp, mp->path_size+(mp->path_size>>2));
7433 goto RESTART; /* retry, loop size has changed */
7436 } while (!((k>=n)&&(left_type(s)!=mp_end_cycle)));
7437 if ( k==n ) mp->psi[n]=0; else mp->psi[k]=mp->psi[1];
7440 @ When we get to this point of the code, |right_type(p)| is either
7441 |given| or |curl| or |open|. If it is |open|, we must have
7442 |left_type(p)=mp_end_cycle| or |left_type(p)=mp_explicit|. In the latter
7443 case, the |open| type is converted to |given|; however, if the
7444 velocity coming into this knot is zero, the |open| type is
7445 converted to a |curl|, since we don't know the incoming direction.
7447 Similarly, |left_type(q)| is either |given| or |curl| or |open| or
7448 |mp_end_cycle|. The |open| possibility is reduced either to |given| or to |curl|.
7450 @<Remove |open| types at the breakpoints@>=
7451 if ( left_type(q)==mp_open ) {
7452 delx=right_x(q)-x_coord(q); dely=right_y(q)-y_coord(q);
7453 if ( (delx==0)&&(dely==0) ) {
7454 left_type(q)=mp_curl; left_curl(q)=unity;
7456 left_type(q)=mp_given; left_given(q)=mp_n_arg(mp, delx,dely);
7459 if ( (right_type(p)==mp_open)&&(left_type(p)==mp_explicit) ) {
7460 delx=x_coord(p)-left_x(p); dely=y_coord(p)-left_y(p);
7461 if ( (delx==0)&&(dely==0) ) {
7462 right_type(p)=mp_curl; right_curl(p)=unity;
7464 right_type(p)=mp_given; right_given(p)=mp_n_arg(mp, delx,dely);
7468 @ Linear equations need to be solved whenever |n>1|; and also when |n=1|
7469 and exactly one of the breakpoints involves a curl. The simplest case occurs
7470 when |n=1| and there is a curl at both breakpoints; then we simply draw
7473 But before coding up the simple cases, we might as well face the general case,
7474 since we must deal with it sooner or later, and since the general case
7475 is likely to give some insight into the way simple cases can be handled best.
7477 When there is no cycle, the linear equations to be solved form a tridiagonal
7478 system, and we can apply the standard technique of Gaussian elimination
7479 to convert that system to a sequence of equations of the form
7480 $$\theta_0+u_0\theta_1=v_0,\quad
7481 \theta_1+u_1\theta_2=v_1,\quad\ldots,\quad
7482 \theta_{n-1}+u_{n-1}\theta_n=v_{n-1},\quad
7484 It is possible to do this diagonalization while generating the equations.
7485 Once $\theta_n$ is known, it is easy to determine $\theta_{n-1}$, \dots,
7486 $\theta_1$, $\theta_0$; thus, the equations will be solved.
7488 The procedure is slightly more complex when there is a cycle, but the
7489 basic idea will be nearly the same. In the cyclic case the right-hand
7490 sides will be $v_k+w_k\theta_0$ instead of simply $v_k$, and we will start
7491 the process off with $u_0=v_0=0$, $w_0=1$. The final equation will be not
7492 $\theta_n=v_n$ but $\theta_n+u_n\theta_1=v_n+w_n\theta_0$; an appropriate
7493 ending routine will take account of the fact that $\theta_n=\theta_0$ and
7494 eliminate the $w$'s from the system, after which the solution can be
7497 When $u_k$, $v_k$, and $w_k$ are being computed, the three pointer
7498 variables |r|, |s|,~|t| will point respectively to knots |k-1|, |k|,
7499 and~|k+1|. The $u$'s and $w$'s are scaled by $2^{28}$, i.e., they are
7500 of type |fraction|; the $\theta$'s and $v$'s are of type |angle|.
7503 angle *theta; /* values of $\theta_k$ */
7504 fraction *uu; /* values of $u_k$ */
7505 angle *vv; /* values of $v_k$ */
7506 fraction *ww; /* values of $w_k$ */
7508 @ @<Dealloc variables@>=
7514 @ @<Declare |mp_reallocate| functions@>=
7515 void mp_reallocate_paths (MP mp, int l);
7518 void mp_reallocate_paths (MP mp, int l) {
7519 XREALLOC (mp->delta_x, l, scaled);
7520 XREALLOC (mp->delta_y, l, scaled);
7521 XREALLOC (mp->delta, l, scaled);
7522 XREALLOC (mp->psi, l, angle);
7523 XREALLOC (mp->theta, l, angle);
7524 XREALLOC (mp->uu, l, fraction);
7525 XREALLOC (mp->vv, l, angle);
7526 XREALLOC (mp->ww, l, fraction);
7530 @ Our immediate problem is to get the ball rolling by setting up the
7531 first equation or by realizing that no equations are needed, and to fit
7532 this initialization into a framework suitable for the overall computation.
7534 @<Declare the procedure called |solve_choices|@>=
7535 @<Declare subroutines needed by |solve_choices|@>
7536 void mp_solve_choices (MP mp,pointer p, pointer q, halfword n) {
7537 int k; /* current knot number */
7538 pointer r,s,t; /* registers for list traversal */
7539 @<Other local variables for |solve_choices|@>;
7544 @<Get the linear equations started; or |return|
7545 with the control points in place, if linear equations
7548 switch (left_type(s)) {
7549 case mp_end_cycle: case mp_open:
7550 @<Set up equation to match mock curvatures
7551 at $z_k$; then |goto found| with $\theta_n$
7552 adjusted to equal $\theta_0$, if a cycle has ended@>;
7555 @<Set up equation for a curl at $\theta_n$
7559 @<Calculate the given value of $\theta_n$
7562 } /* there are no other cases */
7567 @<Finish choosing angles and assigning control points@>;
7570 @ On the first time through the loop, we have |k=0| and |r| is not yet
7571 defined. The first linear equation, if any, will have $A_0=B_0=0$.
7573 @<Get the linear equations started...@>=
7574 switch (right_type(s)) {
7576 if ( left_type(t)==mp_given ) {
7577 @<Reduce to simple case of two givens and |return|@>
7579 @<Set up the equation for a given value of $\theta_0$@>;
7583 if ( left_type(t)==mp_curl ) {
7584 @<Reduce to simple case of straight line and |return|@>
7586 @<Set up the equation for a curl at $\theta_0$@>;
7590 mp->uu[0]=0; mp->vv[0]=0; mp->ww[0]=fraction_one;
7591 /* this begins a cycle */
7593 } /* there are no other cases */
7595 @ The general equation that specifies equality of mock curvature at $z_k$ is
7596 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
7597 as derived above. We want to combine this with the already-derived equation
7598 $\theta_{k-1}+u_{k-1}\theta_k=v_{k-1}+w_{k-1}\theta_0$ in order to obtain
7600 $\theta_k+u_k\theta\k=v_k+w_k\theta_0$. This can be done by dividing the
7602 $$(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}
7603 -A_kw_{k-1}\theta_0$$
7604 by $B_k-u_{k-1}A_k+C_k$. The trick is to do this carefully with
7605 fixed-point arithmetic, avoiding the chance of overflow while retaining
7608 The calculations will be performed in several registers that
7609 provide temporary storage for intermediate quantities.
7611 @<Other local variables for |solve_choices|@>=
7612 fraction aa,bb,cc,ff,acc; /* temporary registers */
7613 scaled dd,ee; /* likewise, but |scaled| */
7614 scaled lt,rt; /* tension values */
7616 @ @<Set up equation to match mock curvatures...@>=
7617 { @<Calculate the values $\\{aa}=A_k/B_k$, $\\{bb}=D_k/C_k$,
7618 $\\{dd}=(3-\alpha_{k-1})d_{k,k+1}$, $\\{ee}=(3-\beta\k)d_{k-1,k}$,
7619 and $\\{cc}=(B_k-u_{k-1}A_k)/B_k$@>;
7620 @<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>;
7621 mp->uu[k]=mp_take_fraction(mp, ff,bb);
7622 @<Calculate the values of $v_k$ and $w_k$@>;
7623 if ( left_type(s)==mp_end_cycle ) {
7624 @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>;
7628 @ Since tension values are never less than 3/4, the values |aa| and
7629 |bb| computed here are never more than 4/5.
7631 @<Calculate the values $\\{aa}=...@>=
7632 if ( abs(right_tension(r))==unity) {
7633 aa=fraction_half; dd=2*mp->delta[k];
7635 aa=mp_make_fraction(mp, unity,3*abs(right_tension(r))-unity);
7636 dd=mp_take_fraction(mp, mp->delta[k],
7637 fraction_three-mp_make_fraction(mp, unity,abs(right_tension(r))));
7639 if ( abs(left_tension(t))==unity ){
7640 bb=fraction_half; ee=2*mp->delta[k-1];
7642 bb=mp_make_fraction(mp, unity,3*abs(left_tension(t))-unity);
7643 ee=mp_take_fraction(mp, mp->delta[k-1],
7644 fraction_three-mp_make_fraction(mp, unity,abs(left_tension(t))));
7646 cc=fraction_one-mp_take_fraction(mp, mp->uu[k-1],aa)
7648 @ The ratio to be calculated in this step can be written in the form
7649 $$\beta_k^2\cdot\\{ee}\over\beta_k^2\cdot\\{ee}+\alpha_k^2\cdot
7650 \\{cc}\cdot\\{dd},$$
7651 because of the quantities just calculated. The values of |dd| and |ee|
7652 will not be needed after this step has been performed.
7654 @<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>=
7655 dd=mp_take_fraction(mp, dd,cc); lt=abs(left_tension(s)); rt=abs(right_tension(s));
7656 if ( lt!=rt ) { /* $\beta_k^{-1}\ne\alpha_k^{-1}$ */
7658 ff=mp_make_fraction(mp, lt,rt);
7659 ff=mp_take_fraction(mp, ff,ff); /* $\alpha_k^2/\beta_k^2$ */
7660 dd=mp_take_fraction(mp, dd,ff);
7662 ff=mp_make_fraction(mp, rt,lt);
7663 ff=mp_take_fraction(mp, ff,ff); /* $\beta_k^2/\alpha_k^2$ */
7664 ee=mp_take_fraction(mp, ee,ff);
7667 ff=mp_make_fraction(mp, ee,ee+dd)
7669 @ The value of $u_{k-1}$ will be |<=1| except when $k=1$ and the previous
7670 equation was specified by a curl. In that case we must use a special
7671 method of computation to prevent overflow.
7673 Fortunately, the calculations turn out to be even simpler in this ``hard''
7674 case. The curl equation makes $w_0=0$ and $v_0=-u_0\psi_1$, hence
7675 $-B_1\psi_1-A_1v_0=-(B_1-u_0A_1)\psi_1=-\\{cc}\cdot B_1\psi_1$.
7677 @<Calculate the values of $v_k$ and $w_k$@>=
7678 acc=-mp_take_fraction(mp, mp->psi[k+1],mp->uu[k]);
7679 if ( right_type(r)==mp_curl ) {
7681 mp->vv[k]=acc-mp_take_fraction(mp, mp->psi[1],fraction_one-ff);
7683 ff=mp_make_fraction(mp, fraction_one-ff,cc); /* this is
7684 $B_k/(C_k+B_k-u_{k-1}A_k)<5$ */
7685 acc=acc-mp_take_fraction(mp, mp->psi[k],ff);
7686 ff=mp_take_fraction(mp, ff,aa); /* this is $A_k/(C_k+B_k-u_{k-1}A_k)$ */
7687 mp->vv[k]=acc-mp_take_fraction(mp, mp->vv[k-1],ff);
7688 if ( mp->ww[k-1]==0 ) mp->ww[k]=0;
7689 else mp->ww[k]=-mp_take_fraction(mp, mp->ww[k-1],ff);
7692 @ When a complete cycle has been traversed, we have $\theta_k+u_k\theta\k=
7693 v_k+w_k\theta_0$, for |1<=k<=n|. We would like to determine the value of
7694 $\theta_n$ and reduce the system to the form $\theta_k+u_k\theta\k=v_k$
7695 for |0<=k<n|, so that the cyclic case can be finished up just as if there
7698 The idea in the following code is to observe that
7699 $$\eqalign{\theta_n&=v_n+w_n\theta_0-u_n\theta_1=\cdots\cr
7700 &=v_n+w_n\theta_0-u_n\bigl(v_1+w_1\theta_0-u_1(v_2+\cdots
7701 -u_{n-2}(v_{n-1}+w_{n-1}\theta_0-u_{n-1}\theta_0))\bigr),\cr}$$
7702 so we can solve for $\theta_n=\theta_0$.
7704 @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>=
7706 aa=0; bb=fraction_one; /* we have |k=n| */
7709 aa=mp->vv[k]-mp_take_fraction(mp, aa,mp->uu[k]);
7710 bb=mp->ww[k]-mp_take_fraction(mp, bb,mp->uu[k]);
7711 } while (k!=n); /* now $\theta_n=\\{aa}+\\{bb}\cdot\theta_n$ */
7712 aa=mp_make_fraction(mp, aa,fraction_one-bb);
7713 mp->theta[n]=aa; mp->vv[0]=aa;
7714 for (k=1;k<=n-1;k++) {
7715 mp->vv[k]=mp->vv[k]+mp_take_fraction(mp, aa,mp->ww[k]);
7720 @ @d reduce_angle(A) if ( abs((A))>one_eighty_deg ) {
7721 if ( (A)>0 ) (A)=(A)-three_sixty_deg; else (A)=(A)+three_sixty_deg; }
7723 @<Calculate the given value of $\theta_n$...@>=
7725 mp->theta[n]=left_given(s)-mp_n_arg(mp, mp->delta_x[n-1],mp->delta_y[n-1]);
7726 reduce_angle(mp->theta[n]);
7730 @ @<Set up the equation for a given value of $\theta_0$@>=
7732 mp->vv[0]=right_given(s)-mp_n_arg(mp, mp->delta_x[0],mp->delta_y[0]);
7733 reduce_angle(mp->vv[0]);
7734 mp->uu[0]=0; mp->ww[0]=0;
7737 @ @<Set up the equation for a curl at $\theta_0$@>=
7738 { cc=right_curl(s); lt=abs(left_tension(t)); rt=abs(right_tension(s));
7739 if ( (rt==unity)&&(lt==unity) )
7740 mp->uu[0]=mp_make_fraction(mp, cc+cc+unity,cc+two);
7742 mp->uu[0]=mp_curl_ratio(mp, cc,rt,lt);
7743 mp->vv[0]=-mp_take_fraction(mp, mp->psi[1],mp->uu[0]); mp->ww[0]=0;
7746 @ @<Set up equation for a curl at $\theta_n$...@>=
7747 { cc=left_curl(s); lt=abs(left_tension(s)); rt=abs(right_tension(r));
7748 if ( (rt==unity)&&(lt==unity) )
7749 ff=mp_make_fraction(mp, cc+cc+unity,cc+two);
7751 ff=mp_curl_ratio(mp, cc,lt,rt);
7752 mp->theta[n]=-mp_make_fraction(mp, mp_take_fraction(mp, mp->vv[n-1],ff),
7753 fraction_one-mp_take_fraction(mp, ff,mp->uu[n-1]));
7757 @ The |curl_ratio| subroutine has three arguments, which our previous notation
7758 encourages us to call $\gamma$, $\alpha^{-1}$, and $\beta^{-1}$. It is
7759 a somewhat tedious program to calculate
7760 $${(3-\alpha)\alpha^2\gamma+\beta^3\over
7761 \alpha^3\gamma+(3-\beta)\beta^2},$$
7762 with the result reduced to 4 if it exceeds 4. (This reduction of curl
7763 is necessary only if the curl and tension are both large.)
7764 The values of $\alpha$ and $\beta$ will be at most~4/3.
7766 @<Declare subroutines needed by |solve_choices|@>=
7767 fraction mp_curl_ratio (MP mp,scaled gamma, scaled a_tension,
7769 fraction alpha,beta,num,denom,ff; /* registers */
7770 alpha=mp_make_fraction(mp, unity,a_tension);
7771 beta=mp_make_fraction(mp, unity,b_tension);
7772 if ( alpha<=beta ) {
7773 ff=mp_make_fraction(mp, alpha,beta); ff=mp_take_fraction(mp, ff,ff);
7774 gamma=mp_take_fraction(mp, gamma,ff);
7775 beta=beta / 010000; /* convert |fraction| to |scaled| */
7776 denom=mp_take_fraction(mp, gamma,alpha)+three-beta;
7777 num=mp_take_fraction(mp, gamma,fraction_three-alpha)+beta;
7779 ff=mp_make_fraction(mp, beta,alpha); ff=mp_take_fraction(mp, ff,ff);
7780 beta=mp_take_fraction(mp, beta,ff) / 010000; /* convert |fraction| to |scaled| */
7781 denom=mp_take_fraction(mp, gamma,alpha)+(ff / 1365)-beta;
7782 /* $1365\approx 2^{12}/3$ */
7783 num=mp_take_fraction(mp, gamma,fraction_three-alpha)+beta;
7785 if ( num>=denom+denom+denom+denom ) return fraction_four;
7786 else return mp_make_fraction(mp, num,denom);
7789 @ We're in the home stretch now.
7791 @<Finish choosing angles and assigning control points@>=
7792 for (k=n-1;k>=0;k--) {
7793 mp->theta[k]=mp->vv[k]-mp_take_fraction(mp,mp->theta[k+1],mp->uu[k]);
7798 mp_n_sin_cos(mp, mp->theta[k]); mp->st=mp->n_sin; mp->ct=mp->n_cos;
7799 mp_n_sin_cos(mp, -mp->psi[k+1]-mp->theta[k+1]); mp->sf=mp->n_sin; mp->cf=mp->n_cos;
7800 mp_set_controls(mp, s,t,k);
7804 @ The |set_controls| routine actually puts the control points into
7805 a pair of consecutive nodes |p| and~|q|. Global variables are used to
7806 record the values of $\sin\theta$, $\cos\theta$, $\sin\phi$, and
7807 $\cos\phi$ needed in this calculation.
7813 fraction cf; /* sines and cosines */
7815 @ @<Declare subroutines needed by |solve_choices|@>=
7816 void mp_set_controls (MP mp,pointer p, pointer q, integer k) {
7817 fraction rr,ss; /* velocities, divided by thrice the tension */
7818 scaled lt,rt; /* tensions */
7819 fraction sine; /* $\sin(\theta+\phi)$ */
7820 lt=abs(left_tension(q)); rt=abs(right_tension(p));
7821 rr=mp_velocity(mp, mp->st,mp->ct,mp->sf,mp->cf,rt);
7822 ss=mp_velocity(mp, mp->sf,mp->cf,mp->st,mp->ct,lt);
7823 if ( (right_tension(p)<0)||(left_tension(q)<0) ) {
7824 @<Decrease the velocities,
7825 if necessary, to stay inside the bounding triangle@>;
7827 right_x(p)=x_coord(p)+mp_take_fraction(mp,
7828 mp_take_fraction(mp, mp->delta_x[k],mp->ct)-
7829 mp_take_fraction(mp, mp->delta_y[k],mp->st),rr);
7830 right_y(p)=y_coord(p)+mp_take_fraction(mp,
7831 mp_take_fraction(mp, mp->delta_y[k],mp->ct)+
7832 mp_take_fraction(mp, mp->delta_x[k],mp->st),rr);
7833 left_x(q)=x_coord(q)-mp_take_fraction(mp,
7834 mp_take_fraction(mp, mp->delta_x[k],mp->cf)+
7835 mp_take_fraction(mp, mp->delta_y[k],mp->sf),ss);
7836 left_y(q)=y_coord(q)-mp_take_fraction(mp,
7837 mp_take_fraction(mp, mp->delta_y[k],mp->cf)-
7838 mp_take_fraction(mp, mp->delta_x[k],mp->sf),ss);
7839 right_type(p)=mp_explicit; left_type(q)=mp_explicit;
7842 @ The boundedness conditions $\\{rr}\L\sin\phi\,/\sin(\theta+\phi)$ and
7843 $\\{ss}\L\sin\theta\,/\sin(\theta+\phi)$ are to be enforced if $\sin\theta$,
7844 $\sin\phi$, and $\sin(\theta+\phi)$ all have the same sign. Otherwise
7845 there is no ``bounding triangle.''
7847 @<Decrease the velocities, if necessary...@>=
7848 if (((mp->st>=0)&&(mp->sf>=0))||((mp->st<=0)&&(mp->sf<=0)) ) {
7849 sine=mp_take_fraction(mp, abs(mp->st),mp->cf)+
7850 mp_take_fraction(mp, abs(mp->sf),mp->ct);
7852 sine=mp_take_fraction(mp, sine,fraction_one+unity); /* safety factor */
7853 if ( right_tension(p)<0 )
7854 if ( mp_ab_vs_cd(mp, abs(mp->sf),fraction_one,rr,sine)<0 )
7855 rr=mp_make_fraction(mp, abs(mp->sf),sine);
7856 if ( left_tension(q)<0 )
7857 if ( mp_ab_vs_cd(mp, abs(mp->st),fraction_one,ss,sine)<0 )
7858 ss=mp_make_fraction(mp, abs(mp->st),sine);
7862 @ Only the simple cases remain to be handled.
7864 @<Reduce to simple case of two givens and |return|@>=
7866 aa=mp_n_arg(mp, mp->delta_x[0],mp->delta_y[0]);
7867 mp_n_sin_cos(mp, right_given(p)-aa); mp->ct=mp->n_cos; mp->st=mp->n_sin;
7868 mp_n_sin_cos(mp, left_given(q)-aa); mp->cf=mp->n_cos; mp->sf=-mp->n_sin;
7869 mp_set_controls(mp, p,q,0); return;
7872 @ @<Reduce to simple case of straight line and |return|@>=
7874 right_type(p)=mp_explicit; left_type(q)=mp_explicit;
7875 lt=abs(left_tension(q)); rt=abs(right_tension(p));
7877 if ( mp->delta_x[0]>=0 ) right_x(p)=x_coord(p)+((mp->delta_x[0]+1) / 3);
7878 else right_x(p)=x_coord(p)+((mp->delta_x[0]-1) / 3);
7879 if ( mp->delta_y[0]>=0 ) right_y(p)=y_coord(p)+((mp->delta_y[0]+1) / 3);
7880 else right_y(p)=y_coord(p)+((mp->delta_y[0]-1) / 3);
7882 ff=mp_make_fraction(mp, unity,3*rt); /* $\alpha/3$ */
7883 right_x(p)=x_coord(p)+mp_take_fraction(mp, mp->delta_x[0],ff);
7884 right_y(p)=y_coord(p)+mp_take_fraction(mp, mp->delta_y[0],ff);
7887 if ( mp->delta_x[0]>=0 ) left_x(q)=x_coord(q)-((mp->delta_x[0]+1) / 3);
7888 else left_x(q)=x_coord(q)-((mp->delta_x[0]-1) / 3);
7889 if ( mp->delta_y[0]>=0 ) left_y(q)=y_coord(q)-((mp->delta_y[0]+1) / 3);
7890 else left_y(q)=y_coord(q)-((mp->delta_y[0]-1) / 3);
7892 ff=mp_make_fraction(mp, unity,3*lt); /* $\beta/3$ */
7893 left_x(q)=x_coord(q)-mp_take_fraction(mp, mp->delta_x[0],ff);
7894 left_y(q)=y_coord(q)-mp_take_fraction(mp, mp->delta_y[0],ff);
7899 @* \[19] Measuring paths.
7900 \MP's \&{llcorner}, \&{lrcorner}, \&{ulcorner}, and \&{urcorner} operators
7901 allow the user to measure the bounding box of anything that can go into a
7902 picture. It's easy to get rough bounds on the $x$ and $y$ extent of a path
7903 by just finding the bounding box of the knots and the control points. We
7904 need a more accurate version of the bounding box, but we can still use the
7905 easy estimate to save time by focusing on the interesting parts of the path.
7907 @ Computing an accurate bounding box involves a theme that will come up again
7908 and again. Given a Bernshte{\u\i}n polynomial
7909 @^Bernshte{\u\i}n, Serge{\u\i} Natanovich@>
7910 $$B(z_0,z_1,\ldots,z_n;t)=\sum_k{n\choose k}t^k(1-t)^{n-k}z_k,$$
7911 we can conveniently bisect its range as follows:
7914 \textindent{1)} Let $z_k^{(0)}=z_k$, for |0<=k<=n|.
7917 \textindent{2)} Let $z_k^{(j+1)}={1\over2}(z_k^{(j)}+z\k^{(j)})$, for
7918 |0<=k<n-j|, for |0<=j<n|.
7922 $$B(z_0,z_1,\ldots,z_n;t)=B(z_0^{(0)},z_0^{(1)},\ldots,z_0^{(n)};2t)
7923 =B(z_0^{(n)},z_1^{(n-1)},\ldots,z_n^{(0)};2t-1).$$
7924 This formula gives us the coefficients of polynomials to use over the ranges
7925 $0\L t\L{1\over2}$ and ${1\over2}\L t\L1$.
7927 @ Now here's a subroutine that's handy for all sorts of path computations:
7928 Given a quadratic polynomial $B(a,b,c;t)$, the |crossing_point| function
7929 returns the unique |fraction| value |t| between 0 and~1 at which
7930 $B(a,b,c;t)$ changes from positive to negative, or returns
7931 |t=fraction_one+1| if no such value exists. If |a<0| (so that $B(a,b,c;t)$
7932 is already negative at |t=0|), |crossing_point| returns the value zero.
7934 @d no_crossing { return (fraction_one+1); }
7935 @d one_crossing { return fraction_one; }
7936 @d zero_crossing { return 0; }
7937 @d mp_crossing_point(M,A,B,C) mp_do_crossing_point(A,B,C)
7939 @c fraction mp_do_crossing_point (integer a, integer b, integer c) {
7940 integer d; /* recursive counter */
7941 integer x,xx,x0,x1,x2; /* temporary registers for bisection */
7942 if ( a<0 ) zero_crossing;
7945 if ( c>0 ) { no_crossing; }
7946 else if ( (a==0)&&(b==0) ) { no_crossing;}
7947 else { one_crossing; }
7949 if ( a==0 ) zero_crossing;
7950 } else if ( a==0 ) {
7951 if ( b<=0 ) zero_crossing;
7953 @<Use bisection to find the crossing point, if one exists@>;
7956 @ The general bisection method is quite simple when $n=2$, hence
7957 |crossing_point| does not take much time. At each stage in the
7958 recursion we have a subinterval defined by |l| and~|j| such that
7959 $B(a,b,c;2^{-l}(j+t))=B(x_0,x_1,x_2;t)$, and we want to ``zero in'' on
7960 the subinterval where $x_0\G0$ and $\min(x_1,x_2)<0$.
7962 It is convenient for purposes of calculation to combine the values
7963 of |l| and~|j| in a single variable $d=2^l+j$, because the operation
7964 of bisection then corresponds simply to doubling $d$ and possibly
7965 adding~1. Furthermore it proves to be convenient to modify
7966 our previous conventions for bisection slightly, maintaining the
7967 variables $X_0=2^lx_0$, $X_1=2^l(x_0-x_1)$, and $X_2=2^l(x_1-x_2)$.
7968 With these variables the conditions $x_0\ge0$ and $\min(x_1,x_2)<0$ are
7969 equivalent to $\max(X_1,X_1+X_2)>X_0\ge0$.
7971 The following code maintains the invariant relations
7972 $0\L|x0|<\max(|x1|,|x1|+|x2|)$,
7973 $\vert|x1|\vert<2^{30}$, $\vert|x2|\vert<2^{30}$;
7974 it has been constructed in such a way that no arithmetic overflow
7975 will occur if the inputs satisfy
7976 $a<2^{30}$, $\vert a-b\vert<2^{30}$, and $\vert b-c\vert<2^{30}$.
7978 @<Use bisection to find the crossing point...@>=
7979 d=1; x0=a; x1=a-b; x2=b-c;
7990 if ( x<=x0 ) { if ( x+x2<=x0 ) no_crossing; }
7994 } while (d<fraction_one);
7995 return (d-fraction_one)
7997 @ Here is a routine that computes the $x$ or $y$ coordinate of the point on
7998 a cubic corresponding to the |fraction| value~|t|.
8000 It is convenient to define a \.{WEB} macro |t_of_the_way| such that
8001 |t_of_the_way(a,b)| expands to |a-(a-b)*t|, i.e., to |t[a,b]|.
8003 @d t_of_the_way(A,B) ((A)-mp_take_fraction(mp,((A)-(B)),t))
8005 @c scaled mp_eval_cubic (MP mp,pointer p, pointer q, fraction t) {
8006 scaled x1,x2,x3; /* intermediate values */
8007 x1=t_of_the_way(knot_coord(p),right_coord(p));
8008 x2=t_of_the_way(right_coord(p),left_coord(q));
8009 x3=t_of_the_way(left_coord(q),knot_coord(q));
8010 x1=t_of_the_way(x1,x2);
8011 x2=t_of_the_way(x2,x3);
8012 return t_of_the_way(x1,x2);
8015 @ The actual bounding box information is stored in global variables.
8016 Since it is convenient to address the $x$ and $y$ information
8017 separately, we define arrays indexed by |x_code..y_code| and use
8018 macros to give them more convenient names.
8022 mp_x_code=0, /* index for |minx| and |maxx| */
8023 mp_y_code /* index for |miny| and |maxy| */
8027 @d minx mp->bbmin[mp_x_code]
8028 @d maxx mp->bbmax[mp_x_code]
8029 @d miny mp->bbmin[mp_y_code]
8030 @d maxy mp->bbmax[mp_y_code]
8033 scaled bbmin[mp_y_code+1];
8034 scaled bbmax[mp_y_code+1];
8035 /* the result of procedures that compute bounding box information */
8037 @ Now we're ready for the key part of the bounding box computation.
8038 The |bound_cubic| procedure updates |bbmin[c]| and |bbmax[c]| based on
8039 $$B(\hbox{|knot_coord(p)|}, \hbox{|right_coord(p)|},
8040 \hbox{|left_coord(q)|}, \hbox{|knot_coord(q)|};t)
8042 for $0<t\le1$. In other words, the procedure adjusts the bounds to
8043 accommodate |knot_coord(q)| and any extremes over the range $0<t<1$.
8044 The |c| parameter is |x_code| or |y_code|.
8046 @c void mp_bound_cubic (MP mp,pointer p, pointer q, small_number c) {
8047 boolean wavy; /* whether we need to look for extremes */
8048 scaled del1,del2,del3,del,dmax; /* proportional to the control
8049 points of a quadratic derived from a cubic */
8050 fraction t,tt; /* where a quadratic crosses zero */
8051 scaled x; /* a value that |bbmin[c]| and |bbmax[c]| must accommodate */
8053 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8054 @<Check the control points against the bounding box and set |wavy:=true|
8055 if any of them lie outside@>;
8057 del1=right_coord(p)-knot_coord(p);
8058 del2=left_coord(q)-right_coord(p);
8059 del3=knot_coord(q)-left_coord(q);
8060 @<Scale up |del1|, |del2|, and |del3| for greater accuracy;
8061 also set |del| to the first nonzero element of |(del1,del2,del3)|@>;
8063 negate(del1); negate(del2); negate(del3);
8065 t=mp_crossing_point(mp, del1,del2,del3);
8066 if ( t<fraction_one ) {
8067 @<Test the extremes of the cubic against the bounding box@>;
8072 @ @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>=
8073 if ( x<mp->bbmin[c] ) mp->bbmin[c]=x;
8074 if ( x>mp->bbmax[c] ) mp->bbmax[c]=x
8076 @ @<Check the control points against the bounding box and set...@>=
8078 if ( mp->bbmin[c]<=right_coord(p) )
8079 if ( right_coord(p)<=mp->bbmax[c] )
8080 if ( mp->bbmin[c]<=left_coord(q) )
8081 if ( left_coord(q)<=mp->bbmax[c] )
8084 @ If |del1=del2=del3=0|, it's impossible to obey the title of this
8085 section. We just set |del=0| in that case.
8087 @<Scale up |del1|, |del2|, and |del3| for greater accuracy...@>=
8088 if ( del1!=0 ) del=del1;
8089 else if ( del2!=0 ) del=del2;
8093 if ( abs(del2)>dmax ) dmax=abs(del2);
8094 if ( abs(del3)>dmax ) dmax=abs(del3);
8095 while ( dmax<fraction_half ) {
8096 dmax+=dmax; del1+=del1; del2+=del2; del3+=del3;
8100 @ Since |crossing_point| has tried to choose |t| so that
8101 $B(|del1|,|del2|,|del3|;\tau)$ crosses zero at $\tau=|t|$ with negative
8102 slope, the value of |del2| computed below should not be positive.
8103 But rounding error could make it slightly positive in which case we
8104 must cut it to zero to avoid confusion.
8106 @<Test the extremes of the cubic against the bounding box@>=
8108 x=mp_eval_cubic(mp, p,q,t);
8109 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8110 del2=t_of_the_way(del2,del3);
8111 /* now |0,del2,del3| represent the derivative on the remaining interval */
8112 if ( del2>0 ) del2=0;
8113 tt=mp_crossing_point(mp, 0,-del2,-del3);
8114 if ( tt<fraction_one ) {
8115 @<Test the second extreme against the bounding box@>;
8119 @ @<Test the second extreme against the bounding box@>=
8121 x=mp_eval_cubic(mp, p,q,t_of_the_way(tt,fraction_one));
8122 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
8125 @ Finding the bounding box of a path is basically a matter of applying
8126 |bound_cubic| twice for each pair of adjacent knots.
8128 @c void mp_path_bbox (MP mp,pointer h) {
8129 pointer p,q; /* a pair of adjacent knots */
8130 minx=x_coord(h); miny=y_coord(h);
8131 maxx=minx; maxy=miny;
8134 if ( right_type(p)==mp_endpoint ) return;
8136 mp_bound_cubic(mp, x_loc(p),x_loc(q),mp_x_code);
8137 mp_bound_cubic(mp, y_loc(p),y_loc(q),mp_y_code);
8142 @ Another important way to measure a path is to find its arc length. This
8143 is best done by using the general bisection algorithm to subdivide the path
8144 until obtaining ``well behaved'' subpaths whose arc lengths can be approximated
8147 Since the arc length is the integral with respect to time of the magnitude of
8148 the velocity, it is natural to use Simpson's rule for the approximation.
8150 If $\dot B(t)$ is the spline velocity, Simpson's rule gives
8151 $$ \vb\dot B(0)\vb + 4\vb\dot B({1\over2})\vb + \vb\dot B(1)\vb \over 6 $$
8152 for the arc length of a path of length~1. For a cubic spline
8153 $B(z_0,z_1,z_2,z_3;t)$, the time derivative $\dot B(t)$ is
8154 $3B(dz_0,dz_1,dz_2;t)$, where $dz_i=z_{i+1}-z_i$. Hence the arc length
8156 $$ {\vb dz_0\vb \over 2} + 2\vb dz_{02}\vb + {\vb dz_2\vb \over 2}, $$
8158 $$ dz_{02}={1\over2}\left({dz_0+dz_1\over 2}+{dz_1+dz_2\over 2}\right)$$
8159 is the result of the bisection algorithm.
8161 @ The remaining problem is how to decide when a subpath is ``well behaved.''
8162 This could be done via the theoretical error bound for Simpson's rule,
8164 but this is impractical because it requires an estimate of the fourth
8165 derivative of the quantity being integrated. It is much easier to just perform
8166 a bisection step and see how much the arc length estimate changes. Since the
8167 error for Simpson's rule is proportional to the fourth power of the sample
8168 spacing, the remaining error is typically about $1\over16$ of the amount of
8169 the change. We say ``typically'' because the error has a pseudo-random behavior
8170 that could cause the two estimates to agree when each contain large errors.
8172 To protect against disasters such as undetected cusps, the bisection process
8173 should always continue until all the $dz_i$ vectors belong to a single
8174 $90^\circ$ sector. This ensures that no point on the spline can have velocity
8175 less than 70\% of the minimum of $\vb dz_0\vb$, $\vb dz_1\vb$ and $\vb dz_2\vb$.
8176 If such a spline happens to produce an erroneous arc length estimate that
8177 is little changed by bisection, the amount of the error is likely to be fairly
8178 small. We will try to arrange things so that freak accidents of this type do
8179 not destroy the inverse relationship between the \&{arclength} and
8180 \&{arctime} operations.
8181 @:arclength_}{\&{arclength} primitive@>
8182 @:arctime_}{\&{arctime} primitive@>
8184 @ The \&{arclength} and \&{arctime} operations are both based on a recursive
8186 function that finds the arc length of a cubic spline given $dz_0$, $dz_1$,
8187 $dz_2$. This |arc_test| routine also takes an arc length goal |a_goal| and
8188 returns the time when the arc length reaches |a_goal| if there is such a time.
8189 Thus the return value is either an arc length less than |a_goal| or, if the
8190 arc length would be at least |a_goal|, it returns a time value decreased by
8191 |two|. This allows the caller to use the sign of the result to distinguish
8192 between arc lengths and time values. On certain types of overflow, it is
8193 possible for |a_goal| and the result of |arc_test| both to be |el_gordo|.
8194 Otherwise, the result is always less than |a_goal|.
8196 Rather than halving the control point coordinates on each recursive call to
8197 |arc_test|, it is better to keep them proportional to velocity on the original
8198 curve and halve the results instead. This means that recursive calls can
8199 potentially use larger error tolerances in their arc length estimates. How
8200 much larger depends on to what extent the errors behave as though they are
8201 independent of each other. To save computing time, we use optimistic assumptions
8202 and increase the tolerance by a factor of about $\sqrt2$ for each recursive
8205 In addition to the tolerance parameter, |arc_test| should also have parameters
8206 for ${1\over3}\vb\dot B(0)\vb$, ${2\over3}\vb\dot B({1\over2})\vb$, and
8207 ${1\over3}\vb\dot B(1)\vb$. These quantities are relatively expensive to compute
8208 and they are needed in different instances of |arc_test|.
8210 @c @<Declare subroutines needed by |arc_test|@>
8211 scaled mp_arc_test (MP mp, scaled dx0, scaled dy0, scaled dx1, scaled dy1,
8212 scaled dx2, scaled dy2, scaled v0, scaled v02,
8213 scaled v2, scaled a_goal, scaled tol) {
8214 boolean simple; /* are the control points confined to a $90^\circ$ sector? */
8215 scaled dx01, dy01, dx12, dy12, dx02, dy02; /* bisection results */
8217 /* twice the velocity magnitudes at $t={1\over4}$ and $t={3\over4}$ */
8218 scaled arc; /* best arc length estimate before recursion */
8219 @<Other local variables in |arc_test|@>;
8220 @<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,
8222 @<Initialize |v002|, |v022|, and the arc length estimate |arc|; if it overflows
8223 set |arc_test| and |return|@>;
8224 @<Test if the control points are confined to one quadrant or rotating them
8225 $45^\circ$ would put them in one quadrant. Then set |simple| appropriately@>;
8226 if ( simple && (abs(arc-v02-halfp(v0+v2)) <= tol) ) {
8227 if ( arc < a_goal ) {
8230 @<Estimate when the arc length reaches |a_goal| and set |arc_test| to
8231 that time minus |two|@>;
8234 @<Use one or two recursive calls to compute the |arc_test| function@>;
8238 @ The |tol| value should by multiplied by $\sqrt 2$ before making recursive
8239 calls, but $1.5$ is an adequate approximation. It is best to avoid using
8240 |make_fraction| in this inner loop.
8243 @<Use one or two recursive calls to compute the |arc_test| function@>=
8245 @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is as
8246 large as possible@>;
8247 tol = tol + halfp(tol);
8248 a = mp_arc_test(mp, dx0,dy0, dx01,dy01, dx02,dy02, v0, v002,
8249 halfp(v02), a_new, tol);
8251 return (-halfp(two-a));
8253 @<Update |a_new| to reduce |a_new+a_aux| by |a|@>;
8254 b = mp_arc_test(mp, dx02,dy02, dx12,dy12, dx2,dy2,
8255 halfp(v02), v022, v2, a_new, tol);
8257 return (-halfp(-b) - half_unit);
8259 return (a + half(b-a));
8263 @ @<Other local variables in |arc_test|@>=
8264 scaled a,b; /* results of recursive calls */
8265 scaled a_new,a_aux; /* the sum of these gives the |a_goal| */
8267 @ @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is...@>=
8268 a_aux = el_gordo - a_goal;
8269 if ( a_goal > a_aux ) {
8270 a_aux = a_goal - a_aux;
8273 a_new = a_goal + a_goal;
8277 @ There is no need to maintain |a_aux| at this point so we use it as a temporary
8278 to force the additions and subtractions to be done in an order that avoids
8281 @<Update |a_new| to reduce |a_new+a_aux| by |a|@>=
8284 a_new = a_new + a_aux;
8287 @ This code assumes all {\it dx} and {\it dy} variables have magnitude less than
8288 |fraction_four|. To simplify the rest of the |arc_test| routine, we strengthen
8289 this assumption by requiring the norm of each $({\it dx},{\it dy})$ pair to obey
8290 this bound. Note that recursive calls will maintain this invariant.
8292 @<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,...@>=
8293 dx01 = half(dx0 + dx1);
8294 dx12 = half(dx1 + dx2);
8295 dx02 = half(dx01 + dx12);
8296 dy01 = half(dy0 + dy1);
8297 dy12 = half(dy1 + dy2);
8298 dy02 = half(dy01 + dy12)
8300 @ We should be careful to keep |arc<el_gordo| so that calling |arc_test| with
8301 |a_goal=el_gordo| is guaranteed to yield the arc length.
8303 @<Initialize |v002|, |v022|, and the arc length estimate |arc|;...@>=
8304 v002 = mp_pyth_add(mp, dx01+half(dx0+dx02), dy01+half(dy0+dy02));
8305 v022 = mp_pyth_add(mp, dx12+half(dx02+dx2), dy12+half(dy02+dy2));
8307 arc1 = v002 + half(halfp(v0+tmp) - v002);
8308 arc = v022 + half(halfp(v2+tmp) - v022);
8309 if ( (arc < el_gordo-arc1) ) {
8312 mp->arith_error = true;
8313 if ( a_goal==el_gordo ) return (el_gordo);
8317 @ @<Other local variables in |arc_test|@>=
8318 scaled tmp, tmp2; /* all purpose temporary registers */
8319 scaled arc1; /* arc length estimate for the first half */
8321 @ @<Test if the control points are confined to one quadrant or rotating...@>=
8322 simple = ((dx0>=0) && (dx1>=0) && (dx2>=0)) ||
8323 ((dx0<=0) && (dx1<=0) && (dx2<=0));
8325 simple = ((dy0>=0) && (dy1>=0) && (dy2>=0)) ||
8326 ((dy0<=0) && (dy1<=0) && (dy2<=0));
8328 simple = ((dx0>=dy0) && (dx1>=dy1) && (dx2>=dy2)) ||
8329 ((dx0<=dy0) && (dx1<=dy1) && (dx2<=dy2));
8331 simple = ((-dx0>=dy0) && (-dx1>=dy1) && (-dx2>=dy2)) ||
8332 ((-dx0<=dy0) && (-dx1<=dy1) && (-dx2<=dy2));
8335 @ Since Simpson's rule is based on approximating the integrand by a parabola,
8337 it is appropriate to use the same approximation to decide when the integral
8338 reaches the intermediate value |a_goal|. At this point
8340 {\vb\dot B(0)\vb\over 3} &= \hbox{|v0|}, \qquad
8341 {\vb\dot B({1\over4})\vb\over 3} = {\hbox{|v002|}\over 2}, \qquad
8342 {\vb\dot B({1\over2})\vb\over 3} = {\hbox{|v02|}\over 2}, \cr
8343 {\vb\dot B({3\over4})\vb\over 3} &= {\hbox{|v022|}\over 2}, \qquad
8344 {\vb\dot B(1)\vb\over 3} = \hbox{|v2|} \cr
8348 $$ {\vb\dot B(t)\vb\over 3} \approx
8349 \cases{B\left(\hbox{|v0|},
8350 \hbox{|v002|}-{1\over 2}\hbox{|v0|}-{1\over 4}\hbox{|v02|},
8351 {1\over 2}\hbox{|v02|}; 2t \right)&
8352 if $t\le{1\over 2}$\cr
8353 B\left({1\over 2}\hbox{|v02|},
8354 \hbox{|v022|}-{1\over 4}\hbox{|v02|}-{1\over 2}\hbox{|v2|},
8355 \hbox{|v2|}; 2t-1 \right)&
8356 if $t\ge{1\over 2}$.\cr}
8359 We can integrate $\vb\dot B(t)\vb$ by using
8360 $$\int 3B(a,b,c;\tau)\,dt =
8361 {B(0,a,a+b,a+b+c;\tau) + {\rm constant} \over {d\tau\over dt}}.
8364 This construction allows us to find the time when the arc length reaches
8365 |a_goal| by solving a cubic equation of the form
8366 $$ B(0,a,a+b,a+b+c;\tau) = x, $$
8367 where $\tau$ is $2t$ or $2t+1$, $x$ is |a_goal| or |a_goal-arc1|, and $a$, $b$,
8368 and $c$ are the Bernshte{\u\i}n coefficients from $(*)$ divided by
8369 @^Bernshte{\u\i}n, Serge{\u\i} Natanovich@>
8370 $d\tau\over dt$. We shall define a function |solve_rising_cubic| that finds
8371 $\tau$ given $a$, $b$, $c$, and $x$.
8373 @<Estimate when the arc length reaches |a_goal| and set |arc_test| to...@>=
8375 tmp = (v02 + 2) / 4;
8376 if ( a_goal<=arc1 ) {
8379 (halfp(mp_solve_rising_cubic(mp, tmp2, arc1-tmp2-tmp, tmp, a_goal))- two);
8382 return ((half_unit - two) +
8383 halfp(mp_solve_rising_cubic(mp, tmp, arc-arc1-tmp-tmp2, tmp2, a_goal-arc1)));
8387 @ Here is the |solve_rising_cubic| routine that finds the time~$t$ when
8388 $$ B(0, a, a+b, a+b+c; t) = x. $$
8389 This routine is based on |crossing_point| but is simplified by the
8390 assumptions that $B(a,b,c;t)\ge0$ for $0\le t\le1$ and that |0<=x<=a+b+c|.
8391 If rounding error causes this condition to be violated slightly, we just ignore
8392 it and proceed with binary search. This finds a time when the function value
8393 reaches |x| and the slope is positive.
8395 @<Declare subroutines needed by |arc_test|@>=
8396 scaled mp_solve_rising_cubic (MP mp,scaled a, scaled b, scaled c, scaled x) {
8397 scaled ab, bc, ac; /* bisection results */
8398 integer t; /* $2^k+q$ where unscaled answer is in $[q2^{-k},(q+1)2^{-k})$ */
8399 integer xx; /* temporary for updating |x| */
8400 if ( (a<0) || (c<0) ) mp_confusion(mp, "rising?");
8401 @:this can't happen rising?}{\quad rising?@>
8404 } else if ( x >= a+b+c ) {
8408 @<Rescale if necessary to make sure |a|, |b|, and |c| are all less than
8412 @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>;
8413 xx = x - a - ab - ac;
8414 if ( xx < -x ) { x+=x; b=ab; c=ac; }
8415 else { x = x + xx; a=ac; b=bc; t = t+1; };
8416 } while (t < unity);
8421 @ @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>=
8426 @ @d one_third_el_gordo 05252525252 /* upper bound on |a|, |b|, and |c| */
8428 @<Rescale if necessary to make sure |a|, |b|, and |c| are all less than...@>=
8429 while ((a>one_third_el_gordo)||(b>one_third_el_gordo)||(c>one_third_el_gordo)) {
8436 @ It is convenient to have a simpler interface to |arc_test| that requires no
8437 unnecessary arguments and ensures that each $({\it dx},{\it dy})$ pair has
8438 length less than |fraction_four|.
8440 @d arc_tol 16 /* quit when change in arc length estimate reaches this */
8442 @c scaled mp_do_arc_test (MP mp,scaled dx0, scaled dy0, scaled dx1,
8443 scaled dy1, scaled dx2, scaled dy2, scaled a_goal) {
8444 scaled v0,v1,v2; /* length of each $({\it dx},{\it dy})$ pair */
8445 scaled v02; /* twice the norm of the quadratic at $t={1\over2}$ */
8446 v0 = mp_pyth_add(mp, dx0,dy0);
8447 v1 = mp_pyth_add(mp, dx1,dy1);
8448 v2 = mp_pyth_add(mp, dx2,dy2);
8449 if ( (v0>=fraction_four) || (v1>=fraction_four) || (v2>=fraction_four) ) {
8450 mp->arith_error = true;
8451 if ( a_goal==el_gordo ) return el_gordo;
8454 v02 = mp_pyth_add(mp, dx1+half(dx0+dx2), dy1+half(dy0+dy2));
8455 return (mp_arc_test(mp, dx0,dy0, dx1,dy1, dx2,dy2,
8456 v0, v02, v2, a_goal, arc_tol));
8460 @ Now it is easy to find the arc length of an entire path.
8462 @c scaled mp_get_arc_length (MP mp,pointer h) {
8463 pointer p,q; /* for traversing the path */
8464 scaled a,a_tot; /* current and total arc lengths */
8467 while ( right_type(p)!=mp_endpoint ){
8469 a = mp_do_arc_test(mp, right_x(p)-x_coord(p), right_y(p)-y_coord(p),
8470 left_x(q)-right_x(p), left_y(q)-right_y(p),
8471 x_coord(q)-left_x(q), y_coord(q)-left_y(q), el_gordo);
8472 a_tot = mp_slow_add(mp, a, a_tot);
8473 if ( q==h ) break; else p=q;
8479 @ The inverse operation of finding the time on a path~|h| when the arc length
8480 reaches some value |arc0| can also be accomplished via |do_arc_test|. Some care
8481 is required to handle very large times or negative times on cyclic paths. For
8482 non-cyclic paths, |arc0| values that are negative or too large cause
8483 |get_arc_time| to return 0 or the length of path~|h|.
8485 If |arc0| is greater than the arc length of a cyclic path~|h|, the result is a
8486 time value greater than the length of the path. Since it could be much greater,
8487 we must be prepared to compute the arc length of path~|h| and divide this into
8488 |arc0| to find how many multiples of the length of path~|h| to add.
8490 @c scaled mp_get_arc_time (MP mp,pointer h, scaled arc0) {
8491 pointer p,q; /* for traversing the path */
8492 scaled t_tot; /* accumulator for the result */
8493 scaled t; /* the result of |do_arc_test| */
8494 scaled arc; /* portion of |arc0| not used up so far */
8495 integer n; /* number of extra times to go around the cycle */
8497 @<Deal with a negative |arc0| value and |return|@>;
8499 if ( arc0==el_gordo ) decr(arc0);
8503 while ( (right_type(p)!=mp_endpoint) && (arc>0) ) {
8505 t = mp_do_arc_test(mp, right_x(p)-x_coord(p), right_y(p)-y_coord(p),
8506 left_x(q)-right_x(p), left_y(q)-right_y(p),
8507 x_coord(q)-left_x(q), y_coord(q)-left_y(q), arc);
8508 @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>;
8510 @<Update |t_tot| and |arc| to avoid going around the cyclic
8511 path too many times but set |arith_error:=true| and |goto done| on
8520 @ @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>=
8521 if ( t<0 ) { t_tot = t_tot + t + two; arc = 0; }
8522 else { t_tot = t_tot + unity; arc = arc - t; }
8524 @ @<Deal with a negative |arc0| value and |return|@>=
8526 if ( left_type(h)==mp_endpoint ) {
8529 p = mp_htap_ypoc(mp, h);
8530 t_tot = -mp_get_arc_time(mp, p, -arc0);
8531 mp_toss_knot_list(mp, p);
8537 @ @<Update |t_tot| and |arc| to avoid going around the cyclic...@>=
8539 n = arc / (arc0 - arc);
8540 arc = arc - n*(arc0 - arc);
8541 if ( t_tot > (el_gordo / (n+1)) ) {
8544 t_tot = (n + 1)*t_tot;
8547 @* \[20] Data structures for pens.
8548 A Pen in \MP\ can be either elliptical or polygonal. Elliptical pens result
8549 in \ps\ \&{stroke} commands, while anything drawn with a polygonal pen is
8550 @:stroke}{\&{stroke} command@>
8551 converted into an area fill as described in the next part of this program.
8552 The mathematics behind this process is based on simple aspects of the theory
8553 of tracings developed by Leo Guibas, Lyle Ramshaw, and Jorge Stolfi
8554 [``A kinematic framework for computational geometry,'' Proc.\ IEEE Symp.\
8555 Foundations of Computer Science {\bf 24} (1983), 100--111].
8557 Polygonal pens are created from paths via \MP's \&{makepen} primitive.
8558 @:makepen_}{\&{makepen} primitive@>
8559 This path representation is almost sufficient for our purposes except that
8560 a pen path should always be a convex polygon with the vertices in
8561 counter-clockwise order.
8562 Since we will need to scan pen polygons both forward and backward, a pen
8563 should be represented as a doubly linked ring of knot nodes. There is
8564 room for the extra back pointer because we do not need the
8565 |left_type| or |right_type| fields. In fact, we don't need the |left_x|,
8566 |left_y|, |right_x|, or |right_y| fields either but we leave these alone
8567 so that certain procedures can operate on both pens and paths. In particular,
8568 pens can be copied using |copy_path| and recycled using |toss_knot_list|.
8571 /* this replaces the |left_type| and |right_type| fields in a pen knot */
8573 @ The |make_pen| procedure turns a path into a pen by initializing
8574 the |knil| pointers and making sure the knots form a convex polygon.
8575 Thus each cubic in the given path becomes a straight line and the control
8576 points are ignored. If the path is not cyclic, the ends are connected by a
8579 @d copy_pen(A) mp_make_pen(mp, mp_copy_path(mp, (A)),false)
8581 @c @<Declare a function called |convex_hull|@>
8582 pointer mp_make_pen (MP mp,pointer h, boolean need_hull) {
8583 pointer p,q; /* two consecutive knots */
8590 h=mp_convex_hull(mp, h);
8591 @<Make sure |h| isn't confused with an elliptical pen@>;
8596 @ The only information required about an elliptical pen is the overall
8597 transformation that has been applied to the original \&{pencircle}.
8598 @:pencircle_}{\&{pencircle} primitive@>
8599 Since it suffices to keep track of how the three points $(0,0)$, $(1,0)$,
8600 and $(0,1)$ are transformed, an elliptical pen can be stored in a single
8601 knot node and transformed as if it were a path.
8603 @d pen_is_elliptical(A) ((A)==link((A)))
8605 @c pointer mp_get_pen_circle (MP mp,scaled diam) {
8606 pointer h; /* the knot node to return */
8607 h=mp_get_node(mp, knot_node_size);
8608 link(h)=h; knil(h)=h;
8609 originator(h)=mp_program_code;
8610 x_coord(h)=0; y_coord(h)=0;
8611 left_x(h)=diam; left_y(h)=0;
8612 right_x(h)=0; right_y(h)=diam;
8616 @ If the polygon being returned by |make_pen| has only one vertex, it will
8617 be interpreted as an elliptical pen. This is no problem since a degenerate
8618 polygon can equally well be thought of as a degenerate ellipse. We need only
8619 initialize the |left_x|, |left_y|, |right_x|, and |right_y| fields.
8621 @<Make sure |h| isn't confused with an elliptical pen@>=
8622 if ( pen_is_elliptical( h) ){
8623 left_x(h)=x_coord(h); left_y(h)=y_coord(h);
8624 right_x(h)=x_coord(h); right_y(h)=y_coord(h);
8627 @ We have to cheat a little here but most operations on pens only use
8628 the first three words in each knot node.
8629 @^data structure assumptions@>
8631 @<Initialize a pen at |test_pen| so that it fits in nine words@>=
8632 x_coord(test_pen)=-half_unit;
8633 y_coord(test_pen)=0;
8634 x_coord(test_pen+3)=half_unit;
8635 y_coord(test_pen+3)=0;
8636 x_coord(test_pen+6)=0;
8637 y_coord(test_pen+6)=unity;
8638 link(test_pen)=test_pen+3;
8639 link(test_pen+3)=test_pen+6;
8640 link(test_pen+6)=test_pen;
8641 knil(test_pen)=test_pen+6;
8642 knil(test_pen+3)=test_pen;
8643 knil(test_pen+6)=test_pen+3
8645 @ Printing a polygonal pen is very much like printing a path
8647 @<Declare subroutines for printing expressions@>=
8648 void mp_pr_pen (MP mp,pointer h) {
8649 pointer p,q; /* for list traversal */
8650 if ( pen_is_elliptical(h) ) {
8651 @<Print the elliptical pen |h|@>;
8655 mp_print_two(mp, x_coord(p),y_coord(p));
8656 mp_print_nl(mp, " .. ");
8657 @<Advance |p| making sure the links are OK and |return| if there is
8660 mp_print(mp, "cycle");
8664 @ @<Advance |p| making sure the links are OK and |return| if there is...@>=
8666 if ( (q==null) || (knil(q)!=p) ) {
8667 mp_print_nl(mp, "???"); return; /* this won't happen */
8672 @ @<Print the elliptical pen |h|@>=
8674 mp_print(mp, "pencircle transformed (");
8675 mp_print_scaled(mp, x_coord(h));
8676 mp_print_char(mp, ',');
8677 mp_print_scaled(mp, y_coord(h));
8678 mp_print_char(mp, ',');
8679 mp_print_scaled(mp, left_x(h)-x_coord(h));
8680 mp_print_char(mp, ',');
8681 mp_print_scaled(mp, right_x(h)-x_coord(h));
8682 mp_print_char(mp, ',');
8683 mp_print_scaled(mp, left_y(h)-y_coord(h));
8684 mp_print_char(mp, ',');
8685 mp_print_scaled(mp, right_y(h)-y_coord(h));
8686 mp_print_char(mp, ')');
8689 @ Here us another version of |pr_pen| that prints the pen as a diagnostic
8692 @<Declare subroutines for printing expressions@>=
8693 void mp_print_pen (MP mp,pointer h, const char *s, boolean nuline) {
8694 mp_print_diagnostic(mp, "Pen",s,nuline); mp_print_ln(mp);
8697 mp_end_diagnostic(mp, true);
8700 @ Making a polygonal pen into a path involves restoring the |left_type| and
8701 |right_type| fields and setting the control points so as to make a polygonal
8705 void mp_make_path (MP mp,pointer h) {
8706 pointer p; /* for traversing the knot list */
8707 small_number k; /* a loop counter */
8708 @<Other local variables in |make_path|@>;
8709 if ( pen_is_elliptical(h) ) {
8710 @<Make the elliptical pen |h| into a path@>;
8714 left_type(p)=mp_explicit;
8715 right_type(p)=mp_explicit;
8716 @<copy the coordinates of knot |p| into its control points@>;
8722 @ @<copy the coordinates of knot |p| into its control points@>=
8723 left_x(p)=x_coord(p);
8724 left_y(p)=y_coord(p);
8725 right_x(p)=x_coord(p);
8726 right_y(p)=y_coord(p)
8728 @ We need an eight knot path to get a good approximation to an ellipse.
8730 @<Make the elliptical pen |h| into a path@>=
8732 @<Extract the transformation parameters from the elliptical pen~|h|@>;
8734 for (k=0;k<=7;k++ ) {
8735 @<Initialize |p| as the |k|th knot of a circle of unit diameter,
8736 transforming it appropriately@>;
8737 if ( k==7 ) link(p)=h; else link(p)=mp_get_node(mp, knot_node_size);
8742 @ @<Extract the transformation parameters from the elliptical pen~|h|@>=
8743 center_x=x_coord(h);
8744 center_y=y_coord(h);
8745 width_x=left_x(h)-center_x;
8746 width_y=left_y(h)-center_y;
8747 height_x=right_x(h)-center_x;
8748 height_y=right_y(h)-center_y
8750 @ @<Other local variables in |make_path|@>=
8751 scaled center_x,center_y; /* translation parameters for an elliptical pen */
8752 scaled width_x,width_y; /* the effect of a unit change in $x$ */
8753 scaled height_x,height_y; /* the effect of a unit change in $y$ */
8754 scaled dx,dy; /* the vector from knot |p| to its right control point */
8756 /* |k| advanced $270^\circ$ around the ring (cf. $\sin\theta=\cos(\theta+270)$) */
8758 @ The only tricky thing here are the tables |half_cos| and |d_cos| used to
8759 find the point $k/8$ of the way around the circle and the direction vector
8762 @<Initialize |p| as the |k|th knot of a circle of unit diameter,...@>=
8764 x_coord(p)=center_x+mp_take_fraction(mp, mp->half_cos[k],width_x)
8765 +mp_take_fraction(mp, mp->half_cos[kk],height_x);
8766 y_coord(p)=center_y+mp_take_fraction(mp, mp->half_cos[k],width_y)
8767 +mp_take_fraction(mp, mp->half_cos[kk],height_y);
8768 dx=-mp_take_fraction(mp, mp->d_cos[kk],width_x)
8769 +mp_take_fraction(mp, mp->d_cos[k],height_x);
8770 dy=-mp_take_fraction(mp, mp->d_cos[kk],width_y)
8771 +mp_take_fraction(mp, mp->d_cos[k],height_y);
8772 right_x(p)=x_coord(p)+dx;
8773 right_y(p)=y_coord(p)+dy;
8774 left_x(p)=x_coord(p)-dx;
8775 left_y(p)=y_coord(p)-dy;
8776 left_type(p)=mp_explicit;
8777 right_type(p)=mp_explicit;
8778 originator(p)=mp_program_code
8781 fraction half_cos[8]; /* ${1\over2}\cos(45k)$ */
8782 fraction d_cos[8]; /* a magic constant times $\cos(45k)$ */
8784 @ The magic constant for |d_cos| is the distance between $({1\over2},0)$ and
8785 $({1\over4}\sqrt2,{1\over4}\sqrt2)$ times the result of the |velocity|
8786 function for $\theta=\phi=22.5^\circ$. This comes out to be
8787 $$ d = {\sqrt{2-\sqrt2}\over 3+3\cos22.5^\circ}
8788 \approx 0.132608244919772.
8792 mp->half_cos[0]=fraction_half;
8793 mp->half_cos[1]=94906266; /* $2^{26}\sqrt2\approx94906265.62$ */
8795 mp->d_cos[0]=35596755; /* $2^{28}d\approx35596754.69$ */
8796 mp->d_cos[1]=25170707; /* $2^{27}\sqrt2\,d\approx25170706.63$ */
8798 for (k=3;k<= 4;k++ ) {
8799 mp->half_cos[k]=-mp->half_cos[4-k];
8800 mp->d_cos[k]=-mp->d_cos[4-k];
8802 for (k=5;k<= 7;k++ ) {
8803 mp->half_cos[k]=mp->half_cos[8-k];
8804 mp->d_cos[k]=mp->d_cos[8-k];
8807 @ The |convex_hull| function forces a pen polygon to be convex when it is
8808 returned by |make_pen| and after any subsequent transformation where rounding
8809 error might allow the convexity to be lost.
8810 The convex hull algorithm used here is described by F.~P. Preparata and
8811 M.~I. Shamos [{\sl Computational Geometry}, Springer-Verlag, 1985].
8813 @<Declare a function called |convex_hull|@>=
8814 @<Declare a procedure called |move_knot|@>
8815 pointer mp_convex_hull (MP mp,pointer h) { /* Make a polygonal pen convex */
8816 pointer l,r; /* the leftmost and rightmost knots */
8817 pointer p,q; /* knots being scanned */
8818 pointer s; /* the starting point for an upcoming scan */
8819 scaled dx,dy; /* a temporary pointer */
8820 if ( pen_is_elliptical(h) ) {
8823 @<Set |l| to the leftmost knot in polygon~|h|@>;
8824 @<Set |r| to the rightmost knot in polygon~|h|@>;
8827 @<Find any knots on the path from |l| to |r| above the |l|-|r| line and
8828 move them past~|r|@>;
8829 @<Find any knots on the path from |s| to |l| below the |l|-|r| line and
8830 move them past~|l|@>;
8831 @<Sort the path from |l| to |r| by increasing $x$@>;
8832 @<Sort the path from |r| to |l| by decreasing $x$@>;
8835 @<Do a Gramm scan and remove vertices where there is no left turn@>;
8841 @ All comparisons are done primarily on $x$ and secondarily on $y$.
8843 @<Set |l| to the leftmost knot in polygon~|h|@>=
8847 if ( x_coord(p)<=x_coord(l) )
8848 if ( (x_coord(p)<x_coord(l)) || (y_coord(p)<y_coord(l)) )
8853 @ @<Set |r| to the rightmost knot in polygon~|h|@>=
8857 if ( x_coord(p)>=x_coord(r) )
8858 if ( (x_coord(p)>x_coord(r)) || (y_coord(p)>y_coord(r)) )
8863 @ @<Find any knots on the path from |l| to |r| above the |l|-|r| line...@>=
8864 dx=x_coord(r)-x_coord(l);
8865 dy=y_coord(r)-y_coord(l);
8869 if ( mp_ab_vs_cd(mp, dx,y_coord(p)-y_coord(l),dy,x_coord(p)-x_coord(l))>0 )
8870 mp_move_knot(mp, p, r);
8874 @ The |move_knot| procedure removes |p| from a doubly linked list and inserts
8877 @ @<Declare a procedure called |move_knot|@>=
8878 void mp_move_knot (MP mp,pointer p, pointer q) {
8879 link(knil(p))=link(p);
8880 knil(link(p))=knil(p);
8887 @ @<Find any knots on the path from |s| to |l| below the |l|-|r| line...@>=
8891 if ( mp_ab_vs_cd(mp, dx,y_coord(p)-y_coord(l),dy,x_coord(p)-x_coord(l))<0 )
8892 mp_move_knot(mp, p,l);
8896 @ The list is likely to be in order already so we just do linear insertions.
8897 Secondary comparisons on $y$ ensure that the sort is consistent with the
8898 choice of |l| and |r|.
8900 @<Sort the path from |l| to |r| by increasing $x$@>=
8904 while ( x_coord(q)>x_coord(p) ) q=knil(q);
8905 while ( x_coord(q)==x_coord(p) ) {
8906 if ( y_coord(q)>y_coord(p) ) q=knil(q); else break;
8908 if ( q==knil(p) ) p=link(p);
8909 else { p=link(p); mp_move_knot(mp, knil(p),q); };
8912 @ @<Sort the path from |r| to |l| by decreasing $x$@>=
8916 while ( x_coord(q)<x_coord(p) ) q=knil(q);
8917 while ( x_coord(q)==x_coord(p) ) {
8918 if ( y_coord(q)<y_coord(p) ) q=knil(q); else break;
8920 if ( q==knil(p) ) p=link(p);
8921 else { p=link(p); mp_move_knot(mp, knil(p),q); };
8924 @ The condition involving |ab_vs_cd| tests if there is not a left turn
8925 at knot |q|. There usually will be a left turn so we streamline the case
8926 where the |then| clause is not executed.
8928 @<Do a Gramm scan and remove vertices where there...@>=
8932 dx=x_coord(q)-x_coord(p);
8933 dy=y_coord(q)-y_coord(p);
8937 if ( mp_ab_vs_cd(mp, dx,y_coord(q)-y_coord(p),dy,x_coord(q)-x_coord(p))<=0 ) {
8938 @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>;
8943 @ @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>=
8946 mp_free_node(mp, p,knot_node_size);
8947 link(s)=q; knil(q)=s;
8949 else { p=knil(s); q=s; };
8952 @ The |find_offset| procedure sets global variables |(cur_x,cur_y)| to the
8953 offset associated with the given direction |(x,y)|. If two different offsets
8954 apply, it chooses one of them.
8957 void mp_find_offset (MP mp,scaled x, scaled y, pointer h) {
8958 pointer p,q; /* consecutive knots */
8960 /* the transformation matrix for an elliptical pen */
8961 fraction xx,yy; /* untransformed offset for an elliptical pen */
8962 fraction d; /* a temporary register */
8963 if ( pen_is_elliptical(h) ) {
8964 @<Find the offset for |(x,y)| on the elliptical pen~|h|@>
8969 } while (!(mp_ab_vs_cd(mp, x_coord(q)-x_coord(p),y, y_coord(q)-y_coord(p),x)>=0));
8972 } while (!(mp_ab_vs_cd(mp, x_coord(q)-x_coord(p),y, y_coord(q)-y_coord(p),x)<=0));
8973 mp->cur_x=x_coord(p);
8974 mp->cur_y=y_coord(p);
8980 scaled cur_y; /* all-purpose return value registers */
8982 @ @<Find the offset for |(x,y)| on the elliptical pen~|h|@>=
8983 if ( (x==0) && (y==0) ) {
8984 mp->cur_x=x_coord(h); mp->cur_y=y_coord(h);
8986 @<Find the non-constant part of the transformation for |h|@>;
8987 while ( (abs(x)<fraction_half) && (abs(y)<fraction_half) ){
8990 @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the
8991 untransformed version of |(x,y)|@>;
8992 mp->cur_x=x_coord(h)+mp_take_fraction(mp, xx,wx)+mp_take_fraction(mp, yy,hx);
8993 mp->cur_y=y_coord(h)+mp_take_fraction(mp, xx,wy)+mp_take_fraction(mp, yy,hy);
8996 @ @<Find the non-constant part of the transformation for |h|@>=
8997 wx=left_x(h)-x_coord(h);
8998 wy=left_y(h)-y_coord(h);
8999 hx=right_x(h)-x_coord(h);
9000 hy=right_y(h)-y_coord(h)
9002 @ @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the...@>=
9003 yy=-(mp_take_fraction(mp, x,hy)+mp_take_fraction(mp, y,-hx));
9004 xx=mp_take_fraction(mp, x,-wy)+mp_take_fraction(mp, y,wx);
9005 d=mp_pyth_add(mp, xx,yy);
9007 xx=half(mp_make_fraction(mp, xx,d));
9008 yy=half(mp_make_fraction(mp, yy,d));
9011 @ Finding the bounding box of a pen is easy except if the pen is elliptical.
9012 But we can handle that case by just calling |find_offset| twice. The answer
9013 is stored in the global variables |minx|, |maxx|, |miny|, and |maxy|.
9016 void mp_pen_bbox (MP mp,pointer h) {
9017 pointer p; /* for scanning the knot list */
9018 if ( pen_is_elliptical(h) ) {
9019 @<Find the bounding box of an elliptical pen@>;
9021 minx=x_coord(h); maxx=minx;
9022 miny=y_coord(h); maxy=miny;
9025 if ( x_coord(p)<minx ) minx=x_coord(p);
9026 if ( y_coord(p)<miny ) miny=y_coord(p);
9027 if ( x_coord(p)>maxx ) maxx=x_coord(p);
9028 if ( y_coord(p)>maxy ) maxy=y_coord(p);
9034 @ @<Find the bounding box of an elliptical pen@>=
9036 mp_find_offset(mp, 0,fraction_one,h);
9038 minx=2*x_coord(h)-mp->cur_x;
9039 mp_find_offset(mp, -fraction_one,0,h);
9041 miny=2*y_coord(h)-mp->cur_y;
9044 @* \[21] Edge structures.
9045 Now we come to \MP's internal scheme for representing pictures.
9046 The representation is very different from \MF's edge structures
9047 because \MP\ pictures contain \ps\ graphics objects instead of pixel
9048 images. However, the basic idea is somewhat similar in that shapes
9049 are represented via their boundaries.
9051 The main purpose of edge structures is to keep track of graphical objects
9052 until it is time to translate them into \ps. Since \MP\ does not need to
9053 know anything about an edge structure other than how to translate it into
9054 \ps\ and how to find its bounding box, edge structures can be just linked
9055 lists of graphical objects. \MP\ has no easy way to determine whether
9056 two such objects overlap, but it suffices to draw the first one first and
9057 let the second one overwrite it if necessary.
9060 enum mp_graphical_object_code {
9061 @<Graphical object codes@>
9065 @ Let's consider the types of graphical objects one at a time.
9066 First of all, a filled contour is represented by a eight-word node. The first
9067 word contains |type| and |link| fields, and the next six words contain a
9068 pointer to a cyclic path and the value to use for \ps' \&{currentrgbcolor}
9069 parameter. If a pen is used for filling |pen_p|, |ljoin_val| and |miterlim_val|
9070 give the relevant information.
9072 @d path_p(A) link((A)+1)
9073 /* a pointer to the path that needs filling */
9074 @d pen_p(A) info((A)+1)
9075 /* a pointer to the pen to fill or stroke with */
9076 @d color_model(A) type((A)+2) /* the color model */
9077 @d obj_red_loc(A) ((A)+3) /* the first of three locations for the color */
9078 @d obj_cyan_loc obj_red_loc /* the first of four locations for the color */
9079 @d obj_grey_loc obj_red_loc /* the location for the color */
9080 @d red_val(A) mp->mem[(A)+3].sc
9081 /* the red component of the color in the range $0\ldots1$ */
9084 @d green_val(A) mp->mem[(A)+4].sc
9085 /* the green component of the color in the range $0\ldots1$ */
9086 @d magenta_val green_val
9087 @d blue_val(A) mp->mem[(A)+5].sc
9088 /* the blue component of the color in the range $0\ldots1$ */
9089 @d yellow_val blue_val
9090 @d black_val(A) mp->mem[(A)+6].sc
9091 /* the blue component of the color in the range $0\ldots1$ */
9092 @d ljoin_val(A) name_type((A)) /* the value of \&{linejoin} */
9093 @:mp_linejoin_}{\&{linejoin} primitive@>
9094 @d miterlim_val(A) mp->mem[(A)+7].sc /* the value of \&{miterlimit} */
9095 @:mp_miterlimit_}{\&{miterlimit} primitive@>
9096 @d obj_color_part(A) mp->mem[(A)+3-red_part].sc
9097 /* interpret an object pointer that has been offset by |red_part..blue_part| */
9098 @d pre_script(A) mp->mem[(A)+8].hh.lh
9099 @d post_script(A) mp->mem[(A)+8].hh.rh
9102 @ @<Graphical object codes@>=
9106 pointer mp_new_fill_node (MP mp,pointer p) {
9107 /* make a fill node for cyclic path |p| and color black */
9108 pointer t; /* the new node */
9109 t=mp_get_node(mp, fill_node_size);
9110 type(t)=mp_fill_code;
9112 pen_p(t)=null; /* |null| means don't use a pen */
9117 color_model(t)=mp_uninitialized_model;
9119 post_script(t)=null;
9120 @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>;
9124 @ @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>=
9125 if ( mp->internal[mp_linejoin]>unity ) ljoin_val(t)=2;
9126 else if ( mp->internal[mp_linejoin]>0 ) ljoin_val(t)=1;
9127 else ljoin_val(t)=0;
9128 if ( mp->internal[mp_miterlimit]<unity )
9129 miterlim_val(t)=unity;
9131 miterlim_val(t)=mp->internal[mp_miterlimit]
9133 @ A stroked path is represented by an eight-word node that is like a filled
9134 contour node except that it contains the current \&{linecap} value, a scale
9135 factor for the dash pattern, and a pointer that is non-null if the stroke
9136 is to be dashed. The purpose of the scale factor is to allow a picture to
9137 be transformed without touching the picture that |dash_p| points to.
9139 @d dash_p(A) link((A)+9)
9140 /* a pointer to the edge structure that gives the dash pattern */
9141 @d lcap_val(A) type((A)+9)
9142 /* the value of \&{linecap} */
9143 @:mp_linecap_}{\&{linecap} primitive@>
9144 @d dash_scale(A) mp->mem[(A)+10].sc /* dash lengths are scaled by this factor */
9145 @d stroked_node_size 11
9147 @ @<Graphical object codes@>=
9151 pointer mp_new_stroked_node (MP mp,pointer p) {
9152 /* make a stroked node for path |p| with |pen_p(p)| temporarily |null| */
9153 pointer t; /* the new node */
9154 t=mp_get_node(mp, stroked_node_size);
9155 type(t)=mp_stroked_code;
9156 path_p(t)=p; pen_p(t)=null;
9158 dash_scale(t)=unity;
9163 color_model(t)=mp_uninitialized_model;
9165 post_script(t)=null;
9166 @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>;
9167 if ( mp->internal[mp_linecap]>unity ) lcap_val(t)=2;
9168 else if ( mp->internal[mp_linecap]>0 ) lcap_val(t)=1;
9173 @ When a dashed line is computed in a transformed coordinate system, the dash
9174 lengths get scaled like the pen shape and we need to compensate for this. Since
9175 there is no unique scale factor for an arbitrary transformation, we use the
9176 the square root of the determinant. The properties of the determinant make it
9177 easier to maintain the |dash_scale|. The computation is fairly straight-forward
9178 except for the initialization of the scale factor |s|. The factor of 64 is
9179 needed because |square_rt| scales its result by $2^8$ while we need $2^{14}$
9180 to counteract the effect of |take_fraction|.
9182 @<Declare subroutines needed by |print_edges|@>=
9183 scaled mp_sqrt_det (MP mp,scaled a, scaled b, scaled c, scaled d) {
9184 scaled maxabs; /* $max(|a|,|b|,|c|,|d|)$ */
9185 integer s; /* amount by which the result of |square_rt| needs to be scaled */
9186 @<Initialize |maxabs|@>;
9188 while ( (maxabs<fraction_one) && (s>1) ){
9189 a+=a; b+=b; c+=c; d+=d;
9190 maxabs+=maxabs; s=halfp(s);
9192 return s*mp_square_rt(mp, abs(mp_take_fraction(mp, a,d)-mp_take_fraction(mp, b,c)));
9195 scaled mp_get_pen_scale (MP mp,pointer p) {
9196 return mp_sqrt_det(mp,
9197 left_x(p)-x_coord(p), right_x(p)-x_coord(p),
9198 left_y(p)-y_coord(p), right_y(p)-y_coord(p));
9201 @ @<Internal library ...@>=
9202 scaled mp_sqrt_det (MP mp,scaled a, scaled b, scaled c, scaled d) ;
9205 @ @<Initialize |maxabs|@>=
9207 if ( abs(b)>maxabs ) maxabs=abs(b);
9208 if ( abs(c)>maxabs ) maxabs=abs(c);
9209 if ( abs(d)>maxabs ) maxabs=abs(d)
9211 @ When a picture contains text, this is represented by a fourteen-word node
9212 where the color information and |type| and |link| fields are augmented by
9213 additional fields that describe the text and how it is transformed.
9214 The |path_p| and |pen_p| pointers are replaced by a number that identifies
9215 the font and a string number that gives the text to be displayed.
9216 The |width|, |height|, and |depth| fields
9217 give the dimensions of the text at its design size, and the remaining six
9218 words give a transformation to be applied to the text. The |new_text_node|
9219 function initializes everything to default values so that the text comes out
9220 black with its reference point at the origin.
9222 @d text_p(A) link((A)+1) /* a string pointer for the text to display */
9223 @d font_n(A) info((A)+1) /* the font number */
9224 @d width_val(A) mp->mem[(A)+7].sc /* unscaled width of the text */
9225 @d height_val(A) mp->mem[(A)+9].sc /* unscaled height of the text */
9226 @d depth_val(A) mp->mem[(A)+10].sc /* unscaled depth of the text */
9227 @d text_tx_loc(A) ((A)+11)
9228 /* the first of six locations for transformation parameters */
9229 @d tx_val(A) mp->mem[(A)+11].sc /* $x$ shift amount */
9230 @d ty_val(A) mp->mem[(A)+12].sc /* $y$ shift amount */
9231 @d txx_val(A) mp->mem[(A)+13].sc /* |txx| transformation parameter */
9232 @d txy_val(A) mp->mem[(A)+14].sc /* |txy| transformation parameter */
9233 @d tyx_val(A) mp->mem[(A)+15].sc /* |tyx| transformation parameter */
9234 @d tyy_val(A) mp->mem[(A)+16].sc /* |tyy| transformation parameter */
9235 @d text_trans_part(A) mp->mem[(A)+11-x_part].sc
9236 /* interpret a text node pointer that has been offset by |x_part..yy_part| */
9237 @d text_node_size 17
9239 @ @<Graphical object codes@>=
9242 @ @c @<Declare text measuring subroutines@>
9243 pointer mp_new_text_node (MP mp,char *f,str_number s) {
9244 /* make a text node for font |f| and text string |s| */
9245 pointer t; /* the new node */
9246 t=mp_get_node(mp, text_node_size);
9247 type(t)=mp_text_code;
9249 font_n(t)=mp_find_font(mp, f); /* this identifies the font */
9254 color_model(t)=mp_uninitialized_model;
9256 post_script(t)=null;
9257 tx_val(t)=0; ty_val(t)=0;
9258 txx_val(t)=unity; txy_val(t)=0;
9259 tyx_val(t)=0; tyy_val(t)=unity;
9260 mp_set_text_box(mp, t); /* this finds the bounding box */
9264 @ The last two types of graphical objects that can occur in an edge structure
9265 are clipping paths and \&{setbounds} paths. These are slightly more difficult
9266 @:set_bounds_}{\&{setbounds} primitive@>
9267 to implement because we must keep track of exactly what is being clipped or
9268 bounded when pictures get merged together. For this reason, each clipping or
9269 \&{setbounds} operation is represented by a pair of nodes: first comes a
9270 two-word node whose |path_p| gives the relevant path, then there is the list
9271 of objects to clip or bound followed by a two-word node whose second word is
9274 Using at least two words for each graphical object node allows them all to be
9275 allocated and deallocated similarly with a global array |gr_object_size| to
9276 give the size in words for each object type.
9278 @d start_clip_size 2
9279 @d start_bounds_size 2
9280 @d stop_clip_size 2 /* the second word is not used here */
9281 @d stop_bounds_size 2 /* the second word is not used here */
9283 @d stop_type(A) ((A)+2)
9284 /* matching |type| for |start_clip_code| or |start_bounds_code| */
9285 @d has_color(A) (type((A))<mp_start_clip_code)
9286 /* does a graphical object have color fields? */
9287 @d has_pen(A) (type((A))<mp_text_code)
9288 /* does a graphical object have a |pen_p| field? */
9289 @d is_start_or_stop(A) (type((A))>=mp_start_clip_code)
9290 @d is_stop(A) (type((A))>=mp_stop_clip_code)
9292 @ @<Graphical object codes@>=
9293 mp_start_clip_code=4, /* |type| of a node that starts clipping */
9294 mp_start_bounds_code=5, /* |type| of a node that gives a \&{setbounds} path */
9295 mp_stop_clip_code=6, /* |type| of a node that stops clipping */
9296 mp_stop_bounds_code=7, /* |type| of a node that stops \&{setbounds} */
9299 pointer mp_new_bounds_node (MP mp,pointer p, small_number c) {
9300 /* make a node of type |c| where |p| is the clipping or \&{setbounds} path */
9301 pointer t; /* the new node */
9302 t=mp_get_node(mp, mp->gr_object_size[c]);
9308 @ We need an array to keep track of the sizes of graphical objects.
9311 small_number gr_object_size[mp_stop_bounds_code+1];
9314 mp->gr_object_size[mp_fill_code]=fill_node_size;
9315 mp->gr_object_size[mp_stroked_code]=stroked_node_size;
9316 mp->gr_object_size[mp_text_code]=text_node_size;
9317 mp->gr_object_size[mp_start_clip_code]=start_clip_size;
9318 mp->gr_object_size[mp_stop_clip_code]=stop_clip_size;
9319 mp->gr_object_size[mp_start_bounds_code]=start_bounds_size;
9320 mp->gr_object_size[mp_stop_bounds_code]=stop_bounds_size;
9322 @ All the essential information in an edge structure is encoded as a linked list
9323 of graphical objects as we have just seen, but it is helpful to add some
9324 redundant information. A single edge structure might be used as a dash pattern
9325 many times, and it would be nice to avoid scanning the same structure
9326 repeatedly. Thus, an edge structure known to be a suitable dash pattern
9327 has a header that gives a list of dashes in a sorted order designed for rapid
9328 translation into \ps.
9330 Each dash is represented by a three-word node containing the initial and final
9331 $x$~coordinates as well as the usual |link| field. The |link| fields points to
9332 the dash node with the next higher $x$-coordinates and the final link points
9333 to a special location called |null_dash|. (There should be no overlap between
9334 dashes). Since the $y$~coordinate of the dash pattern is needed to determine
9335 the period of repetition, this needs to be stored in the edge header along
9336 with a pointer to the list of dash nodes.
9338 @d start_x(A) mp->mem[(A)+1].sc /* the starting $x$~coordinate in a dash node */
9339 @d stop_x(A) mp->mem[(A)+2].sc /* the ending $x$~coordinate in a dash node */
9342 /* in an edge header this points to the first dash node */
9343 @d dash_y(A) mp->mem[(A)+1].sc /* $y$ value for the dash list in an edge header */
9345 @ It is also convenient for an edge header to contain the bounding
9346 box information needed by the \&{llcorner} and \&{urcorner} operators
9347 so that this does not have to be recomputed unnecessarily. This is done by
9348 adding fields for the $x$~and $y$ extremes as well as a pointer that indicates
9349 how far the bounding box computation has gotten. Thus if the user asks for
9350 the bounding box and then adds some more text to the picture before asking
9351 for more bounding box information, the second computation need only look at
9352 the additional text.
9354 When the bounding box has not been computed, the |bblast| pointer points
9355 to a dummy link at the head of the graphical object list while the |minx_val|
9356 and |miny_val| fields contain |el_gordo| and the |maxx_val| and |maxy_val|
9357 fields contain |-el_gordo|.
9359 Since the bounding box of pictures containing objects of type
9360 |mp_start_bounds_code| depends on the value of \&{truecorners}, the bounding box
9361 @:mp_true_corners_}{\&{truecorners} primitive@>
9362 data might not be valid for all values of this parameter. Hence, the |bbtype|
9363 field is needed to keep track of this.
9365 @d minx_val(A) mp->mem[(A)+2].sc
9366 @d miny_val(A) mp->mem[(A)+3].sc
9367 @d maxx_val(A) mp->mem[(A)+4].sc
9368 @d maxy_val(A) mp->mem[(A)+5].sc
9369 @d bblast(A) link((A)+6) /* last item considered in bounding box computation */
9370 @d bbtype(A) info((A)+6) /* tells how bounding box data depends on \&{truecorners} */
9371 @d dummy_loc(A) ((A)+7) /* where the object list begins in an edge header */
9373 /* |bbtype| value when bounding box data is valid for all \&{truecorners} values */
9375 /* |bbtype| value when bounding box data is for \&{truecorners}${}\le 0$ */
9377 /* |bbtype| value when bounding box data is for \&{truecorners}${}>0$ */
9380 void mp_init_bbox (MP mp,pointer h) {
9381 /* Initialize the bounding box information in edge structure |h| */
9382 bblast(h)=dummy_loc(h);
9383 bbtype(h)=no_bounds;
9384 minx_val(h)=el_gordo;
9385 miny_val(h)=el_gordo;
9386 maxx_val(h)=-el_gordo;
9387 maxy_val(h)=-el_gordo;
9390 @ The only other entries in an edge header are a reference count in the first
9391 word and a pointer to the tail of the object list in the last word.
9393 @d obj_tail(A) info((A)+7) /* points to the last entry in the object list */
9394 @d edge_header_size 8
9397 void mp_init_edges (MP mp,pointer h) {
9398 /* initialize an edge header to null values */
9399 dash_list(h)=null_dash;
9400 obj_tail(h)=dummy_loc(h);
9401 link(dummy_loc(h))=null;
9403 mp_init_bbox(mp, h);
9406 @ Here is how edge structures are deleted. The process can be recursive because
9407 of the need to dereference edge structures that are used as dash patterns.
9410 @d add_edge_ref(A) incr(ref_count(A))
9411 @d delete_edge_ref(A) {
9412 if ( ref_count((A))==null )
9413 mp_toss_edges(mp, A);
9418 @<Declare the recycling subroutines@>=
9419 void mp_flush_dash_list (MP mp,pointer h);
9420 pointer mp_toss_gr_object (MP mp,pointer p) ;
9421 void mp_toss_edges (MP mp,pointer h) ;
9423 @ @c void mp_toss_edges (MP mp,pointer h) {
9424 pointer p,q; /* pointers that scan the list being recycled */
9425 pointer r; /* an edge structure that object |p| refers to */
9426 mp_flush_dash_list(mp, h);
9427 q=link(dummy_loc(h));
9428 while ( (q!=null) ) {
9430 r=mp_toss_gr_object(mp, p);
9431 if ( r!=null ) delete_edge_ref(r);
9433 mp_free_node(mp, h,edge_header_size);
9435 void mp_flush_dash_list (MP mp,pointer h) {
9436 pointer p,q; /* pointers that scan the list being recycled */
9438 while ( q!=null_dash ) {
9440 mp_free_node(mp, p,dash_node_size);
9442 dash_list(h)=null_dash;
9444 pointer mp_toss_gr_object (MP mp,pointer p) {
9445 /* returns an edge structure that needs to be dereferenced */
9446 pointer e; /* the edge structure to return */
9448 @<Prepare to recycle graphical object |p|@>;
9449 mp_free_node(mp, p,mp->gr_object_size[type(p)]);
9453 @ @<Prepare to recycle graphical object |p|@>=
9456 mp_toss_knot_list(mp, path_p(p));
9457 if ( pen_p(p)!=null ) mp_toss_knot_list(mp, pen_p(p));
9458 if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
9459 if ( post_script(p)!=null ) delete_str_ref(post_script(p));
9461 case mp_stroked_code:
9462 mp_toss_knot_list(mp, path_p(p));
9463 if ( pen_p(p)!=null ) mp_toss_knot_list(mp, pen_p(p));
9464 if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
9465 if ( post_script(p)!=null ) delete_str_ref(post_script(p));
9469 delete_str_ref(text_p(p));
9470 if ( pre_script(p)!=null ) delete_str_ref(pre_script(p));
9471 if ( post_script(p)!=null ) delete_str_ref(post_script(p));
9473 case mp_start_clip_code:
9474 case mp_start_bounds_code:
9475 mp_toss_knot_list(mp, path_p(p));
9477 case mp_stop_clip_code:
9478 case mp_stop_bounds_code:
9480 } /* there are no other cases */
9482 @ If we use |add_edge_ref| to ``copy'' edge structures, the real copying needs
9483 to be done before making a significant change to an edge structure. Much of
9484 the work is done in a separate routine |copy_objects| that copies a list of
9485 graphical objects into a new edge header.
9487 @c @<Declare a function called |copy_objects|@>
9488 pointer mp_private_edges (MP mp,pointer h) {
9489 /* make a private copy of the edge structure headed by |h| */
9490 pointer hh; /* the edge header for the new copy */
9491 pointer p,pp; /* pointers for copying the dash list */
9492 if ( ref_count(h)==null ) {
9496 hh=mp_copy_objects(mp, link(dummy_loc(h)),null);
9497 @<Copy the dash list from |h| to |hh|@>;
9498 @<Copy the bounding box information from |h| to |hh| and make |bblast(hh)|
9499 point into the new object list@>;
9504 @ Here we use the fact that |dash_list(hh)=link(hh)|.
9505 @^data structure assumptions@>
9507 @<Copy the dash list from |h| to |hh|@>=
9508 pp=hh; p=dash_list(h);
9509 while ( (p!=null_dash) ) {
9510 link(pp)=mp_get_node(mp, dash_node_size);
9512 start_x(pp)=start_x(p);
9513 stop_x(pp)=stop_x(p);
9517 dash_y(hh)=dash_y(h)
9520 @ |h| is an edge structure
9523 mp_dash_object *mp_export_dashes (MP mp, pointer q, scaled *w) {
9526 scaled scf; /* scale factor */
9530 if (h==null || dash_list(h)==null_dash)
9533 scf=mp_get_pen_scale(mp, pen_p(q));
9535 if (*w==0) scf = dash_scale(q); else return NULL;
9537 scf=mp_make_scaled(mp, *w,scf);
9538 scf=mp_take_scaled(mp, scf,dash_scale(q));
9541 d = mp_xmalloc(mp,1,sizeof(mp_dash_object));
9542 start_x(null_dash)=start_x(p)+dash_y(h);
9543 while (p != null_dash) {
9544 dashes = mp_xrealloc(mp, dashes, num_dashes+2, sizeof(scaled));
9545 dashes[(num_dashes-1)] =
9546 mp_take_scaled(mp,(stop_x(p)-start_x(p)),scf);
9547 dashes[(num_dashes)] =
9548 mp_take_scaled(mp,(start_x(link(p))-stop_x(p)),scf);
9549 dashes[(num_dashes+1)] = -1; /* terminus */
9553 d->array_field = dashes;
9555 mp_take_scaled(mp,mp_dash_offset(mp, h),scf);
9561 @ @<Copy the bounding box information from |h| to |hh|...@>=
9562 minx_val(hh)=minx_val(h);
9563 miny_val(hh)=miny_val(h);
9564 maxx_val(hh)=maxx_val(h);
9565 maxy_val(hh)=maxy_val(h);
9566 bbtype(hh)=bbtype(h);
9567 p=dummy_loc(h); pp=dummy_loc(hh);
9568 while ((p!=bblast(h)) ) {
9569 if ( p==null ) mp_confusion(mp, "bblast");
9570 @:this can't happen bblast}{\quad bblast@>
9571 p=link(p); pp=link(pp);
9575 @ Here is the promised routine for copying graphical objects into a new edge
9576 structure. It starts copying at object~|p| and stops just before object~|q|.
9577 If |q| is null, it copies the entire sublist headed at |p|. The resulting edge
9578 structure requires further initialization by |init_bbox|.
9580 @<Declare a function called |copy_objects|@>=
9581 pointer mp_copy_objects (MP mp, pointer p, pointer q) {
9582 pointer hh; /* the new edge header */
9583 pointer pp; /* the last newly copied object */
9584 small_number k; /* temporary register */
9585 hh=mp_get_node(mp, edge_header_size);
9586 dash_list(hh)=null_dash;
9590 @<Make |link(pp)| point to a copy of object |p|, and update |p| and |pp|@>;
9597 @ @<Make |link(pp)| point to a copy of object |p|, and update |p| and |pp|@>=
9598 { k=mp->gr_object_size[type(p)];
9599 link(pp)=mp_get_node(mp, k);
9601 while ( (k>0) ) { decr(k); mp->mem[pp+k]=mp->mem[p+k]; };
9602 @<Fix anything in graphical object |pp| that should differ from the
9603 corresponding field in |p|@>;
9607 @ @<Fix anything in graphical object |pp| that should differ from the...@>=
9609 case mp_start_clip_code:
9610 case mp_start_bounds_code:
9611 path_p(pp)=mp_copy_path(mp, path_p(p));
9614 path_p(pp)=mp_copy_path(mp, path_p(p));
9615 if ( pre_script(p)!=null ) add_str_ref(pre_script(p));
9616 if ( post_script(p)!=null ) add_str_ref(post_script(p));
9617 if ( pen_p(p)!=null ) pen_p(pp)=copy_pen(pen_p(p));
9619 case mp_stroked_code:
9620 if ( pre_script(p)!=null ) add_str_ref(pre_script(p));
9621 if ( post_script(p)!=null ) add_str_ref(post_script(p));
9622 path_p(pp)=mp_copy_path(mp, path_p(p));
9623 pen_p(pp)=copy_pen(pen_p(p));
9624 if ( dash_p(p)!=null ) add_edge_ref(dash_p(pp));
9627 if ( pre_script(p)!=null ) add_str_ref(pre_script(p));
9628 if ( post_script(p)!=null ) add_str_ref(post_script(p));
9629 add_str_ref(text_p(pp));
9631 case mp_stop_clip_code:
9632 case mp_stop_bounds_code:
9634 } /* there are no other cases */
9636 @ Here is one way to find an acceptable value for the second argument to
9637 |copy_objects|. Given a non-null graphical object list, |skip_1component|
9638 skips past one picture component, where a ``picture component'' is a single
9639 graphical object, or a start bounds or start clip object and everything up
9640 through the matching stop bounds or stop clip object. The macro version avoids
9641 procedure call overhead and error handling: |skip_component(p)(e)| advances |p|
9642 unless |p| points to a stop bounds or stop clip node, in which case it executes
9645 @d skip_component(A)
9646 if ( ! is_start_or_stop((A)) ) (A)=link((A));
9647 else if ( ! is_stop((A)) ) (A)=mp_skip_1component(mp, (A));
9651 pointer mp_skip_1component (MP mp,pointer p) {
9652 integer lev; /* current nesting level */
9655 if ( is_start_or_stop(p) ) {
9656 if ( is_stop(p) ) decr(lev); else incr(lev);
9663 @ Here is a diagnostic routine for printing an edge structure in symbolic form.
9665 @<Declare subroutines for printing expressions@>=
9666 @<Declare subroutines needed by |print_edges|@>
9667 void mp_print_edges (MP mp,pointer h, const char *s, boolean nuline) {
9668 pointer p; /* a graphical object to be printed */
9669 pointer hh,pp; /* temporary pointers */
9670 scaled scf; /* a scale factor for the dash pattern */
9671 boolean ok_to_dash; /* |false| for polygonal pen strokes */
9672 mp_print_diagnostic(mp, "Edge structure",s,nuline);
9674 while ( link(p)!=null ) {
9678 @<Cases for printing graphical object node |p|@>;
9680 mp_print(mp, "[unknown object type!]");
9684 mp_print_nl(mp, "End edges");
9685 if ( p!=obj_tail(h) ) mp_print(mp, "?");
9687 mp_end_diagnostic(mp, true);
9690 @ @<Cases for printing graphical object node |p|@>=
9692 mp_print(mp, "Filled contour ");
9693 mp_print_obj_color(mp, p);
9694 mp_print_char(mp, ':'); mp_print_ln(mp);
9695 mp_pr_path(mp, path_p(p)); mp_print_ln(mp);
9696 if ( (pen_p(p)!=null) ) {
9697 @<Print join type for graphical object |p|@>;
9698 mp_print(mp, " with pen"); mp_print_ln(mp);
9699 mp_pr_pen(mp, pen_p(p));
9703 @ @<Print join type for graphical object |p|@>=
9704 switch (ljoin_val(p)) {
9706 mp_print(mp, "mitered joins limited ");
9707 mp_print_scaled(mp, miterlim_val(p));
9710 mp_print(mp, "round joins");
9713 mp_print(mp, "beveled joins");
9716 mp_print(mp, "?? joins");
9721 @ For stroked nodes, we need to print |lcap_val(p)| as well.
9723 @<Print join and cap types for stroked node |p|@>=
9724 switch (lcap_val(p)) {
9725 case 0:mp_print(mp, "butt"); break;
9726 case 1:mp_print(mp, "round"); break;
9727 case 2:mp_print(mp, "square"); break;
9728 default: mp_print(mp, "??"); break;
9731 mp_print(mp, " ends, ");
9732 @<Print join type for graphical object |p|@>
9734 @ Here is a routine that prints the color of a graphical object if it isn't
9735 black (the default color).
9737 @<Declare subroutines needed by |print_edges|@>=
9738 @<Declare a procedure called |print_compact_node|@>
9739 void mp_print_obj_color (MP mp,pointer p) {
9740 if ( color_model(p)==mp_grey_model ) {
9741 if ( grey_val(p)>0 ) {
9742 mp_print(mp, "greyed ");
9743 mp_print_compact_node(mp, obj_grey_loc(p),1);
9745 } else if ( color_model(p)==mp_cmyk_model ) {
9746 if ( (cyan_val(p)>0) || (magenta_val(p)>0) ||
9747 (yellow_val(p)>0) || (black_val(p)>0) ) {
9748 mp_print(mp, "processcolored ");
9749 mp_print_compact_node(mp, obj_cyan_loc(p),4);
9751 } else if ( color_model(p)==mp_rgb_model ) {
9752 if ( (red_val(p)>0) || (green_val(p)>0) || (blue_val(p)>0) ) {
9753 mp_print(mp, "colored ");
9754 mp_print_compact_node(mp, obj_red_loc(p),3);
9759 @ We also need a procedure for printing consecutive scaled values as if they
9760 were a known big node.
9762 @<Declare a procedure called |print_compact_node|@>=
9763 void mp_print_compact_node (MP mp,pointer p, small_number k) {
9764 pointer q; /* last location to print */
9766 mp_print_char(mp, '(');
9768 mp_print_scaled(mp, mp->mem[p].sc);
9769 if ( p<q ) mp_print_char(mp, ',');
9772 mp_print_char(mp, ')');
9775 @ @<Cases for printing graphical object node |p|@>=
9776 case mp_stroked_code:
9777 mp_print(mp, "Filled pen stroke ");
9778 mp_print_obj_color(mp, p);
9779 mp_print_char(mp, ':'); mp_print_ln(mp);
9780 mp_pr_path(mp, path_p(p));
9781 if ( dash_p(p)!=null ) {
9782 mp_print_nl(mp, "dashed (");
9783 @<Finish printing the dash pattern that |p| refers to@>;
9786 @<Print join and cap types for stroked node |p|@>;
9787 mp_print(mp, " with pen"); mp_print_ln(mp);
9788 if ( pen_p(p)==null ) mp_print(mp, "???"); /* shouldn't happen */
9790 else mp_pr_pen(mp, pen_p(p));
9793 @ Normally, the |dash_list| field in an edge header is set to |null_dash|
9794 when it is not known to define a suitable dash pattern. This is disallowed
9795 here because the |dash_p| field should never point to such an edge header.
9796 Note that memory is allocated for |start_x(null_dash)| and we are free to
9797 give it any convenient value.
9799 @<Finish printing the dash pattern that |p| refers to@>=
9800 ok_to_dash=pen_is_elliptical(pen_p(p));
9801 if ( ! ok_to_dash ) scf=unity; else scf=dash_scale(p);
9804 if ( (pp==null_dash) || (dash_y(hh)<0) ) {
9805 mp_print(mp, " ??");
9806 } else { start_x(null_dash)=start_x(pp)+dash_y(hh);
9807 while ( pp!=null_dash ) {
9808 mp_print(mp, "on ");
9809 mp_print_scaled(mp, mp_take_scaled(mp, stop_x(pp)-start_x(pp),scf));
9810 mp_print(mp, " off ");
9811 mp_print_scaled(mp, mp_take_scaled(mp, start_x(link(pp))-stop_x(pp),scf));
9813 if ( pp!=null_dash ) mp_print_char(mp, ' ');
9815 mp_print(mp, ") shifted ");
9816 mp_print_scaled(mp, -mp_take_scaled(mp, mp_dash_offset(mp, hh),scf));
9817 if ( ! ok_to_dash || (dash_y(hh)==0) ) mp_print(mp, " (this will be ignored)");
9820 @ @<Declare subroutines needed by |print_edges|@>=
9821 scaled mp_dash_offset (MP mp,pointer h) {
9822 scaled x; /* the answer */
9823 if (dash_list(h)==null_dash || dash_y(h)<0) mp_confusion(mp, "dash0");
9824 @:this can't happen dash0}{\quad dash0@>
9825 if ( dash_y(h)==0 ) {
9828 x=-(start_x(dash_list(h)) % dash_y(h));
9829 if ( x<0 ) x=x+dash_y(h);
9834 @ @<Cases for printing graphical object node |p|@>=
9836 mp_print_char(mp, '"'); mp_print_str(mp,text_p(p));
9837 mp_print(mp, "\" infont \""); mp_print(mp, mp->font_name[font_n(p)]);
9838 mp_print_char(mp, '"'); mp_print_ln(mp);
9839 mp_print_obj_color(mp, p);
9840 mp_print(mp, "transformed ");
9841 mp_print_compact_node(mp, text_tx_loc(p),6);
9844 @ @<Cases for printing graphical object node |p|@>=
9845 case mp_start_clip_code:
9846 mp_print(mp, "clipping path:");
9848 mp_pr_path(mp, path_p(p));
9850 case mp_stop_clip_code:
9851 mp_print(mp, "stop clipping");
9854 @ @<Cases for printing graphical object node |p|@>=
9855 case mp_start_bounds_code:
9856 mp_print(mp, "setbounds path:");
9858 mp_pr_path(mp, path_p(p));
9860 case mp_stop_bounds_code:
9861 mp_print(mp, "end of setbounds");
9864 @ To initialize the |dash_list| field in an edge header~|h|, we need a
9865 subroutine that scans an edge structure and tries to interpret it as a dash
9866 pattern. This can only be done when there are no filled regions or clipping
9867 paths and all the pen strokes have the same color. The first step is to let
9868 $y_0$ be the initial $y$~coordinate of the first pen stroke. Then we implicitly
9869 project all the pen stroke paths onto the line $y=y_0$ and require that there
9870 be no retracing. If the resulting paths cover a range of $x$~coordinates of
9871 length $\Delta x$, we set |dash_y(h)| to the length of the dash pattern by
9872 finding the maximum of $\Delta x$ and the absolute value of~$y_0$.
9874 @c @<Declare a procedure called |x_retrace_error|@>
9875 pointer mp_make_dashes (MP mp,pointer h) { /* returns |h| or |null| */
9876 pointer p; /* this scans the stroked nodes in the object list */
9877 pointer p0; /* if not |null| this points to the first stroked node */
9878 pointer pp,qq,rr; /* pointers into |path_p(p)| */
9879 pointer d,dd; /* pointers used to create the dash list */
9881 @<Other local variables in |make_dashes|@>;
9882 y0=0; /* the initial $y$ coordinate */
9883 if ( dash_list(h)!=null_dash )
9886 p=link(dummy_loc(h));
9888 if ( type(p)!=mp_stroked_code ) {
9889 @<Compain that the edge structure contains a node of the wrong type
9890 and |goto not_found|@>;
9893 if ( p0==null ){ p0=p; y0=y_coord(pp); };
9894 @<Make |d| point to a new dash node created from stroke |p| and path |pp|
9895 or |goto not_found| if there is an error@>;
9896 @<Insert |d| into the dash list and |goto not_found| if there is an error@>;
9899 if ( dash_list(h)==null_dash )
9900 goto NOT_FOUND; /* No error message */
9901 @<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>;
9902 @<Set |dash_y(h)| and merge the first and last dashes if necessary@>;
9905 @<Flush the dash list, recycle |h| and return |null|@>;
9908 @ @<Compain that the edge structure contains a node of the wrong type...@>=
9910 print_err("Picture is too complicated to use as a dash pattern");
9911 help3("When you say `dashed p', picture p should not contain any")
9912 ("text, filled regions, or clipping paths. This time it did")
9913 ("so I'll just make it a solid line instead.");
9914 mp_put_get_error(mp);
9918 @ A similar error occurs when monotonicity fails.
9920 @<Declare a procedure called |x_retrace_error|@>=
9921 void mp_x_retrace_error (MP mp) {
9922 print_err("Picture is too complicated to use as a dash pattern");
9923 help3("When you say `dashed p', every path in p should be monotone")
9924 ("in x and there must be no overlapping. This failed")
9925 ("so I'll just make it a solid line instead.");
9926 mp_put_get_error(mp);
9929 @ We stash |p| in |info(d)| if |dash_p(p)<>0| so that subsequent processing can
9930 handle the case where the pen stroke |p| is itself dashed.
9932 @<Make |d| point to a new dash node created from stroke |p| and path...@>=
9933 @<Make sure |p| and |p0| are the same color and |goto not_found| if there is
9936 if ( link(pp)!=pp ) {
9939 @<Check for retracing between knots |qq| and |rr| and |goto not_found|
9940 if there is a problem@>;
9941 } while (right_type(rr)!=mp_endpoint);
9943 d=mp_get_node(mp, dash_node_size);
9944 if ( dash_p(p)==0 ) info(d)=0; else info(d)=p;
9945 if ( x_coord(pp)<x_coord(rr) ) {
9946 start_x(d)=x_coord(pp);
9947 stop_x(d)=x_coord(rr);
9949 start_x(d)=x_coord(rr);
9950 stop_x(d)=x_coord(pp);
9953 @ We also need to check for the case where the segment from |qq| to |rr| is
9954 monotone in $x$ but is reversed relative to the path from |pp| to |qq|.
9956 @<Check for retracing between knots |qq| and |rr| and |goto not_found|...@>=
9961 if ( (x0>x1) || (x1>x2) || (x2>x3) ) {
9962 if ( (x0<x1) || (x1<x2) || (x2<x3) ) {
9963 if ( mp_ab_vs_cd(mp, x2-x1,x2-x1,x1-x0,x3-x2)>0 ) {
9964 mp_x_retrace_error(mp); goto NOT_FOUND;
9968 if ( (x_coord(pp)>x0) || (x0>x3) ) {
9969 if ( (x_coord(pp)<x0) || (x0<x3) ) {
9970 mp_x_retrace_error(mp); goto NOT_FOUND;
9974 @ @<Other local variables in |make_dashes|@>=
9975 scaled x0,x1,x2,x3; /* $x$ coordinates of the segment from |qq| to |rr| */
9977 @ @<Make sure |p| and |p0| are the same color and |goto not_found|...@>=
9978 if ( (red_val(p)!=red_val(p0)) || (black_val(p)!=black_val(p0)) ||
9979 (green_val(p)!=green_val(p0)) || (blue_val(p)!=blue_val(p0)) ) {
9980 print_err("Picture is too complicated to use as a dash pattern");
9981 help3("When you say `dashed p', everything in picture p should")
9982 ("be the same color. I can\'t handle your color changes")
9983 ("so I'll just make it a solid line instead.");
9984 mp_put_get_error(mp);
9988 @ @<Insert |d| into the dash list and |goto not_found| if there is an error@>=
9989 start_x(null_dash)=stop_x(d);
9990 dd=h; /* this makes |link(dd)=dash_list(h)| */
9991 while ( start_x(link(dd))<stop_x(d) )
9994 if ( (stop_x(dd)>start_x(d)) )
9995 { mp_x_retrace_error(mp); goto NOT_FOUND; };
10000 @ @<Set |dash_y(h)| and merge the first and last dashes if necessary@>=
10002 while ( (link(d)!=null_dash) )
10005 dash_y(h)=stop_x(d)-start_x(dd);
10006 if ( abs(y0)>dash_y(h) ) {
10008 } else if ( d!=dd ) {
10009 dash_list(h)=link(dd);
10010 stop_x(d)=stop_x(dd)+dash_y(h);
10011 mp_free_node(mp, dd,dash_node_size);
10014 @ We get here when the argument is a null picture or when there is an error.
10015 Recovering from an error involves making |dash_list(h)| empty to indicate
10016 that |h| is not known to be a valid dash pattern. We also dereference |h|
10017 since it is not being used for the return value.
10019 @<Flush the dash list, recycle |h| and return |null|@>=
10020 mp_flush_dash_list(mp, h);
10021 delete_edge_ref(h);
10024 @ Having carefully saved the dashed stroked nodes in the
10025 corresponding dash nodes, we must be prepared to break up these dashes into
10028 @<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>=
10029 d=h; /* now |link(d)=dash_list(h)| */
10030 while ( link(d)!=null_dash ) {
10036 hsf=dash_scale(ds);
10037 if ( (hh==null) ) mp_confusion(mp, "dash1");
10038 @:this can't happen dash0}{\quad dash1@>
10039 if ( dash_y(hh)==0 ) {
10042 if ( dash_list(hh)==null ) mp_confusion(mp, "dash1");
10043 @:this can't happen dash0}{\quad dash1@>
10044 @<Replace |link(d)| by a dashed version as determined by edge header
10045 |hh| and scale factor |ds|@>;
10050 @ @<Other local variables in |make_dashes|@>=
10051 pointer dln; /* |link(d)| */
10052 pointer hh; /* an edge header that tells how to break up |dln| */
10053 scaled hsf; /* the dash pattern from |hh| gets scaled by this */
10054 pointer ds; /* the stroked node from which |hh| and |hsf| are derived */
10055 scaled xoff; /* added to $x$ values in |dash_list(hh)| to match |dln| */
10057 @ @<Replace |link(d)| by a dashed version as determined by edge header...@>=
10060 xoff=start_x(dln)-mp_take_scaled(mp, hsf,start_x(dd))-
10061 mp_take_scaled(mp, hsf,mp_dash_offset(mp, hh));
10062 start_x(null_dash)=mp_take_scaled(mp, hsf,start_x(dd))
10063 +mp_take_scaled(mp, hsf,dash_y(hh));
10064 stop_x(null_dash)=start_x(null_dash);
10065 @<Advance |dd| until finding the first dash that overlaps |dln| when
10066 offset by |xoff|@>;
10067 while ( start_x(dln)<=stop_x(dln) ) {
10068 @<If |dd| has `fallen off the end', back up to the beginning and fix |xoff|@>;
10069 @<Insert a dash between |d| and |dln| for the overlap with the offset version
10072 start_x(dln)=xoff+mp_take_scaled(mp, hsf,start_x(dd));
10075 mp_free_node(mp, dln,dash_node_size)
10077 @ The name of this module is a bit of a lie because we just find the
10078 first |dd| where |take_scaled (hsf, stop_x(dd))| is large enough to make an
10079 overlap possible. It could be that the unoffset version of dash |dln| falls
10080 in the gap between |dd| and its predecessor.
10082 @<Advance |dd| until finding the first dash that overlaps |dln| when...@>=
10083 while ( xoff+mp_take_scaled(mp, hsf,stop_x(dd))<start_x(dln) ) {
10087 @ @<If |dd| has `fallen off the end', back up to the beginning and fix...@>=
10088 if ( dd==null_dash ) {
10090 xoff=xoff+mp_take_scaled(mp, hsf,dash_y(hh));
10093 @ At this point we already know that
10094 |start_x(dln)<=xoff+take_scaled(hsf,stop_x(dd))|.
10096 @<Insert a dash between |d| and |dln| for the overlap with the offset...@>=
10097 if ( (xoff+mp_take_scaled(mp, hsf,start_x(dd)))<=stop_x(dln) ) {
10098 link(d)=mp_get_node(mp, dash_node_size);
10101 if ( start_x(dln)>(xoff+mp_take_scaled(mp, hsf,start_x(dd))))
10102 start_x(d)=start_x(dln);
10104 start_x(d)=xoff+mp_take_scaled(mp, hsf,start_x(dd));
10105 if ( stop_x(dln)<(xoff+mp_take_scaled(mp, hsf,stop_x(dd))))
10106 stop_x(d)=stop_x(dln);
10108 stop_x(d)=xoff+mp_take_scaled(mp, hsf,stop_x(dd));
10111 @ The next major task is to update the bounding box information in an edge
10112 header~|h|. This is done via a procedure |adjust_bbox| that enlarges an edge
10113 header's bounding box to accommodate the box computed by |path_bbox| or
10114 |pen_bbox|. (This is stored in global variables |minx|, |miny|, |maxx|, and
10117 @c void mp_adjust_bbox (MP mp,pointer h) {
10118 if ( minx<minx_val(h) ) minx_val(h)=minx;
10119 if ( miny<miny_val(h) ) miny_val(h)=miny;
10120 if ( maxx>maxx_val(h) ) maxx_val(h)=maxx;
10121 if ( maxy>maxy_val(h) ) maxy_val(h)=maxy;
10124 @ Here is a special routine for updating the bounding box information in
10125 edge header~|h| to account for the squared-off ends of a non-cyclic path~|p|
10126 that is to be stroked with the pen~|pp|.
10128 @c void mp_box_ends (MP mp, pointer p, pointer pp, pointer h) {
10129 pointer q; /* a knot node adjacent to knot |p| */
10130 fraction dx,dy; /* a unit vector in the direction out of the path at~|p| */
10131 scaled d; /* a factor for adjusting the length of |(dx,dy)| */
10132 scaled z; /* a coordinate being tested against the bounding box */
10133 scaled xx,yy; /* the extreme pen vertex in the |(dx,dy)| direction */
10134 integer i; /* a loop counter */
10135 if ( right_type(p)!=mp_endpoint ) {
10138 @<Make |(dx,dy)| the final direction for the path segment from
10139 |q| to~|p|; set~|d|@>;
10140 d=mp_pyth_add(mp, dx,dy);
10142 @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>;
10143 for (i=1;i<= 2;i++) {
10144 @<Use |(dx,dy)| to generate a vertex of the square end cap and
10145 update the bounding box to accommodate it@>;
10149 if ( right_type(p)==mp_endpoint ) {
10152 @<Advance |p| to the end of the path and make |q| the previous knot@>;
10158 @ @<Make |(dx,dy)| the final direction for the path segment from...@>=
10159 if ( q==link(p) ) {
10160 dx=x_coord(p)-right_x(p);
10161 dy=y_coord(p)-right_y(p);
10162 if ( (dx==0)&&(dy==0) ) {
10163 dx=x_coord(p)-left_x(q);
10164 dy=y_coord(p)-left_y(q);
10167 dx=x_coord(p)-left_x(p);
10168 dy=y_coord(p)-left_y(p);
10169 if ( (dx==0)&&(dy==0) ) {
10170 dx=x_coord(p)-right_x(q);
10171 dy=y_coord(p)-right_y(q);
10174 dx=x_coord(p)-x_coord(q);
10175 dy=y_coord(p)-y_coord(q)
10177 @ @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>=
10178 dx=mp_make_fraction(mp, dx,d);
10179 dy=mp_make_fraction(mp, dy,d);
10180 mp_find_offset(mp, -dy,dx,pp);
10181 xx=mp->cur_x; yy=mp->cur_y
10183 @ @<Use |(dx,dy)| to generate a vertex of the square end cap and...@>=
10184 mp_find_offset(mp, dx,dy,pp);
10185 d=mp_take_fraction(mp, xx-mp->cur_x,dx)+mp_take_fraction(mp, yy-mp->cur_y,dy);
10186 if ( ((d<0)&&(i==1)) || ((d>0)&&(i==2)))
10187 mp_confusion(mp, "box_ends");
10188 @:this can't happen box ends}{\quad\\{box\_ends}@>
10189 z=x_coord(p)+mp->cur_x+mp_take_fraction(mp, d,dx);
10190 if ( z<minx_val(h) ) minx_val(h)=z;
10191 if ( z>maxx_val(h) ) maxx_val(h)=z;
10192 z=y_coord(p)+mp->cur_y+mp_take_fraction(mp, d,dy);
10193 if ( z<miny_val(h) ) miny_val(h)=z;
10194 if ( z>maxy_val(h) ) maxy_val(h)=z
10196 @ @<Advance |p| to the end of the path and make |q| the previous knot@>=
10200 } while (right_type(p)!=mp_endpoint)
10202 @ The major difficulty in finding the bounding box of an edge structure is the
10203 effect of clipping paths. We treat them conservatively by only clipping to the
10204 clipping path's bounding box, but this still
10205 requires recursive calls to |set_bbox| in order to find the bounding box of
10207 the objects to be clipped. Such calls are distinguished by the fact that the
10208 boolean parameter |top_level| is false.
10210 @c void mp_set_bbox (MP mp,pointer h, boolean top_level) {
10211 pointer p; /* a graphical object being considered */
10212 scaled sminx,sminy,smaxx,smaxy;
10213 /* for saving the bounding box during recursive calls */
10214 scaled x0,x1,y0,y1; /* temporary registers */
10215 integer lev; /* nesting level for |mp_start_bounds_code| nodes */
10216 @<Wipe out any existing bounding box information if |bbtype(h)| is
10217 incompatible with |internal[mp_true_corners]|@>;
10218 while ( link(bblast(h))!=null ) {
10222 case mp_stop_clip_code:
10223 if ( top_level ) mp_confusion(mp, "bbox"); else return;
10224 @:this can't happen bbox}{\quad bbox@>
10226 @<Other cases for updating the bounding box based on the type of object |p|@>;
10227 } /* all cases are enumerated above */
10229 if ( ! top_level ) mp_confusion(mp, "bbox");
10232 @ @<Internal library declarations@>=
10233 void mp_set_bbox (MP mp,pointer h, boolean top_level);
10235 @ @<Wipe out any existing bounding box information if |bbtype(h)| is...@>=
10236 switch (bbtype(h)) {
10240 if ( mp->internal[mp_true_corners]>0 ) mp_init_bbox(mp, h);
10243 if ( mp->internal[mp_true_corners]<=0 ) mp_init_bbox(mp, h);
10245 } /* there are no other cases */
10247 @ @<Other cases for updating the bounding box...@>=
10249 mp_path_bbox(mp, path_p(p));
10250 if ( pen_p(p)!=null ) {
10253 mp_pen_bbox(mp, pen_p(p));
10259 mp_adjust_bbox(mp, h);
10262 @ @<Other cases for updating the bounding box...@>=
10263 case mp_start_bounds_code:
10264 if ( mp->internal[mp_true_corners]>0 ) {
10265 bbtype(h)=bounds_unset;
10267 bbtype(h)=bounds_set;
10268 mp_path_bbox(mp, path_p(p));
10269 mp_adjust_bbox(mp, h);
10270 @<Scan to the matching |mp_stop_bounds_code| node and update |p| and
10274 case mp_stop_bounds_code:
10275 if ( mp->internal[mp_true_corners]<=0 ) mp_confusion(mp, "bbox2");
10276 @:this can't happen bbox2}{\quad bbox2@>
10279 @ @<Scan to the matching |mp_stop_bounds_code| node and update |p| and...@>=
10282 if ( link(p)==null ) mp_confusion(mp, "bbox2");
10283 @:this can't happen bbox2}{\quad bbox2@>
10285 if ( type(p)==mp_start_bounds_code ) incr(lev);
10286 else if ( type(p)==mp_stop_bounds_code ) decr(lev);
10290 @ It saves a lot of grief here to be slightly conservative and not account for
10291 omitted parts of dashed lines. We also don't worry about the material omitted
10292 when using butt end caps. The basic computation is for round end caps and
10293 |box_ends| augments it for square end caps.
10295 @<Other cases for updating the bounding box...@>=
10296 case mp_stroked_code:
10297 mp_path_bbox(mp, path_p(p));
10300 mp_pen_bbox(mp, pen_p(p));
10305 mp_adjust_bbox(mp, h);
10306 if ( (left_type(path_p(p))==mp_endpoint)&&(lcap_val(p)==2) )
10307 mp_box_ends(mp, path_p(p), pen_p(p), h);
10310 @ The height width and depth information stored in a text node determines a
10311 rectangle that needs to be transformed according to the transformation
10312 parameters stored in the text node.
10314 @<Other cases for updating the bounding box...@>=
10316 x1=mp_take_scaled(mp, txx_val(p),width_val(p));
10317 y0=mp_take_scaled(mp, txy_val(p),-depth_val(p));
10318 y1=mp_take_scaled(mp, txy_val(p),height_val(p));
10321 if ( y0<y1 ) { minx=minx+y0; maxx=maxx+y1; }
10322 else { minx=minx+y1; maxx=maxx+y0; }
10323 if ( x1<0 ) minx=minx+x1; else maxx=maxx+x1;
10324 x1=mp_take_scaled(mp, tyx_val(p),width_val(p));
10325 y0=mp_take_scaled(mp, tyy_val(p),-depth_val(p));
10326 y1=mp_take_scaled(mp, tyy_val(p),height_val(p));
10329 if ( y0<y1 ) { miny=miny+y0; maxy=maxy+y1; }
10330 else { miny=miny+y1; maxy=maxy+y0; }
10331 if ( x1<0 ) miny=miny+x1; else maxy=maxy+x1;
10332 mp_adjust_bbox(mp, h);
10335 @ This case involves a recursive call that advances |bblast(h)| to the node of
10336 type |mp_stop_clip_code| that matches |p|.
10338 @<Other cases for updating the bounding box...@>=
10339 case mp_start_clip_code:
10340 mp_path_bbox(mp, path_p(p));
10343 sminx=minx_val(h); sminy=miny_val(h);
10344 smaxx=maxx_val(h); smaxy=maxy_val(h);
10345 @<Reinitialize the bounding box in header |h| and call |set_bbox| recursively
10346 starting at |link(p)|@>;
10347 @<Clip the bounding box in |h| to the rectangle given by |x0|, |x1|,
10349 minx=sminx; miny=sminy;
10350 maxx=smaxx; maxy=smaxy;
10351 mp_adjust_bbox(mp, h);
10354 @ @<Reinitialize the bounding box in header |h| and call |set_bbox|...@>=
10355 minx_val(h)=el_gordo;
10356 miny_val(h)=el_gordo;
10357 maxx_val(h)=-el_gordo;
10358 maxy_val(h)=-el_gordo;
10359 mp_set_bbox(mp, h,false)
10361 @ @<Clip the bounding box in |h| to the rectangle given by |x0|, |x1|,...@>=
10362 if ( minx_val(h)<x0 ) minx_val(h)=x0;
10363 if ( miny_val(h)<y0 ) miny_val(h)=y0;
10364 if ( maxx_val(h)>x1 ) maxx_val(h)=x1;
10365 if ( maxy_val(h)>y1 ) maxy_val(h)=y1
10367 @* \[22] Finding an envelope.
10368 When \MP\ has a path and a polygonal pen, it needs to express the desired
10369 shape in terms of things \ps\ can understand. The present task is to compute
10370 a new path that describes the region to be filled. It is convenient to
10371 define this as a two step process where the first step is determining what
10372 offset to use for each segment of the path.
10374 @ Given a pointer |c| to a cyclic path,
10375 and a pointer~|h| to the first knot of a pen polygon,
10376 the |offset_prep| routine changes the path into cubics that are
10377 associated with particular pen offsets. Thus if the cubic between |p|
10378 and~|q| is associated with the |k|th offset and the cubic between |q| and~|r|
10379 has offset |l| then |info(q)=zero_off+l-k|. (The constant |zero_off| is added
10380 to because |l-k| could be negative.)
10382 After overwriting the type information with offset differences, we no longer
10383 have a true path so we refer to the knot list returned by |offset_prep| as an
10386 Since an envelope spec only determines relative changes in pen offsets,
10387 |offset_prep| sets a global variable |spec_offset| to the relative change from
10388 |h| to the first offset.
10390 @d zero_off 16384 /* added to offset changes to make them positive */
10393 integer spec_offset; /* number of pen edges between |h| and the initial offset */
10395 @ @c @<Declare subroutines needed by |offset_prep|@>
10396 pointer mp_offset_prep (MP mp,pointer c, pointer h) {
10397 halfword n; /* the number of vertices in the pen polygon */
10398 pointer c0,p,q,q0,r,w, ww; /* for list manipulation */
10399 integer k_needed; /* amount to be added to |info(p)| when it is computed */
10400 pointer w0; /* a pointer to pen offset to use just before |p| */
10401 scaled dxin,dyin; /* the direction into knot |p| */
10402 integer turn_amt; /* change in pen offsets for the current cubic */
10403 @<Other local variables for |offset_prep|@>;
10405 @<Initialize the pen size~|n|@>;
10406 @<Initialize the incoming direction and pen offset at |c|@>;
10407 p=c; c0=c; k_needed=0;
10410 @<Split the cubic between |p| and |q|, if necessary, into cubics
10411 associated with single offsets, after which |q| should
10412 point to the end of the final such cubic@>;
10414 @<Advance |p| to node |q|, removing any ``dead'' cubics that
10415 might have been introduced by the splitting process@>;
10417 @<Fix the offset change in |info(c)| and set |c| to the return value of
10422 @ We shall want to keep track of where certain knots on the cyclic path
10423 wind up in the envelope spec. It doesn't suffice just to keep pointers to
10424 knot nodes because some nodes are deleted while removing dead cubics. Thus
10425 |offset_prep| updates the following pointers
10429 pointer spec_p2; /* pointers to distinguished knots */
10432 mp->spec_p1=null; mp->spec_p2=null;
10434 @ @<Initialize the pen size~|n|@>=
10441 @ Since the true incoming direction isn't known yet, we just pick a direction
10442 consistent with the pen offset~|h|. If this is wrong, it can be corrected
10445 @<Initialize the incoming direction and pen offset at |c|@>=
10446 dxin=x_coord(link(h))-x_coord(knil(h));
10447 dyin=y_coord(link(h))-y_coord(knil(h));
10448 if ( (dxin==0)&&(dyin==0) ) {
10449 dxin=y_coord(knil(h))-y_coord(h);
10450 dyin=x_coord(h)-x_coord(knil(h));
10454 @ We must be careful not to remove the only cubic in a cycle.
10456 But we must also be careful for another reason. If the user-supplied
10457 path starts with a set of degenerate cubics, the target node |q| can
10458 be collapsed to the initial node |p| which might be the same as the
10459 initial node |c| of the curve. This would cause the |offset_prep| routine
10460 to bail out too early, causing distress later on. (See for example
10461 the testcase reported by Bogus\l{}aw Jackowski in tracker id 267, case 52c
10464 @<Advance |p| to node |q|, removing any ``dead'' cubics...@>=
10468 if ( x_coord(p)==right_x(p) && y_coord(p)==right_y(p) &&
10469 x_coord(p)==left_x(r) && y_coord(p)==left_y(r) &&
10470 x_coord(p)==x_coord(r) && y_coord(p)==y_coord(r) &&
10472 @<Remove the cubic following |p| and update the data structures
10473 to merge |r| into |p|@>;
10477 /* Check if we removed too much */
10478 if ((q!=q0)&&(q!=c||c==c0))
10481 @ @<Remove the cubic following |p| and update the data structures...@>=
10482 { k_needed=info(p)-zero_off;
10486 info(p)=k_needed+info(r);
10489 if ( r==c ) { info(p)=info(c); c=p; };
10490 if ( r==mp->spec_p1 ) mp->spec_p1=p;
10491 if ( r==mp->spec_p2 ) mp->spec_p2=p;
10492 r=p; mp_remove_cubic(mp, p);
10495 @ Not setting the |info| field of the newly created knot allows the splitting
10496 routine to work for paths.
10498 @<Declare subroutines needed by |offset_prep|@>=
10499 void mp_split_cubic (MP mp,pointer p, fraction t) { /* splits the cubic after |p| */
10500 scaled v; /* an intermediate value */
10501 pointer q,r; /* for list manipulation */
10502 q=link(p); r=mp_get_node(mp, knot_node_size); link(p)=r; link(r)=q;
10503 originator(r)=mp_program_code;
10504 left_type(r)=mp_explicit; right_type(r)=mp_explicit;
10505 v=t_of_the_way(right_x(p),left_x(q));
10506 right_x(p)=t_of_the_way(x_coord(p),right_x(p));
10507 left_x(q)=t_of_the_way(left_x(q),x_coord(q));
10508 left_x(r)=t_of_the_way(right_x(p),v);
10509 right_x(r)=t_of_the_way(v,left_x(q));
10510 x_coord(r)=t_of_the_way(left_x(r),right_x(r));
10511 v=t_of_the_way(right_y(p),left_y(q));
10512 right_y(p)=t_of_the_way(y_coord(p),right_y(p));
10513 left_y(q)=t_of_the_way(left_y(q),y_coord(q));
10514 left_y(r)=t_of_the_way(right_y(p),v);
10515 right_y(r)=t_of_the_way(v,left_y(q));
10516 y_coord(r)=t_of_the_way(left_y(r),right_y(r));
10519 @ This does not set |info(p)| or |right_type(p)|.
10521 @<Declare subroutines needed by |offset_prep|@>=
10522 void mp_remove_cubic (MP mp,pointer p) { /* removes the dead cubic following~|p| */
10523 pointer q; /* the node that disappears */
10524 q=link(p); link(p)=link(q);
10525 right_x(p)=right_x(q); right_y(p)=right_y(q);
10526 mp_free_node(mp, q,knot_node_size);
10529 @ Let $d\prec d'$ mean that the counter-clockwise angle from $d$ to~$d'$ is
10530 strictly between zero and $180^\circ$. Then we can define $d\preceq d'$ to
10531 mean that the angle could be zero or $180^\circ$. If $w_k=(u_k,v_k)$ is the
10532 $k$th pen offset, the $k$th pen edge direction is defined by the formula
10533 $$d_k=(u\k-u_k,\,v\k-v_k).$$
10534 When listed by increasing $k$, these directions occur in counter-clockwise
10535 order so that $d_k\preceq d\k$ for all~$k$.
10536 The goal of |offset_prep| is to find an offset index~|k| to associate with
10537 each cubic, such that the direction $d(t)$ of the cubic satisfies
10538 $$d_{k-1}\preceq d(t)\preceq d_k\qquad\hbox{for $0\le t\le 1$.}\eqno(*)$$
10539 We may have to split a cubic into many pieces before each
10540 piece corresponds to a unique offset.
10542 @<Split the cubic between |p| and |q|, if necessary, into cubics...@>=
10543 info(p)=zero_off+k_needed;
10545 @<Prepare for derivative computations;
10546 |goto not_found| if the current cubic is dead@>;
10547 @<Find the initial direction |(dx,dy)|@>;
10548 @<Update |info(p)| and find the offset $w_k$ such that
10549 $d_{k-1}\preceq(\\{dx},\\{dy})\prec d_k$; also advance |w0| for
10550 the direction change at |p|@>;
10551 @<Find the final direction |(dxin,dyin)|@>;
10552 @<Decide on the net change in pen offsets and set |turn_amt|@>;
10553 @<Complete the offset splitting process@>;
10554 w0=mp_pen_walk(mp, w0,turn_amt)
10556 @ @<Declare subroutines needed by |offset_prep|@>=
10557 pointer mp_pen_walk (MP mp,pointer w, integer k) {
10558 /* walk |k| steps around a pen from |w| */
10559 while ( k>0 ) { w=link(w); decr(k); };
10560 while ( k<0 ) { w=knil(w); incr(k); };
10564 @ The direction of a cubic $B(z_0,z_1,z_2,z_3;t)=\bigl(x(t),y(t)\bigr)$ can be
10565 calculated from the quadratic polynomials
10566 ${1\over3}x'(t)=B(x_1-x_0,x_2-x_1,x_3-x_2;t)$ and
10567 ${1\over3}y'(t)=B(y_1-y_0,y_2-y_1,y_3-y_2;t)$.
10568 Since we may be calculating directions from several cubics
10569 split from the current one, it is desirable to do these calculations
10570 without losing too much precision. ``Scaled up'' values of the
10571 derivatives, which will be less tainted by accumulated errors than
10572 derivatives found from the cubics themselves, are maintained in
10573 local variables |x0|, |x1|, and |x2|, representing $X_0=2^l(x_1-x_0)$,
10574 $X_1=2^l(x_2-x_1)$, and $X_2=2^l(x_3-x_2)$; similarly |y0|, |y1|, and~|y2|
10575 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)$.
10577 @<Other local variables for |offset_prep|@>=
10578 integer x0,x1,x2,y0,y1,y2; /* representatives of derivatives */
10579 integer t0,t1,t2; /* coefficients of polynomial for slope testing */
10580 integer du,dv,dx,dy; /* for directions of the pen and the curve */
10581 integer dx0,dy0; /* initial direction for the first cubic in the curve */
10582 integer max_coef; /* used while scaling */
10583 integer x0a,x1a,x2a,y0a,y1a,y2a; /* intermediate values */
10584 fraction t; /* where the derivative passes through zero */
10585 fraction s; /* a temporary value */
10587 @ @<Prepare for derivative computations...@>=
10588 x0=right_x(p)-x_coord(p);
10589 x2=x_coord(q)-left_x(q);
10590 x1=left_x(q)-right_x(p);
10591 y0=right_y(p)-y_coord(p); y2=y_coord(q)-left_y(q);
10592 y1=left_y(q)-right_y(p);
10594 if ( abs(x1)>max_coef ) max_coef=abs(x1);
10595 if ( abs(x2)>max_coef ) max_coef=abs(x2);
10596 if ( abs(y0)>max_coef ) max_coef=abs(y0);
10597 if ( abs(y1)>max_coef ) max_coef=abs(y1);
10598 if ( abs(y2)>max_coef ) max_coef=abs(y2);
10599 if ( max_coef==0 ) goto NOT_FOUND;
10600 while ( max_coef<fraction_half ) {
10602 double(x0); double(x1); double(x2);
10603 double(y0); double(y1); double(y2);
10606 @ Let us first solve a special case of the problem: Suppose we
10607 know an index~$k$ such that either (i)~$d(t)\succeq d_{k-1}$ for all~$t$
10608 and $d(0)\prec d_k$, or (ii)~$d(t)\preceq d_k$ for all~$t$ and
10609 $d(0)\succ d_{k-1}$.
10610 Then, in a sense, we're halfway done, since one of the two relations
10611 in $(*)$ is satisfied, and the other couldn't be satisfied for
10612 any other value of~|k|.
10614 Actually, the conditions can be relaxed somewhat since a relation such as
10615 $d(t)\succeq d_{k-1}$ restricts $d(t)$ to a half plane when all that really
10616 matters is whether $d(t)$ crosses the ray in the $d_{k-1}$ direction from
10617 the origin. The condition for case~(i) becomes $d_{k-1}\preceq d(0)\prec d_k$
10618 and $d(t)$ never crosses the $d_{k-1}$ ray in the clockwise direction.
10619 Case~(ii) is similar except $d(t)$ cannot cross the $d_k$ ray in the
10620 counterclockwise direction.
10622 The |fin_offset_prep| subroutine solves the stated subproblem.
10623 It has a parameter called |rise| that is |1| in
10624 case~(i), |-1| in case~(ii). Parameters |x0| through |y2| represent
10625 the derivative of the cubic following |p|.
10626 The |w| parameter should point to offset~$w_k$ and |info(p)| should already
10627 be set properly. The |turn_amt| parameter gives the absolute value of the
10628 overall net change in pen offsets.
10630 @<Declare subroutines needed by |offset_prep|@>=
10631 void mp_fin_offset_prep (MP mp,pointer p, pointer w, integer
10632 x0,integer x1, integer x2, integer y0, integer y1, integer y2,
10633 integer rise, integer turn_amt) {
10634 pointer ww; /* for list manipulation */
10635 scaled du,dv; /* for slope calculation */
10636 integer t0,t1,t2; /* test coefficients */
10637 fraction t; /* place where the derivative passes a critical slope */
10638 fraction s; /* slope or reciprocal slope */
10639 integer v; /* intermediate value for updating |x0..y2| */
10640 pointer q; /* original |link(p)| */
10643 if ( rise>0 ) ww=link(w); /* a pointer to $w\k$ */
10644 else ww=knil(w); /* a pointer to $w_{k-1}$ */
10645 @<Compute test coefficients |(t0,t1,t2)|
10646 for $d(t)$ versus $d_k$ or $d_{k-1}$@>;
10647 t=mp_crossing_point(mp, t0,t1,t2);
10648 if ( t>=fraction_one ) {
10649 if ( turn_amt>0 ) t=fraction_one; else return;
10651 @<Split the cubic at $t$,
10652 and split off another cubic if the derivative crosses back@>;
10657 @ We want $B(\\{t0},\\{t1},\\{t2};t)$ to be the dot product of $d(t)$ with a
10658 $-90^\circ$ rotation of the vector from |w| to |ww|. This makes the resulting
10659 function cross from positive to negative when $d_{k-1}\preceq d(t)\preceq d_k$
10662 @<Compute test coefficients |(t0,t1,t2)| for $d(t)$ versus...@>=
10663 du=x_coord(ww)-x_coord(w); dv=y_coord(ww)-y_coord(w);
10664 if ( abs(du)>=abs(dv) ) {
10665 s=mp_make_fraction(mp, dv,du);
10666 t0=mp_take_fraction(mp, x0,s)-y0;
10667 t1=mp_take_fraction(mp, x1,s)-y1;
10668 t2=mp_take_fraction(mp, x2,s)-y2;
10669 if ( du<0 ) { negate(t0); negate(t1); negate(t2); }
10671 s=mp_make_fraction(mp, du,dv);
10672 t0=x0-mp_take_fraction(mp, y0,s);
10673 t1=x1-mp_take_fraction(mp, y1,s);
10674 t2=x2-mp_take_fraction(mp, y2,s);
10675 if ( dv<0 ) { negate(t0); negate(t1); negate(t2); }
10677 if ( t0<0 ) t0=0 /* should be positive without rounding error */
10679 @ The curve has crossed $d_k$ or $d_{k-1}$; its initial segment satisfies
10680 $(*)$, and it might cross again and return towards $s_{k-1}$ or $s_k$,
10681 respectively, yielding another solution of $(*)$.
10683 @<Split the cubic at $t$, and split off another...@>=
10685 mp_split_cubic(mp, p,t); p=link(p); info(p)=zero_off+rise;
10687 v=t_of_the_way(x0,x1); x1=t_of_the_way(x1,x2);
10688 x0=t_of_the_way(v,x1);
10689 v=t_of_the_way(y0,y1); y1=t_of_the_way(y1,y2);
10690 y0=t_of_the_way(v,y1);
10691 if ( turn_amt<0 ) {
10692 t1=t_of_the_way(t1,t2);
10693 if ( t1>0 ) t1=0; /* without rounding error, |t1| would be |<=0| */
10694 t=mp_crossing_point(mp, 0,-t1,-t2);
10695 if ( t>fraction_one ) t=fraction_one;
10697 if ( (t==fraction_one)&&(link(p)!=q) ) {
10698 info(link(p))=info(link(p))-rise;
10700 mp_split_cubic(mp, p,t); info(link(p))=zero_off-rise;
10701 v=t_of_the_way(x1,x2); x1=t_of_the_way(x0,x1);
10702 x2=t_of_the_way(x1,v);
10703 v=t_of_the_way(y1,y2); y1=t_of_the_way(y0,y1);
10704 y2=t_of_the_way(y1,v);
10709 @ Now we must consider the general problem of |offset_prep|, when
10710 nothing is known about a given cubic. We start by finding its
10711 direction in the vicinity of |t=0|.
10713 If $z'(t)=0$, the given cubic is numerically unstable but |offset_prep|
10714 has not yet introduced any more numerical errors. Thus we can compute
10715 the true initial direction for the given cubic, even if it is almost
10718 @<Find the initial direction |(dx,dy)|@>=
10720 if ( dx==0 && dy==0 ) {
10722 if ( dx==0 && dy==0 ) {
10726 if ( p==c ) { dx0=dx; dy0=dy; }
10728 @ @<Find the final direction |(dxin,dyin)|@>=
10730 if ( dxin==0 && dyin==0 ) {
10732 if ( dxin==0 && dyin==0 ) {
10737 @ The next step is to bracket the initial direction between consecutive
10738 edges of the pen polygon. We must be careful to turn clockwise only if
10739 this makes the turn less than $180^\circ$. (A $180^\circ$ turn must be
10740 counter-clockwise in order to make \&{doublepath} envelopes come out
10741 @:double_path_}{\&{doublepath} primitive@>
10742 right.) This code depends on |w0| being the offset for |(dxin,dyin)|.
10744 @<Update |info(p)| and find the offset $w_k$ such that...@>=
10745 turn_amt=mp_get_turn_amt(mp,w0,dx,dy,(mp_ab_vs_cd(mp, dy,dxin,dx,dyin)>=0));
10746 w=mp_pen_walk(mp, w0, turn_amt);
10748 info(p)=info(p)+turn_amt
10750 @ Decide how many pen offsets to go away from |w| in order to find the offset
10751 for |(dx,dy)|, going counterclockwise if |ccw| is |true|. This assumes that
10752 |w| is the offset for some direction $(x',y')$ from which the angle to |(dx,dy)|
10753 in the sense determined by |ccw| is less than or equal to $180^\circ$.
10755 If the pen polygon has only two edges, they could both be parallel
10756 to |(dx,dy)|. In this case, we must be careful to stop after crossing the first
10757 such edge in order to avoid an infinite loop.
10759 @<Declare subroutines needed by |offset_prep|@>=
10760 integer mp_get_turn_amt (MP mp,pointer w, scaled dx,
10761 scaled dy, boolean ccw) {
10762 pointer ww; /* a neighbor of knot~|w| */
10763 integer s; /* turn amount so far */
10764 integer t; /* |ab_vs_cd| result */
10769 t=mp_ab_vs_cd(mp, dy,(x_coord(ww)-x_coord(w)),
10770 dx,(y_coord(ww)-y_coord(w)));
10777 while ( mp_ab_vs_cd(mp, dy,(x_coord(w)-x_coord(ww)),
10778 dx,(y_coord(w)-y_coord(ww))) < 0) {
10786 @ When we're all done, the final offset is |w0| and the final curve direction
10787 is |(dxin,dyin)|. With this knowledge of the incoming direction at |c|, we
10788 can correct |info(c)| which was erroneously based on an incoming offset
10791 @d fix_by(A) info(c)=info(c)+(A)
10793 @<Fix the offset change in |info(c)| and set |c| to the return value of...@>=
10794 mp->spec_offset=info(c)-zero_off;
10795 if ( link(c)==c ) {
10796 info(c)=zero_off+n;
10799 while ( w0!=h ) { fix_by(1); w0=link(w0); };
10800 while ( info(c)<=zero_off-n ) fix_by(n);
10801 while ( info(c)>zero_off ) fix_by(-n);
10802 if ( (info(c)!=zero_off)&&(mp_ab_vs_cd(mp, dy0,dxin,dx0,dyin)>=0) ) fix_by(n);
10805 @ Finally we want to reduce the general problem to situations that
10806 |fin_offset_prep| can handle. We split the cubic into at most three parts
10807 with respect to $d_{k-1}$, and apply |fin_offset_prep| to each part.
10809 @<Complete the offset splitting process@>=
10811 @<Compute test coeff...@>;
10812 @<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set
10813 |t:=fraction_one+1|@>;
10814 if ( t>fraction_one ) {
10815 mp_fin_offset_prep(mp, p,w,x0,x1,x2,y0,y1,y2,1,turn_amt);
10817 mp_split_cubic(mp, p,t); r=link(p);
10818 x1a=t_of_the_way(x0,x1); x1=t_of_the_way(x1,x2);
10819 x2a=t_of_the_way(x1a,x1);
10820 y1a=t_of_the_way(y0,y1); y1=t_of_the_way(y1,y2);
10821 y2a=t_of_the_way(y1a,y1);
10822 mp_fin_offset_prep(mp, p,w,x0,x1a,x2a,y0,y1a,y2a,1,0); x0=x2a; y0=y2a;
10823 info(r)=zero_off-1;
10824 if ( turn_amt>=0 ) {
10825 t1=t_of_the_way(t1,t2);
10827 t=mp_crossing_point(mp, 0,-t1,-t2);
10828 if ( t>fraction_one ) t=fraction_one;
10829 @<Split off another rising cubic for |fin_offset_prep|@>;
10830 mp_fin_offset_prep(mp, r,ww,x0,x1,x2,y0,y1,y2,-1,0);
10832 mp_fin_offset_prep(mp, r,ww,x0,x1,x2,y0,y1,y2,-1,(-1-turn_amt));
10836 @ @<Split off another rising cubic for |fin_offset_prep|@>=
10837 mp_split_cubic(mp, r,t); info(link(r))=zero_off+1;
10838 x1a=t_of_the_way(x1,x2); x1=t_of_the_way(x0,x1);
10839 x0a=t_of_the_way(x1,x1a);
10840 y1a=t_of_the_way(y1,y2); y1=t_of_the_way(y0,y1);
10841 y0a=t_of_the_way(y1,y1a);
10842 mp_fin_offset_prep(mp, link(r),w,x0a,x1a,x2,y0a,y1a,y2,1,turn_amt);
10845 @ At this point, the direction of the incoming pen edge is |(-du,-dv)|.
10846 When the component of $d(t)$ perpendicular to |(-du,-dv)| crosses zero, we
10847 need to decide whether the directions are parallel or antiparallel. We
10848 can test this by finding the dot product of $d(t)$ and |(-du,-dv)|, but this
10849 should be avoided when the value of |turn_amt| already determines the
10850 answer. If |t2<0|, there is one crossing and it is antiparallel only if
10851 |turn_amt>=0|. If |turn_amt<0|, there should always be at least one
10852 crossing and the first crossing cannot be antiparallel.
10854 @<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set...@>=
10855 t=mp_crossing_point(mp, t0,t1,t2);
10856 if ( turn_amt>=0 ) {
10860 u0=t_of_the_way(x0,x1);
10861 u1=t_of_the_way(x1,x2);
10862 ss=mp_take_fraction(mp, -du,t_of_the_way(u0,u1));
10863 v0=t_of_the_way(y0,y1);
10864 v1=t_of_the_way(y1,y2);
10865 ss=ss+mp_take_fraction(mp, -dv,t_of_the_way(v0,v1));
10866 if ( ss<0 ) t=fraction_one+1;
10868 } else if ( t>fraction_one ) {
10872 @ @<Other local variables for |offset_prep|@>=
10873 integer u0,u1,v0,v1; /* intermediate values for $d(t)$ calculation */
10874 integer ss = 0; /* the part of the dot product computed so far */
10875 int d_sign; /* sign of overall change in direction for this cubic */
10877 @ If the cubic almost has a cusp, it is a numerically ill-conditioned
10878 problem to decide which way it loops around but that's OK as long we're
10879 consistent. To make \&{doublepath} envelopes work properly, reversing
10880 the path should always change the sign of |turn_amt|.
10882 @<Decide on the net change in pen offsets and set |turn_amt|@>=
10883 d_sign=mp_ab_vs_cd(mp, dx,dyin, dxin,dy);
10885 @<Check rotation direction based on node position@>
10889 if ( dy>0 ) d_sign=1; else d_sign=-1;
10891 if ( dx>0 ) d_sign=1; else d_sign=-1;
10894 @<Make |ss| negative if and only if the total change in direction is
10895 more than $180^\circ$@>;
10896 turn_amt=mp_get_turn_amt(mp, w, dxin, dyin, (d_sign>0));
10897 if ( ss<0 ) turn_amt=turn_amt-d_sign*n
10899 @ We check rotation direction by looking at the vector connecting the current
10900 node with the next. If its angle with incoming and outgoing tangents has the
10901 same sign, we pick this as |d_sign|, since it means we have a flex, not a cusp.
10902 Otherwise we proceed to the cusp code.
10904 @<Check rotation direction based on node position@>=
10905 u0=x_coord(q)-x_coord(p);
10906 u1=y_coord(q)-y_coord(p);
10907 d_sign = half(mp_ab_vs_cd(mp, dx, u1, u0, dy)+
10908 mp_ab_vs_cd(mp, u0, dyin, dxin, u1));
10910 @ In order to be invariant under path reversal, the result of this computation
10911 should not change when |x0|, |y0|, $\ldots$ are all negated and |(x0,y0)| is
10912 then swapped with |(x2,y2)|. We make use of the identities
10913 |take_fraction(-a,-b)=take_fraction(a,b)| and
10914 |t_of_the_way(-a,-b)=-(t_of_the_way(a,b))|.
10916 @<Make |ss| negative if and only if the total change in direction is...@>=
10917 t0=half(mp_take_fraction(mp, x0,y2))-half(mp_take_fraction(mp, x2,y0));
10918 t1=half(mp_take_fraction(mp, x1,(y0+y2)))-half(mp_take_fraction(mp, y1,(x0+x2)));
10919 if ( t0==0 ) t0=d_sign; /* path reversal always negates |d_sign| */
10921 t=mp_crossing_point(mp, t0,t1,-t0);
10922 u0=t_of_the_way(x0,x1);
10923 u1=t_of_the_way(x1,x2);
10924 v0=t_of_the_way(y0,y1);
10925 v1=t_of_the_way(y1,y2);
10927 t=mp_crossing_point(mp, -t0,t1,t0);
10928 u0=t_of_the_way(x2,x1);
10929 u1=t_of_the_way(x1,x0);
10930 v0=t_of_the_way(y2,y1);
10931 v1=t_of_the_way(y1,y0);
10933 ss=mp_take_fraction(mp, (x0+x2),t_of_the_way(u0,u1))+
10934 mp_take_fraction(mp, (y0+y2),t_of_the_way(v0,v1))
10936 @ Here's a routine that prints an envelope spec in symbolic form. It assumes
10937 that the |cur_pen| has not been walked around to the first offset.
10940 void mp_print_spec (MP mp,pointer cur_spec, pointer cur_pen, const char *s) {
10941 pointer p,q; /* list traversal */
10942 pointer w; /* the current pen offset */
10943 mp_print_diagnostic(mp, "Envelope spec",s,true);
10944 p=cur_spec; w=mp_pen_walk(mp, cur_pen,mp->spec_offset);
10946 mp_print_two(mp, x_coord(cur_spec),y_coord(cur_spec));
10947 mp_print(mp, " % beginning with offset ");
10948 mp_print_two(mp, x_coord(w),y_coord(w));
10952 @<Print the cubic between |p| and |q|@>;
10954 if ((p==cur_spec) || (info(p)!=zero_off))
10957 if ( info(p)!=zero_off ) {
10958 @<Update |w| as indicated by |info(p)| and print an explanation@>;
10960 } while (p!=cur_spec);
10961 mp_print_nl(mp, " & cycle");
10962 mp_end_diagnostic(mp, true);
10965 @ @<Update |w| as indicated by |info(p)| and print an explanation@>=
10967 w=mp_pen_walk(mp, w, (info(p)-zero_off));
10968 mp_print(mp, " % ");
10969 if ( info(p)>zero_off ) mp_print(mp, "counter");
10970 mp_print(mp, "clockwise to offset ");
10971 mp_print_two(mp, x_coord(w),y_coord(w));
10974 @ @<Print the cubic between |p| and |q|@>=
10976 mp_print_nl(mp, " ..controls ");
10977 mp_print_two(mp, right_x(p),right_y(p));
10978 mp_print(mp, " and ");
10979 mp_print_two(mp, left_x(q),left_y(q));
10980 mp_print_nl(mp, " ..");
10981 mp_print_two(mp, x_coord(q),y_coord(q));
10984 @ Once we have an envelope spec, the remaining task to construct the actual
10985 envelope by offsetting each cubic as determined by the |info| fields in
10986 the knots. First we use |offset_prep| to convert the |c| into an envelope
10987 spec. Then we add the offsets so that |c| becomes a cyclic path that represents
10990 The |ljoin| and |miterlim| parameters control the treatment of points where the
10991 pen offset changes, and |lcap| controls the endpoints of a \&{doublepath}.
10992 The endpoints are easily located because |c| is given in undoubled form
10993 and then doubled in this procedure. We use |spec_p1| and |spec_p2| to keep
10994 track of the endpoints and treat them like very sharp corners.
10995 Butt end caps are treated like beveled joins; round end caps are treated like
10996 round joins; and square end caps are achieved by setting |join_type:=3|.
10998 None of these parameters apply to inside joins where the convolution tracing
10999 has retrograde lines. In such cases we use a simple connect-the-endpoints
11000 approach that is achieved by setting |join_type:=2|.
11002 @c @<Declare a function called |insert_knot|@>
11003 pointer mp_make_envelope (MP mp,pointer c, pointer h, small_number ljoin,
11004 small_number lcap, scaled miterlim) {
11005 pointer p,q,r,q0; /* for manipulating the path */
11006 int join_type=0; /* codes |0..3| for mitered, round, beveled, or square */
11007 pointer w,w0; /* the pen knot for the current offset */
11008 scaled qx,qy; /* unshifted coordinates of |q| */
11009 halfword k,k0; /* controls pen edge insertion */
11010 @<Other local variables for |make_envelope|@>;
11011 dxin=0; dyin=0; dxout=0; dyout=0;
11012 mp->spec_p1=null; mp->spec_p2=null;
11013 @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>;
11014 @<Use |offset_prep| to compute the envelope spec then walk |h| around to
11015 the initial offset@>;
11020 qx=x_coord(q); qy=y_coord(q);
11023 if ( k!=zero_off ) {
11024 @<Set |join_type| to indicate how to handle offset changes at~|q|@>;
11026 @<Add offset |w| to the cubic from |p| to |q|@>;
11027 while ( k!=zero_off ) {
11028 @<Step |w| and move |k| one step closer to |zero_off|@>;
11029 if ( (join_type==1)||(k==zero_off) )
11030 q=mp_insert_knot(mp, q,qx+x_coord(w),qy+y_coord(w));
11032 if ( q!=link(p) ) {
11033 @<Set |p=link(p)| and add knots between |p| and |q| as
11034 required by |join_type|@>;
11041 @ @<Use |offset_prep| to compute the envelope spec then walk |h| around to...@>=
11042 c=mp_offset_prep(mp, c,h);
11043 if ( mp->internal[mp_tracing_specs]>0 )
11044 mp_print_spec(mp, c,h,"");
11045 h=mp_pen_walk(mp, h,mp->spec_offset)
11047 @ Mitered and squared-off joins depend on path directions that are difficult to
11048 compute for degenerate cubics. The envelope spec computed by |offset_prep| can
11049 have degenerate cubics only if the entire cycle collapses to a single
11050 degenerate cubic. Setting |join_type:=2| in this case makes the computed
11051 envelope degenerate as well.
11053 @<Set |join_type| to indicate how to handle offset changes at~|q|@>=
11054 if ( k<zero_off ) {
11057 if ( (q!=mp->spec_p1)&&(q!=mp->spec_p2) ) join_type=ljoin;
11058 else if ( lcap==2 ) join_type=3;
11059 else join_type=2-lcap;
11060 if ( (join_type==0)||(join_type==3) ) {
11061 @<Set the incoming and outgoing directions at |q|; in case of
11062 degeneracy set |join_type:=2|@>;
11063 if ( join_type==0 ) {
11064 @<If |miterlim| is less than the secant of half the angle at |q|
11065 then set |join_type:=2|@>;
11070 @ @<If |miterlim| is less than the secant of half the angle at |q|...@>=
11072 tmp=mp_take_fraction(mp, miterlim,fraction_half+
11073 half(mp_take_fraction(mp, dxin,dxout)+mp_take_fraction(mp, dyin,dyout)));
11075 if ( mp_take_scaled(mp, miterlim,tmp)<unity ) join_type=2;
11078 @ @<Other local variables for |make_envelope|@>=
11079 fraction dxin,dyin,dxout,dyout; /* directions at |q| when square or mitered */
11080 scaled tmp; /* a temporary value */
11082 @ The coordinates of |p| have already been shifted unless |p| is the first
11083 knot in which case they get shifted at the very end.
11085 @<Add offset |w| to the cubic from |p| to |q|@>=
11086 right_x(p)=right_x(p)+x_coord(w);
11087 right_y(p)=right_y(p)+y_coord(w);
11088 left_x(q)=left_x(q)+x_coord(w);
11089 left_y(q)=left_y(q)+y_coord(w);
11090 x_coord(q)=x_coord(q)+x_coord(w);
11091 y_coord(q)=y_coord(q)+y_coord(w);
11092 left_type(q)=mp_explicit;
11093 right_type(q)=mp_explicit
11095 @ @<Step |w| and move |k| one step closer to |zero_off|@>=
11096 if ( k>zero_off ){ w=link(w); decr(k); }
11097 else { w=knil(w); incr(k); }
11099 @ The cubic from |q| to the new knot at |(x,y)| becomes a line segment and
11100 the |right_x| and |right_y| fields of |r| are set from |q|. This is done in
11101 case the cubic containing these control points is ``yet to be examined.''
11103 @<Declare a function called |insert_knot|@>=
11104 pointer mp_insert_knot (MP mp,pointer q, scaled x, scaled y) {
11105 /* returns the inserted knot */
11106 pointer r; /* the new knot */
11107 r=mp_get_node(mp, knot_node_size);
11108 link(r)=link(q); link(q)=r;
11109 right_x(r)=right_x(q);
11110 right_y(r)=right_y(q);
11113 right_x(q)=x_coord(q);
11114 right_y(q)=y_coord(q);
11115 left_x(r)=x_coord(r);
11116 left_y(r)=y_coord(r);
11117 left_type(r)=mp_explicit;
11118 right_type(r)=mp_explicit;
11119 originator(r)=mp_program_code;
11123 @ After setting |p:=link(p)|, either |join_type=1| or |q=link(p)|.
11125 @<Set |p=link(p)| and add knots between |p| and |q| as...@>=
11128 if ( (join_type==0)||(join_type==3) ) {
11129 if ( join_type==0 ) {
11130 @<Insert a new knot |r| between |p| and |q| as required for a mitered join@>
11132 @<Make |r| the last of two knots inserted between |p| and |q| to form a
11136 right_x(r)=x_coord(r);
11137 right_y(r)=y_coord(r);
11142 @ For very small angles, adding a knot is unnecessary and would cause numerical
11143 problems, so we just set |r:=null| in that case.
11145 @<Insert a new knot |r| between |p| and |q| as required for a mitered join@>=
11147 det=mp_take_fraction(mp, dyout,dxin)-mp_take_fraction(mp, dxout,dyin);
11148 if ( abs(det)<26844 ) {
11149 r=null; /* sine $<10^{-4}$ */
11151 tmp=mp_take_fraction(mp, x_coord(q)-x_coord(p),dyout)-
11152 mp_take_fraction(mp, y_coord(q)-y_coord(p),dxout);
11153 tmp=mp_make_fraction(mp, tmp,det);
11154 r=mp_insert_knot(mp, p,x_coord(p)+mp_take_fraction(mp, tmp,dxin),
11155 y_coord(p)+mp_take_fraction(mp, tmp,dyin));
11159 @ @<Other local variables for |make_envelope|@>=
11160 fraction det; /* a determinant used for mitered join calculations */
11162 @ @<Make |r| the last of two knots inserted between |p| and |q| to form a...@>=
11164 ht_x=y_coord(w)-y_coord(w0);
11165 ht_y=x_coord(w0)-x_coord(w);
11166 while ( (abs(ht_x)<fraction_half)&&(abs(ht_y)<fraction_half) ) {
11167 ht_x+=ht_x; ht_y+=ht_y;
11169 @<Scan the pen polygon between |w0| and |w| and make |max_ht| the range dot
11170 product with |(ht_x,ht_y)|@>;
11171 tmp=mp_make_fraction(mp, max_ht,mp_take_fraction(mp, dxin,ht_x)+
11172 mp_take_fraction(mp, dyin,ht_y));
11173 r=mp_insert_knot(mp, p,x_coord(p)+mp_take_fraction(mp, tmp,dxin),
11174 y_coord(p)+mp_take_fraction(mp, tmp,dyin));
11175 tmp=mp_make_fraction(mp, max_ht,mp_take_fraction(mp, dxout,ht_x)+
11176 mp_take_fraction(mp, dyout,ht_y));
11177 r=mp_insert_knot(mp, r,x_coord(q)+mp_take_fraction(mp, tmp,dxout),
11178 y_coord(q)+mp_take_fraction(mp, tmp,dyout));
11181 @ @<Other local variables for |make_envelope|@>=
11182 fraction ht_x,ht_y; /* perpendicular to the segment from |p| to |q| */
11183 scaled max_ht; /* maximum height of the pen polygon above the |w0|-|w| line */
11184 halfword kk; /* keeps track of the pen vertices being scanned */
11185 pointer ww; /* the pen vertex being tested */
11187 @ The dot product of the vector from |w0| to |ww| with |(ht_x,ht_y)| ranges
11188 from zero to |max_ht|.
11190 @<Scan the pen polygon between |w0| and |w| and make |max_ht| the range...@>=
11195 @<Step |ww| and move |kk| one step closer to |k0|@>;
11196 if ( kk==k0 ) break;
11197 tmp=mp_take_fraction(mp, (x_coord(ww)-x_coord(w0)),ht_x)+
11198 mp_take_fraction(mp, (y_coord(ww)-y_coord(w0)),ht_y);
11199 if ( tmp>max_ht ) max_ht=tmp;
11203 @ @<Step |ww| and move |kk| one step closer to |k0|@>=
11204 if ( kk>k0 ) { ww=link(ww); decr(kk); }
11205 else { ww=knil(ww); incr(kk); }
11207 @ @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>=
11208 if ( left_type(c)==mp_endpoint ) {
11209 mp->spec_p1=mp_htap_ypoc(mp, c);
11210 mp->spec_p2=mp->path_tail;
11211 originator(mp->spec_p1)=mp_program_code;
11212 link(mp->spec_p2)=link(mp->spec_p1);
11213 link(mp->spec_p1)=c;
11214 mp_remove_cubic(mp, mp->spec_p1);
11216 if ( c!=link(c) ) {
11217 originator(mp->spec_p2)=mp_program_code;
11218 mp_remove_cubic(mp, mp->spec_p2);
11220 @<Make |c| look like a cycle of length one@>;
11224 @ @<Make |c| look like a cycle of length one@>=
11226 left_type(c)=mp_explicit; right_type(c)=mp_explicit;
11227 left_x(c)=x_coord(c); left_y(c)=y_coord(c);
11228 right_x(c)=x_coord(c); right_y(c)=y_coord(c);
11231 @ In degenerate situations we might have to look at the knot preceding~|q|.
11232 That knot is |p| but if |p<>c|, its coordinates have already been offset by |w|.
11234 @<Set the incoming and outgoing directions at |q|; in case of...@>=
11235 dxin=x_coord(q)-left_x(q);
11236 dyin=y_coord(q)-left_y(q);
11237 if ( (dxin==0)&&(dyin==0) ) {
11238 dxin=x_coord(q)-right_x(p);
11239 dyin=y_coord(q)-right_y(p);
11240 if ( (dxin==0)&&(dyin==0) ) {
11241 dxin=x_coord(q)-x_coord(p);
11242 dyin=y_coord(q)-y_coord(p);
11243 if ( p!=c ) { /* the coordinates of |p| have been offset by |w| */
11244 dxin=dxin+x_coord(w);
11245 dyin=dyin+y_coord(w);
11249 tmp=mp_pyth_add(mp, dxin,dyin);
11253 dxin=mp_make_fraction(mp, dxin,tmp);
11254 dyin=mp_make_fraction(mp, dyin,tmp);
11255 @<Set the outgoing direction at |q|@>;
11258 @ If |q=c| then the coordinates of |r| and the control points between |q|
11259 and~|r| have already been offset by |h|.
11261 @<Set the outgoing direction at |q|@>=
11262 dxout=right_x(q)-x_coord(q);
11263 dyout=right_y(q)-y_coord(q);
11264 if ( (dxout==0)&&(dyout==0) ) {
11266 dxout=left_x(r)-x_coord(q);
11267 dyout=left_y(r)-y_coord(q);
11268 if ( (dxout==0)&&(dyout==0) ) {
11269 dxout=x_coord(r)-x_coord(q);
11270 dyout=y_coord(r)-y_coord(q);
11274 dxout=dxout-x_coord(h);
11275 dyout=dyout-y_coord(h);
11277 tmp=mp_pyth_add(mp, dxout,dyout);
11278 if ( tmp==0 ) mp_confusion(mp, "degenerate spec");
11279 @:this can't happen degerate spec}{\quad degenerate spec@>
11280 dxout=mp_make_fraction(mp, dxout,tmp);
11281 dyout=mp_make_fraction(mp, dyout,tmp)
11283 @* \[23] Direction and intersection times.
11284 A path of length $n$ is defined parametrically by functions $x(t)$ and
11285 $y(t)$, for |0<=t<=n|; we can regard $t$ as the ``time'' at which the path
11286 reaches the point $\bigl(x(t),y(t)\bigr)$. In this section of the program
11287 we shall consider operations that determine special times associated with
11288 given paths: the first time that a path travels in a given direction, and
11289 a pair of times at which two paths cross each other.
11291 @ Let's start with the easier task. The function |find_direction_time| is
11292 given a direction |(x,y)| and a path starting at~|h|. If the path never
11293 travels in direction |(x,y)|, the direction time will be~|-1|; otherwise
11294 it will be nonnegative.
11296 Certain anomalous cases can arise: If |(x,y)=(0,0)|, so that the given
11297 direction is undefined, the direction time will be~0. If $\bigl(x'(t),
11298 y'(t)\bigr)=(0,0)$, so that the path direction is undefined, it will be
11299 assumed to match any given direction at time~|t|.
11301 The routine solves this problem in nondegenerate cases by rotating the path
11302 and the given direction so that |(x,y)=(1,0)|; i.e., the main task will be
11303 to find when a given path first travels ``due east.''
11306 scaled mp_find_direction_time (MP mp,scaled x, scaled y, pointer h) {
11307 scaled max; /* $\max\bigl(\vert x\vert,\vert y\vert\bigr)$ */
11308 pointer p,q; /* for list traversal */
11309 scaled n; /* the direction time at knot |p| */
11310 scaled tt; /* the direction time within a cubic */
11311 @<Other local variables for |find_direction_time|@>;
11312 @<Normalize the given direction for better accuracy;
11313 but |return| with zero result if it's zero@>;
11316 if ( right_type(p)==mp_endpoint ) break;
11318 @<Rotate the cubic between |p| and |q|; then
11319 |goto found| if the rotated cubic travels due east at some time |tt|;
11320 but |break| if an entire cyclic path has been traversed@>;
11328 @ @<Normalize the given direction for better accuracy...@>=
11329 if ( abs(x)<abs(y) ) {
11330 x=mp_make_fraction(mp, x,abs(y));
11331 if ( y>0 ) y=fraction_one; else y=-fraction_one;
11332 } else if ( x==0 ) {
11335 y=mp_make_fraction(mp, y,abs(x));
11336 if ( x>0 ) x=fraction_one; else x=-fraction_one;
11339 @ Since we're interested in the tangent directions, we work with the
11340 derivative $${1\over3}B'(x_0,x_1,x_2,x_3;t)=
11341 B(x_1-x_0,x_2-x_1,x_3-x_2;t)$$ instead of
11342 $B(x_0,x_1,x_2,x_3;t)$ itself. The derived coefficients are also scaled up
11343 in order to achieve better accuracy.
11345 The given path may turn abruptly at a knot, and it might pass the critical
11346 tangent direction at such a time. Therefore we remember the direction |phi|
11347 in which the previous rotated cubic was traveling. (The value of |phi| will be
11348 undefined on the first cubic, i.e., when |n=0|.)
11350 @<Rotate the cubic between |p| and |q|; then...@>=
11352 @<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples of the control
11353 points of the rotated derivatives@>;
11354 if ( y1==0 ) if ( x1>=0 ) goto FOUND;
11356 @<Exit to |found| if an eastward direction occurs at knot |p|@>;
11359 if ( (x3!=0)||(y3!=0) ) phi=mp_n_arg(mp, x3,y3);
11360 @<Exit to |found| if the curve whose derivatives are specified by
11361 |x1,x2,x3,y1,y2,y3| travels eastward at some time~|tt|@>
11363 @ @<Other local variables for |find_direction_time|@>=
11364 scaled x1,x2,x3,y1,y2,y3; /* multiples of rotated derivatives */
11365 angle theta,phi; /* angles of exit and entry at a knot */
11366 fraction t; /* temp storage */
11368 @ @<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples...@>=
11369 x1=right_x(p)-x_coord(p); x2=left_x(q)-right_x(p);
11370 x3=x_coord(q)-left_x(q);
11371 y1=right_y(p)-y_coord(p); y2=left_y(q)-right_y(p);
11372 y3=y_coord(q)-left_y(q);
11374 if ( abs(x2)>max ) max=abs(x2);
11375 if ( abs(x3)>max ) max=abs(x3);
11376 if ( abs(y1)>max ) max=abs(y1);
11377 if ( abs(y2)>max ) max=abs(y2);
11378 if ( abs(y3)>max ) max=abs(y3);
11379 if ( max==0 ) goto FOUND;
11380 while ( max<fraction_half ){
11381 max+=max; x1+=x1; x2+=x2; x3+=x3;
11382 y1+=y1; y2+=y2; y3+=y3;
11384 t=x1; x1=mp_take_fraction(mp, x1,x)+mp_take_fraction(mp, y1,y);
11385 y1=mp_take_fraction(mp, y1,x)-mp_take_fraction(mp, t,y);
11386 t=x2; x2=mp_take_fraction(mp, x2,x)+mp_take_fraction(mp, y2,y);
11387 y2=mp_take_fraction(mp, y2,x)-mp_take_fraction(mp, t,y);
11388 t=x3; x3=mp_take_fraction(mp, x3,x)+mp_take_fraction(mp, y3,y);
11389 y3=mp_take_fraction(mp, y3,x)-mp_take_fraction(mp, t,y)
11391 @ @<Exit to |found| if an eastward direction occurs at knot |p|@>=
11392 theta=mp_n_arg(mp, x1,y1);
11393 if ( theta>=0 ) if ( phi<=0 ) if ( phi>=theta-one_eighty_deg ) goto FOUND;
11394 if ( theta<=0 ) if ( phi>=0 ) if ( phi<=theta+one_eighty_deg ) goto FOUND
11396 @ In this step we want to use the |crossing_point| routine to find the
11397 roots of the quadratic equation $B(y_1,y_2,y_3;t)=0$.
11398 Several complications arise: If the quadratic equation has a double root,
11399 the curve never crosses zero, and |crossing_point| will find nothing;
11400 this case occurs iff $y_1y_3=y_2^2$ and $y_1y_2<0$. If the quadratic
11401 equation has simple roots, or only one root, we may have to negate it
11402 so that $B(y_1,y_2,y_3;t)$ crosses from positive to negative at its first root.
11403 And finally, we need to do special things if $B(y_1,y_2,y_3;t)$ is
11406 @ @<Exit to |found| if the curve whose derivatives are specified by...@>=
11407 if ( x1<0 ) if ( x2<0 ) if ( x3<0 ) goto DONE;
11408 if ( mp_ab_vs_cd(mp, y1,y3,y2,y2)==0 ) {
11409 @<Handle the test for eastward directions when $y_1y_3=y_2^2$;
11410 either |goto found| or |goto done|@>;
11413 if ( y1<0 ) { y1=-y1; y2=-y2; y3=-y3; }
11414 else if ( y2>0 ){ y2=-y2; y3=-y3; };
11416 @<Check the places where $B(y_1,y_2,y_3;t)=0$ to see if
11417 $B(x_1,x_2,x_3;t)\ge0$@>;
11420 @ The quadratic polynomial $B(y_1,y_2,y_3;t)$ begins |>=0| and has at most
11421 two roots, because we know that it isn't identically zero.
11423 It must be admitted that the |crossing_point| routine is not perfectly accurate;
11424 rounding errors might cause it to find a root when $y_1y_3>y_2^2$, or to
11425 miss the roots when $y_1y_3<y_2^2$. The rotation process is itself
11426 subject to rounding errors. Yet this code optimistically tries to
11427 do the right thing.
11429 @d we_found_it { tt=(t+04000) / 010000; goto FOUND; }
11431 @<Check the places where $B(y_1,y_2,y_3;t)=0$...@>=
11432 t=mp_crossing_point(mp, y1,y2,y3);
11433 if ( t>fraction_one ) goto DONE;
11434 y2=t_of_the_way(y2,y3);
11435 x1=t_of_the_way(x1,x2);
11436 x2=t_of_the_way(x2,x3);
11437 x1=t_of_the_way(x1,x2);
11438 if ( x1>=0 ) we_found_it;
11440 tt=t; t=mp_crossing_point(mp, 0,-y2,-y3);
11441 if ( t>fraction_one ) goto DONE;
11442 x1=t_of_the_way(x1,x2);
11443 x2=t_of_the_way(x2,x3);
11444 if ( t_of_the_way(x1,x2)>=0 ) {
11445 t=t_of_the_way(tt,fraction_one); we_found_it;
11448 @ @<Handle the test for eastward directions when $y_1y_3=y_2^2$;
11449 either |goto found| or |goto done|@>=
11451 if ( mp_ab_vs_cd(mp, y1,y2,0,0)<0 ) {
11452 t=mp_make_fraction(mp, y1,y1-y2);
11453 x1=t_of_the_way(x1,x2);
11454 x2=t_of_the_way(x2,x3);
11455 if ( t_of_the_way(x1,x2)>=0 ) we_found_it;
11456 } else if ( y3==0 ) {
11458 @<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|@>;
11459 } else if ( x3>=0 ) {
11460 tt=unity; goto FOUND;
11466 @ At this point we know that the derivative of |y(t)| is identically zero,
11467 and that |x1<0|; but either |x2>=0| or |x3>=0|, so there's some hope of
11470 @<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|...@>=
11472 t=mp_crossing_point(mp, -x1,-x2,-x3);
11473 if ( t<=fraction_one ) we_found_it;
11474 if ( mp_ab_vs_cd(mp, x1,x3,x2,x2)<=0 ) {
11475 t=mp_make_fraction(mp, x1,x1-x2); we_found_it;
11479 @ The intersection of two cubics can be found by an interesting variant
11480 of the general bisection scheme described in the introduction to
11482 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)$,
11483 we wish to find a pair of times $(t_1,t_2)$ such that $w(t_1)=z(t_2)$,
11484 if an intersection exists. First we find the smallest rectangle that
11485 encloses the points $\{w_0,w_1,w_2,w_3\}$ and check that it overlaps
11486 the smallest rectangle that encloses
11487 $\{z_0,z_1,z_2,z_3\}$; if not, the cubics certainly don't intersect.
11488 But if the rectangles do overlap, we bisect the intervals, getting
11489 new cubics $w'$ and~$w''$, $z'$~and~$z''$; the intersection routine first
11490 tries for an intersection between $w'$ and~$z'$, then (if unsuccessful)
11491 between $w'$ and~$z''$, then (if still unsuccessful) between $w''$ and~$z'$,
11492 finally (if thrice unsuccessful) between $w''$ and~$z''$. After $l$~successful
11493 levels of bisection we will have determined the intersection times $t_1$
11494 and~$t_2$ to $l$~bits of accuracy.
11496 \def\submin{_{\rm min}} \def\submax{_{\rm max}}
11497 As before, it is better to work with the numbers $W_k=2^l(w_k-w_{k-1})$
11498 and $Z_k=2^l(z_k-z_{k-1})$ rather than the coefficients $w_k$ and $z_k$
11499 themselves. We also need one other quantity, $\Delta=2^l(w_0-z_0)$,
11500 to determine when the enclosing rectangles overlap. Here's why:
11501 The $x$~coordinates of~$w(t)$ are between $u\submin$ and $u\submax$,
11502 and the $x$~coordinates of~$z(t)$ are between $x\submin$ and $x\submax$,
11503 if we write $w_k=(u_k,v_k)$ and $z_k=(x_k,y_k)$ and $u\submin=
11504 \min(u_0,u_1,u_2,u_3)$, etc. These intervals of $x$~coordinates
11505 overlap if and only if $u\submin\L x\submax$ and
11506 $x\submin\L u\submax$. Letting
11507 $$U\submin=\min(0,U_1,U_1+U_2,U_1+U_2+U_3),\;
11508 U\submax=\max(0,U_1,U_1+U_2,U_1+U_2+U_3),$$
11509 we have $2^lu\submin=2^lu_0+U\submin$, etc.; the condition for overlap
11511 $$X\submin-U\submax\L 2^l(u_0-x_0)\L X\submax-U\submin.$$
11512 Thus we want to maintain the quantity $2^l(u_0-x_0)$; similarly,
11513 the quantity $2^l(v_0-y_0)$ accounts for the $y$~coordinates. The
11514 coordinates of $\Delta=2^l(w_0-z_0)$ must stay bounded as $l$ increases,
11515 because of the overlap condition; i.e., we know that $X\submin$,
11516 $X\submax$, and their relatives are bounded, hence $X\submax-
11517 U\submin$ and $X\submin-U\submax$ are bounded.
11519 @ Incidentally, if the given cubics intersect more than once, the process
11520 just sketched will not necessarily find the lexicographically smallest pair
11521 $(t_1,t_2)$. The solution actually obtained will be smallest in ``shuffled
11522 order''; i.e., if $t_1=(.a_1a_2\ldots a_{16})_2$ and
11523 $t_2=(.b_1b_2\ldots b_{16})_2$, then we will minimize
11524 $a_1b_1a_2b_2\ldots a_{16}b_{16}$, not
11525 $a_1a_2\ldots a_{16}b_1b_2\ldots b_{16}$.
11526 Shuffled order agrees with lexicographic order if all pairs of solutions
11527 $(t_1,t_2)$ and $(t_1',t_2')$ have the property that $t_1<t_1'$ iff
11528 $t_2<t_2'$; but in general, lexicographic order can be quite different,
11529 and the bisection algorithm would be substantially less efficient if it were
11530 constrained by lexicographic order.
11532 For example, suppose that an overlap has been found for $l=3$ and
11533 $(t_1,t_2)= (.101,.011)$ in binary, but that no overlap is produced by
11534 either of the alternatives $(.1010,.0110)$, $(.1010,.0111)$ at level~4.
11535 Then there is probably an intersection in one of the subintervals
11536 $(.1011,.011x)$; but lexicographic order would require us to explore
11537 $(.1010,.1xxx)$ and $(.1011,.00xx)$ and $(.1011,.010x)$ first. We wouldn't
11538 want to store all of the subdivision data for the second path, so the
11539 subdivisions would have to be regenerated many times. Such inefficiencies
11540 would be associated with every `1' in the binary representation of~$t_1$.
11542 @ The subdivision process introduces rounding errors, hence we need to
11543 make a more liberal test for overlap. It is not hard to show that the
11544 computed values of $U_i$ differ from the truth by at most~$l$, on
11545 level~$l$, hence $U\submin$ and $U\submax$ will be at most $3l$ in error.
11546 If $\beta$ is an upper bound on the absolute error in the computed
11547 components of $\Delta=(|delx|,|dely|)$ on level~$l$, we will replace
11548 the test `$X\submin-U\submax\L|delx|$' by the more liberal test
11549 `$X\submin-U\submax\L|delx|+|tol|$', where $|tol|=6l+\beta$.
11551 More accuracy is obtained if we try the algorithm first with |tol=0|;
11552 the more liberal tolerance is used only if an exact approach fails.
11553 It is convenient to do this double-take by letting `3' in the preceding
11554 paragraph be a parameter, which is first 0, then 3.
11557 unsigned int tol_step; /* either 0 or 3, usually */
11559 @ We shall use an explicit stack to implement the recursive bisection
11560 method described above. The |bisect_stack| array will contain numerous 5-word
11561 packets like $(U_1,U_2,U_3,U\submin,U\submax)$, as well as 20-word packets
11562 comprising the 5-word packets for $U$, $V$, $X$, and~$Y$.
11564 The following macros define the allocation of stack positions to
11565 the quantities needed for bisection-intersection.
11567 @d stack_1(A) mp->bisect_stack[(A)] /* $U_1$, $V_1$, $X_1$, or $Y_1$ */
11568 @d stack_2(A) mp->bisect_stack[(A)+1] /* $U_2$, $V_2$, $X_2$, or $Y_2$ */
11569 @d stack_3(A) mp->bisect_stack[(A)+2] /* $U_3$, $V_3$, $X_3$, or $Y_3$ */
11570 @d stack_min(A) mp->bisect_stack[(A)+3]
11571 /* $U\submin$, $V\submin$, $X\submin$, or $Y\submin$ */
11572 @d stack_max(A) mp->bisect_stack[(A)+4]
11573 /* $U\submax$, $V\submax$, $X\submax$, or $Y\submax$ */
11574 @d int_packets 20 /* number of words to represent $U_k$, $V_k$, $X_k$, and $Y_k$ */
11576 @d u_packet(A) ((A)-5)
11577 @d v_packet(A) ((A)-10)
11578 @d x_packet(A) ((A)-15)
11579 @d y_packet(A) ((A)-20)
11580 @d l_packets (mp->bisect_ptr-int_packets)
11581 @d r_packets mp->bisect_ptr
11582 @d ul_packet u_packet(l_packets) /* base of $U'_k$ variables */
11583 @d vl_packet v_packet(l_packets) /* base of $V'_k$ variables */
11584 @d xl_packet x_packet(l_packets) /* base of $X'_k$ variables */
11585 @d yl_packet y_packet(l_packets) /* base of $Y'_k$ variables */
11586 @d ur_packet u_packet(r_packets) /* base of $U''_k$ variables */
11587 @d vr_packet v_packet(r_packets) /* base of $V''_k$ variables */
11588 @d xr_packet x_packet(r_packets) /* base of $X''_k$ variables */
11589 @d yr_packet y_packet(r_packets) /* base of $Y''_k$ variables */
11591 @d u1l stack_1(ul_packet) /* $U'_1$ */
11592 @d u2l stack_2(ul_packet) /* $U'_2$ */
11593 @d u3l stack_3(ul_packet) /* $U'_3$ */
11594 @d v1l stack_1(vl_packet) /* $V'_1$ */
11595 @d v2l stack_2(vl_packet) /* $V'_2$ */
11596 @d v3l stack_3(vl_packet) /* $V'_3$ */
11597 @d x1l stack_1(xl_packet) /* $X'_1$ */
11598 @d x2l stack_2(xl_packet) /* $X'_2$ */
11599 @d x3l stack_3(xl_packet) /* $X'_3$ */
11600 @d y1l stack_1(yl_packet) /* $Y'_1$ */
11601 @d y2l stack_2(yl_packet) /* $Y'_2$ */
11602 @d y3l stack_3(yl_packet) /* $Y'_3$ */
11603 @d u1r stack_1(ur_packet) /* $U''_1$ */
11604 @d u2r stack_2(ur_packet) /* $U''_2$ */
11605 @d u3r stack_3(ur_packet) /* $U''_3$ */
11606 @d v1r stack_1(vr_packet) /* $V''_1$ */
11607 @d v2r stack_2(vr_packet) /* $V''_2$ */
11608 @d v3r stack_3(vr_packet) /* $V''_3$ */
11609 @d x1r stack_1(xr_packet) /* $X''_1$ */
11610 @d x2r stack_2(xr_packet) /* $X''_2$ */
11611 @d x3r stack_3(xr_packet) /* $X''_3$ */
11612 @d y1r stack_1(yr_packet) /* $Y''_1$ */
11613 @d y2r stack_2(yr_packet) /* $Y''_2$ */
11614 @d y3r stack_3(yr_packet) /* $Y''_3$ */
11616 @d stack_dx mp->bisect_stack[mp->bisect_ptr] /* stacked value of |delx| */
11617 @d stack_dy mp->bisect_stack[mp->bisect_ptr+1] /* stacked value of |dely| */
11618 @d stack_tol mp->bisect_stack[mp->bisect_ptr+2] /* stacked value of |tol| */
11619 @d stack_uv mp->bisect_stack[mp->bisect_ptr+3] /* stacked value of |uv| */
11620 @d stack_xy mp->bisect_stack[mp->bisect_ptr+4] /* stacked value of |xy| */
11621 @d int_increment (int_packets+int_packets+5) /* number of stack words per level */
11624 integer *bisect_stack;
11625 unsigned int bisect_ptr;
11627 @ @<Allocate or initialize ...@>=
11628 mp->bisect_stack = xmalloc((bistack_size+1),sizeof(integer));
11630 @ @<Dealloc variables@>=
11631 xfree(mp->bisect_stack);
11633 @ @<Check the ``constant''...@>=
11634 if ( int_packets+17*int_increment>bistack_size ) mp->bad=19;
11636 @ Computation of the min and max is a tedious but fairly fast sequence of
11637 instructions; exactly four comparisons are made in each branch.
11640 if ( stack_1((A))<0 ) {
11641 if ( stack_3((A))>=0 ) {
11642 if ( stack_2((A))<0 ) stack_min((A))=stack_1((A))+stack_2((A));
11643 else stack_min((A))=stack_1((A));
11644 stack_max((A))=stack_1((A))+stack_2((A))+stack_3((A));
11645 if ( stack_max((A))<0 ) stack_max((A))=0;
11647 stack_min((A))=stack_1((A))+stack_2((A))+stack_3((A));
11648 if ( stack_min((A))>stack_1((A)) ) stack_min((A))=stack_1((A));
11649 stack_max((A))=stack_1((A))+stack_2((A));
11650 if ( stack_max((A))<0 ) stack_max((A))=0;
11652 } else if ( stack_3((A))<=0 ) {
11653 if ( stack_2((A))>0 ) stack_max((A))=stack_1((A))+stack_2((A));
11654 else stack_max((A))=stack_1((A));
11655 stack_min((A))=stack_1((A))+stack_2((A))+stack_3((A));
11656 if ( stack_min((A))>0 ) stack_min((A))=0;
11658 stack_max((A))=stack_1((A))+stack_2((A))+stack_3((A));
11659 if ( stack_max((A))<stack_1((A)) ) stack_max((A))=stack_1((A));
11660 stack_min((A))=stack_1((A))+stack_2((A));
11661 if ( stack_min((A))>0 ) stack_min((A))=0;
11664 @ It's convenient to keep the current values of $l$, $t_1$, and $t_2$ in
11665 the integer form $2^l+2^lt_1$ and $2^l+2^lt_2$. The |cubic_intersection|
11666 routine uses global variables |cur_t| and |cur_tt| for this purpose;
11667 after successful completion, |cur_t| and |cur_tt| will contain |unity|
11668 plus the |scaled| values of $t_1$ and~$t_2$.
11670 The values of |cur_t| and |cur_tt| will be set to zero if |cubic_intersection|
11671 finds no intersection. The routine gives up and gives an approximate answer
11672 if it has backtracked
11673 more than 5000 times (otherwise there are cases where several minutes
11674 of fruitless computation would be possible).
11676 @d max_patience 5000
11679 integer cur_t;integer cur_tt; /* controls and results of |cubic_intersection| */
11680 integer time_to_go; /* this many backtracks before giving up */
11681 integer max_t; /* maximum of $2^{l+1}$ so far achieved */
11683 @ The given cubics $B(w_0,w_1,w_2,w_3;t)$ and
11684 $B(z_0,z_1,z_2,z_3;t)$ are specified in adjacent knot nodes |(p,link(p))|
11685 and |(pp,link(pp))|, respectively.
11687 @c void mp_cubic_intersection (MP mp,pointer p, pointer pp) {
11688 pointer q,qq; /* |link(p)|, |link(pp)| */
11689 mp->time_to_go=max_patience; mp->max_t=2;
11690 @<Initialize for intersections at level zero@>;
11693 if ( mp->delx-mp->tol<=stack_max(x_packet(mp->xy))-stack_min(u_packet(mp->uv)))
11694 if ( mp->delx+mp->tol>=stack_min(x_packet(mp->xy))-stack_max(u_packet(mp->uv)))
11695 if ( mp->dely-mp->tol<=stack_max(y_packet(mp->xy))-stack_min(v_packet(mp->uv)))
11696 if ( mp->dely+mp->tol>=stack_min(y_packet(mp->xy))-stack_max(v_packet(mp->uv)))
11698 if ( mp->cur_t>=mp->max_t ){
11699 if ( mp->max_t==two ) { /* we've done 17 bisections */
11700 mp->cur_t=halfp(mp->cur_t+1);
11701 mp->cur_tt=halfp(mp->cur_tt+1);
11704 mp->max_t+=mp->max_t; mp->appr_t=mp->cur_t; mp->appr_tt=mp->cur_tt;
11706 @<Subdivide for a new level of intersection@>;
11709 if ( mp->time_to_go>0 ) {
11710 decr(mp->time_to_go);
11712 while ( mp->appr_t<unity ) {
11713 mp->appr_t+=mp->appr_t; mp->appr_tt+=mp->appr_tt;
11715 mp->cur_t=mp->appr_t; mp->cur_tt=mp->appr_tt; return;
11717 @<Advance to the next pair |(cur_t,cur_tt)|@>;
11721 @ The following variables are global, although they are used only by
11722 |cubic_intersection|, because it is necessary on some machines to
11723 split |cubic_intersection| up into two procedures.
11726 integer delx;integer dely; /* the components of $\Delta=2^l(w_0-z_0)$ */
11727 integer tol; /* bound on the uncertainty in the overlap test */
11729 unsigned int xy; /* pointers to the current packets of interest */
11730 integer three_l; /* |tol_step| times the bisection level */
11731 integer appr_t;integer appr_tt; /* best approximations known to the answers */
11733 @ We shall assume that the coordinates are sufficiently non-extreme that
11734 integer overflow will not occur.
11735 @^overflow in arithmetic@>
11737 @<Initialize for intersections at level zero@>=
11738 q=link(p); qq=link(pp); mp->bisect_ptr=int_packets;
11739 u1r=right_x(p)-x_coord(p); u2r=left_x(q)-right_x(p);
11740 u3r=x_coord(q)-left_x(q); set_min_max(ur_packet);
11741 v1r=right_y(p)-y_coord(p); v2r=left_y(q)-right_y(p);
11742 v3r=y_coord(q)-left_y(q); set_min_max(vr_packet);
11743 x1r=right_x(pp)-x_coord(pp); x2r=left_x(qq)-right_x(pp);
11744 x3r=x_coord(qq)-left_x(qq); set_min_max(xr_packet);
11745 y1r=right_y(pp)-y_coord(pp); y2r=left_y(qq)-right_y(pp);
11746 y3r=y_coord(qq)-left_y(qq); set_min_max(yr_packet);
11747 mp->delx=x_coord(p)-x_coord(pp); mp->dely=y_coord(p)-y_coord(pp);
11748 mp->tol=0; mp->uv=r_packets; mp->xy=r_packets;
11749 mp->three_l=0; mp->cur_t=1; mp->cur_tt=1
11751 @ @<Subdivide for a new level of intersection@>=
11752 stack_dx=mp->delx; stack_dy=mp->dely; stack_tol=mp->tol;
11753 stack_uv=mp->uv; stack_xy=mp->xy;
11754 mp->bisect_ptr=mp->bisect_ptr+int_increment;
11755 mp->cur_t+=mp->cur_t; mp->cur_tt+=mp->cur_tt;
11756 u1l=stack_1(u_packet(mp->uv)); u3r=stack_3(u_packet(mp->uv));
11757 u2l=half(u1l+stack_2(u_packet(mp->uv)));
11758 u2r=half(u3r+stack_2(u_packet(mp->uv)));
11759 u3l=half(u2l+u2r); u1r=u3l;
11760 set_min_max(ul_packet); set_min_max(ur_packet);
11761 v1l=stack_1(v_packet(mp->uv)); v3r=stack_3(v_packet(mp->uv));
11762 v2l=half(v1l+stack_2(v_packet(mp->uv)));
11763 v2r=half(v3r+stack_2(v_packet(mp->uv)));
11764 v3l=half(v2l+v2r); v1r=v3l;
11765 set_min_max(vl_packet); set_min_max(vr_packet);
11766 x1l=stack_1(x_packet(mp->xy)); x3r=stack_3(x_packet(mp->xy));
11767 x2l=half(x1l+stack_2(x_packet(mp->xy)));
11768 x2r=half(x3r+stack_2(x_packet(mp->xy)));
11769 x3l=half(x2l+x2r); x1r=x3l;
11770 set_min_max(xl_packet); set_min_max(xr_packet);
11771 y1l=stack_1(y_packet(mp->xy)); y3r=stack_3(y_packet(mp->xy));
11772 y2l=half(y1l+stack_2(y_packet(mp->xy)));
11773 y2r=half(y3r+stack_2(y_packet(mp->xy)));
11774 y3l=half(y2l+y2r); y1r=y3l;
11775 set_min_max(yl_packet); set_min_max(yr_packet);
11776 mp->uv=l_packets; mp->xy=l_packets;
11777 mp->delx+=mp->delx; mp->dely+=mp->dely;
11778 mp->tol=mp->tol-mp->three_l+mp->tol_step;
11779 mp->tol+=mp->tol; mp->three_l=mp->three_l+mp->tol_step
11781 @ @<Advance to the next pair |(cur_t,cur_tt)|@>=
11783 if ( odd(mp->cur_tt) ) {
11784 if ( odd(mp->cur_t) ) {
11785 @<Descend to the previous level and |goto not_found|@>;
11788 mp->delx=mp->delx+stack_1(u_packet(mp->uv))+stack_2(u_packet(mp->uv))
11789 +stack_3(u_packet(mp->uv));
11790 mp->dely=mp->dely+stack_1(v_packet(mp->uv))+stack_2(v_packet(mp->uv))
11791 +stack_3(v_packet(mp->uv));
11792 mp->uv=mp->uv+int_packets; /* switch from |l_packets| to |r_packets| */
11793 decr(mp->cur_tt); mp->xy=mp->xy-int_packets;
11794 /* switch from |r_packets| to |l_packets| */
11795 mp->delx=mp->delx+stack_1(x_packet(mp->xy))+stack_2(x_packet(mp->xy))
11796 +stack_3(x_packet(mp->xy));
11797 mp->dely=mp->dely+stack_1(y_packet(mp->xy))+stack_2(y_packet(mp->xy))
11798 +stack_3(y_packet(mp->xy));
11801 incr(mp->cur_tt); mp->tol=mp->tol+mp->three_l;
11802 mp->delx=mp->delx-stack_1(x_packet(mp->xy))-stack_2(x_packet(mp->xy))
11803 -stack_3(x_packet(mp->xy));
11804 mp->dely=mp->dely-stack_1(y_packet(mp->xy))-stack_2(y_packet(mp->xy))
11805 -stack_3(y_packet(mp->xy));
11806 mp->xy=mp->xy+int_packets; /* switch from |l_packets| to |r_packets| */
11809 @ @<Descend to the previous level...@>=
11811 mp->cur_t=halfp(mp->cur_t); mp->cur_tt=halfp(mp->cur_tt);
11812 if ( mp->cur_t==0 ) return;
11813 mp->bisect_ptr=mp->bisect_ptr-int_increment;
11814 mp->three_l=mp->three_l-mp->tol_step;
11815 mp->delx=stack_dx; mp->dely=stack_dy; mp->tol=stack_tol;
11816 mp->uv=stack_uv; mp->xy=stack_xy;
11820 @ The |path_intersection| procedure is much simpler.
11821 It invokes |cubic_intersection| in lexicographic order until finding a
11822 pair of cubics that intersect. The final intersection times are placed in
11823 |cur_t| and~|cur_tt|.
11825 @c void mp_path_intersection (MP mp,pointer h, pointer hh) {
11826 pointer p,pp; /* link registers that traverse the given paths */
11827 integer n,nn; /* integer parts of intersection times, minus |unity| */
11828 @<Change one-point paths into dead cycles@>;
11833 if ( right_type(p)!=mp_endpoint ) {
11836 if ( right_type(pp)!=mp_endpoint ) {
11837 mp_cubic_intersection(mp, p,pp);
11838 if ( mp->cur_t>0 ) {
11839 mp->cur_t=mp->cur_t+n; mp->cur_tt=mp->cur_tt+nn;
11843 nn=nn+unity; pp=link(pp);
11846 n=n+unity; p=link(p);
11848 mp->tol_step=mp->tol_step+3;
11849 } while (mp->tol_step<=3);
11850 mp->cur_t=-unity; mp->cur_tt=-unity;
11853 @ @<Change one-point paths...@>=
11854 if ( right_type(h)==mp_endpoint ) {
11855 right_x(h)=x_coord(h); left_x(h)=x_coord(h);
11856 right_y(h)=y_coord(h); left_y(h)=y_coord(h); right_type(h)=mp_explicit;
11858 if ( right_type(hh)==mp_endpoint ) {
11859 right_x(hh)=x_coord(hh); left_x(hh)=x_coord(hh);
11860 right_y(hh)=y_coord(hh); left_y(hh)=y_coord(hh); right_type(hh)=mp_explicit;
11863 @* \[24] Dynamic linear equations.
11864 \MP\ users define variables implicitly by stating equations that should be
11865 satisfied; the computer is supposed to be smart enough to solve those equations.
11866 And indeed, the computer tries valiantly to do so, by distinguishing five
11867 different types of numeric values:
11870 |type(p)=mp_known| is the nice case, when |value(p)| is the |scaled| value
11871 of the variable whose address is~|p|.
11874 |type(p)=mp_dependent| means that |value(p)| is not present, but |dep_list(p)|
11875 points to a {\sl dependency list\/} that expresses the value of variable~|p|
11876 as a |scaled| number plus a sum of independent variables with |fraction|
11880 |type(p)=mp_independent| means that |value(p)=64s+m|, where |s>0| is a ``serial
11881 number'' reflecting the time this variable was first used in an equation;
11882 also |0<=m<64|, and each dependent variable
11883 that refers to this one is actually referring to the future value of
11884 this variable times~$2^m$. (Usually |m=0|, but higher degrees of
11885 scaling are sometimes needed to keep the coefficients in dependency lists
11886 from getting too large. The value of~|m| will always be even.)
11889 |type(p)=mp_numeric_type| means that variable |p| hasn't appeared in an
11890 equation before, but it has been explicitly declared to be numeric.
11893 |type(p)=undefined| means that variable |p| hasn't appeared before.
11895 \smallskip\noindent
11896 We have actually discussed these five types in the reverse order of their
11897 history during a computation: Once |known|, a variable never again
11898 becomes |dependent|; once |dependent|, it almost never again becomes
11899 |mp_independent|; once |mp_independent|, it never again becomes |mp_numeric_type|;
11900 and once |mp_numeric_type|, it never again becomes |undefined| (except
11901 of course when the user specifically decides to scrap the old value
11902 and start again). A backward step may, however, take place: Sometimes
11903 a |dependent| variable becomes |mp_independent| again, when one of the
11904 independent variables it depends on is reverting to |undefined|.
11907 The next patch detects overflow of independent-variable serial
11908 numbers. Diagnosed and patched by Thorsten Dahlheimer.
11910 @d s_scale 64 /* the serial numbers are multiplied by this factor */
11911 @d new_indep(A) /* create a new independent variable */
11912 { if ( mp->serial_no>el_gordo-s_scale )
11913 mp_fatal_error(mp, "variable instance identifiers exhausted");
11914 type((A))=mp_independent; mp->serial_no=mp->serial_no+s_scale;
11915 value((A))=mp->serial_no;
11919 integer serial_no; /* the most recent serial number, times |s_scale| */
11921 @ @<Make variable |q+s| newly independent@>=new_indep(q+s)
11923 @ But how are dependency lists represented? It's simple: The linear combination
11924 $\alpha_1v_1+\cdots+\alpha_kv_k+\beta$ appears in |k+1| value nodes. If
11925 |q=dep_list(p)| points to this list, and if |k>0|, then |value(q)=
11926 @t$\alpha_1$@>| (which is a |fraction|); |info(q)| points to the location
11927 of $\alpha_1$; and |link(p)| points to the dependency list
11928 $\alpha_2v_2+\cdots+\alpha_kv_k+\beta$. On the other hand if |k=0|,
11929 then |value(q)=@t$\beta$@>| (which is |scaled|) and |info(q)=null|.
11930 The independent variables $v_1$, \dots,~$v_k$ have been sorted so that
11931 they appear in decreasing order of their |value| fields (i.e., of
11932 their serial numbers). \ (It is convenient to use decreasing order,
11933 since |value(null)=0|. If the independent variables were not sorted by
11934 serial number but by some other criterion, such as their location in |mem|,
11935 the equation-solving mechanism would be too system-dependent, because
11936 the ordering can affect the computed results.)
11938 The |link| field in the node that contains the constant term $\beta$ is
11939 called the {\sl final link\/} of the dependency list. \MP\ maintains
11940 a doubly-linked master list of all dependency lists, in terms of a permanently
11942 in |mem| called |dep_head|. If there are no dependencies, we have
11943 |link(dep_head)=dep_head| and |prev_dep(dep_head)=dep_head|;
11944 otherwise |link(dep_head)| points to the first dependent variable, say~|p|,
11945 and |prev_dep(p)=dep_head|. We have |type(p)=mp_dependent|, and |dep_list(p)|
11946 points to its dependency list. If the final link of that dependency list
11947 occurs in location~|q|, then |link(q)| points to the next dependent
11948 variable (say~|r|); and we have |prev_dep(r)=q|, etc.
11950 @d dep_list(A) link(value_loc((A)))
11951 /* half of the |value| field in a |dependent| variable */
11952 @d prev_dep(A) info(value_loc((A)))
11953 /* the other half; makes a doubly linked list */
11954 @d dep_node_size 2 /* the number of words per dependency node */
11956 @<Initialize table entries...@>= mp->serial_no=0;
11957 link(dep_head)=dep_head; prev_dep(dep_head)=dep_head;
11958 info(dep_head)=null; dep_list(dep_head)=null;
11960 @ Actually the description above contains a little white lie. There's
11961 another kind of variable called |mp_proto_dependent|, which is
11962 just like a |dependent| one except that the $\alpha$ coefficients
11963 in its dependency list are |scaled| instead of being fractions.
11964 Proto-dependency lists are mixed with dependency lists in the
11965 nodes reachable from |dep_head|.
11967 @ Here is a procedure that prints a dependency list in symbolic form.
11968 The second parameter should be either |dependent| or |mp_proto_dependent|,
11969 to indicate the scaling of the coefficients.
11971 @<Declare subroutines for printing expressions@>=
11972 void mp_print_dependency (MP mp,pointer p, small_number t) {
11973 integer v; /* a coefficient */
11974 pointer pp,q; /* for list manipulation */
11977 v=abs(value(p)); q=info(p);
11978 if ( q==null ) { /* the constant term */
11979 if ( (v!=0)||(p==pp) ) {
11980 if ( value(p)>0 ) if ( p!=pp ) mp_print_char(mp, '+');
11981 mp_print_scaled(mp, value(p));
11985 @<Print the coefficient, unless it's $\pm1.0$@>;
11986 if ( type(q)!=mp_independent ) mp_confusion(mp, "dep");
11987 @:this can't happen dep}{\quad dep@>
11988 mp_print_variable_name(mp, q); v=value(q) % s_scale;
11989 while ( v>0 ) { mp_print(mp, "*4"); v=v-2; }
11994 @ @<Print the coefficient, unless it's $\pm1.0$@>=
11995 if ( value(p)<0 ) mp_print_char(mp, '-');
11996 else if ( p!=pp ) mp_print_char(mp, '+');
11997 if ( t==mp_dependent ) v=mp_round_fraction(mp, v);
11998 if ( v!=unity ) mp_print_scaled(mp, v)
12000 @ The maximum absolute value of a coefficient in a given dependency list
12001 is returned by the following simple function.
12003 @c fraction mp_max_coef (MP mp,pointer p) {
12004 fraction x; /* the maximum so far */
12006 while ( info(p)!=null ) {
12007 if ( abs(value(p))>x ) x=abs(value(p));
12013 @ One of the main operations needed on dependency lists is to add a multiple
12014 of one list to the other; we call this |p_plus_fq|, where |p| and~|q| point
12015 to dependency lists and |f| is a fraction.
12017 If the coefficient of any independent variable becomes |coef_bound| or
12018 more, in absolute value, this procedure changes the type of that variable
12019 to `|independent_needing_fix|', and sets the global variable |fix_needed|
12020 to~|true|. The value of $|coef_bound|=\mu$ is chosen so that
12021 $\mu^2+\mu<8$; this means that the numbers we deal with won't
12022 get too large. (Instead of the ``optimum'' $\mu=(\sqrt{33}-1)/2\approx
12023 2.3723$, the safer value 7/3 is taken as the threshold.)
12025 The changes mentioned in the preceding paragraph are actually done only if
12026 the global variable |watch_coefs| is |true|. But it usually is; in fact,
12027 it is |false| only when \MP\ is making a dependency list that will soon
12028 be equated to zero.
12030 Several procedures that act on dependency lists, including |p_plus_fq|,
12031 set the global variable |dep_final| to the final (constant term) node of
12032 the dependency list that they produce.
12034 @d coef_bound 04525252525 /* |fraction| approximation to 7/3 */
12035 @d independent_needing_fix 0
12038 boolean fix_needed; /* does at least one |independent| variable need scaling? */
12039 boolean watch_coefs; /* should we scale coefficients that exceed |coef_bound|? */
12040 pointer dep_final; /* location of the constant term and final link */
12043 mp->fix_needed=false; mp->watch_coefs=true;
12045 @ The |p_plus_fq| procedure has a fourth parameter, |t|, that should be
12046 set to |mp_proto_dependent| if |p| is a proto-dependency list. In this
12047 case |f| will be |scaled|, not a |fraction|. Similarly, the fifth parameter~|tt|
12048 should be |mp_proto_dependent| if |q| is a proto-dependency list.
12050 List |q| is unchanged by the operation; but list |p| is totally destroyed.
12052 The final link of the dependency list or proto-dependency list returned
12053 by |p_plus_fq| is the same as the original final link of~|p|. Indeed, the
12054 constant term of the result will be located in the same |mem| location
12055 as the original constant term of~|p|.
12057 Coefficients of the result are assumed to be zero if they are less than
12058 a certain threshold. This compensates for inevitable rounding errors,
12059 and tends to make more variables `|known|'. The threshold is approximately
12060 $10^{-5}$ in the case of normal dependency lists, $10^{-4}$ for
12061 proto-dependencies.
12063 @d fraction_threshold 2685 /* a |fraction| coefficient less than this is zeroed */
12064 @d half_fraction_threshold 1342 /* half of |fraction_threshold| */
12065 @d scaled_threshold 8 /* a |scaled| coefficient less than this is zeroed */
12066 @d half_scaled_threshold 4 /* half of |scaled_threshold| */
12068 @<Declare basic dependency-list subroutines@>=
12069 pointer mp_p_plus_fq ( MP mp, pointer p, integer f,
12070 pointer q, small_number t, small_number tt) ;
12073 pointer mp_p_plus_fq ( MP mp, pointer p, integer f,
12074 pointer q, small_number t, small_number tt) {
12075 pointer pp,qq; /* |info(p)| and |info(q)|, respectively */
12076 pointer r,s; /* for list manipulation */
12077 integer threshold; /* defines a neighborhood of zero */
12078 integer v; /* temporary register */
12079 if ( t==mp_dependent ) threshold=fraction_threshold;
12080 else threshold=scaled_threshold;
12081 r=temp_head; pp=info(p); qq=info(q);
12087 @<Contribute a term from |p|, plus |f| times the
12088 corresponding term from |q|@>
12090 } else if ( value(pp)<value(qq) ) {
12091 @<Contribute a term from |q|, multiplied by~|f|@>
12093 link(r)=p; r=p; p=link(p); pp=info(p);
12096 if ( t==mp_dependent )
12097 value(p)=mp_slow_add(mp, value(p),mp_take_fraction(mp, value(q),f));
12099 value(p)=mp_slow_add(mp, value(p),mp_take_scaled(mp, value(q),f));
12100 link(r)=p; mp->dep_final=p;
12101 return link(temp_head);
12104 @ @<Contribute a term from |p|, plus |f|...@>=
12106 if ( tt==mp_dependent ) v=value(p)+mp_take_fraction(mp, f,value(q));
12107 else v=value(p)+mp_take_scaled(mp, f,value(q));
12108 value(p)=v; s=p; p=link(p);
12109 if ( abs(v)<threshold ) {
12110 mp_free_node(mp, s,dep_node_size);
12112 if ( (abs(v)>=coef_bound) && mp->watch_coefs ) {
12113 type(qq)=independent_needing_fix; mp->fix_needed=true;
12117 pp=info(p); q=link(q); qq=info(q);
12120 @ @<Contribute a term from |q|, multiplied by~|f|@>=
12122 if ( tt==mp_dependent ) v=mp_take_fraction(mp, f,value(q));
12123 else v=mp_take_scaled(mp, f,value(q));
12124 if ( abs(v)>halfp(threshold) ) {
12125 s=mp_get_node(mp, dep_node_size); info(s)=qq; value(s)=v;
12126 if ( (abs(v)>=coef_bound) && mp->watch_coefs ) {
12127 type(qq)=independent_needing_fix; mp->fix_needed=true;
12131 q=link(q); qq=info(q);
12134 @ It is convenient to have another subroutine for the special case
12135 of |p_plus_fq| when |f=1.0|. In this routine lists |p| and |q| are
12136 both of the same type~|t| (either |dependent| or |mp_proto_dependent|).
12138 @c pointer mp_p_plus_q (MP mp,pointer p, pointer q, small_number t) {
12139 pointer pp,qq; /* |info(p)| and |info(q)|, respectively */
12140 pointer r,s; /* for list manipulation */
12141 integer threshold; /* defines a neighborhood of zero */
12142 integer v; /* temporary register */
12143 if ( t==mp_dependent ) threshold=fraction_threshold;
12144 else threshold=scaled_threshold;
12145 r=temp_head; pp=info(p); qq=info(q);
12151 @<Contribute a term from |p|, plus the
12152 corresponding term from |q|@>
12155 if ( value(pp)<value(qq) ) {
12156 s=mp_get_node(mp, dep_node_size); info(s)=qq; value(s)=value(q);
12157 q=link(q); qq=info(q); link(r)=s; r=s;
12159 link(r)=p; r=p; p=link(p); pp=info(p);
12163 value(p)=mp_slow_add(mp, value(p),value(q));
12164 link(r)=p; mp->dep_final=p;
12165 return link(temp_head);
12168 @ @<Contribute a term from |p|, plus the...@>=
12170 v=value(p)+value(q);
12171 value(p)=v; s=p; p=link(p); pp=info(p);
12172 if ( abs(v)<threshold ) {
12173 mp_free_node(mp, s,dep_node_size);
12175 if ( (abs(v)>=coef_bound ) && mp->watch_coefs ) {
12176 type(qq)=independent_needing_fix; mp->fix_needed=true;
12180 q=link(q); qq=info(q);
12183 @ A somewhat simpler routine will multiply a dependency list
12184 by a given constant~|v|. The constant is either a |fraction| less than
12185 |fraction_one|, or it is |scaled|. In the latter case we might be forced to
12186 convert a dependency list to a proto-dependency list.
12187 Parameters |t0| and |t1| are the list types before and after;
12188 they should agree unless |t0=mp_dependent| and |t1=mp_proto_dependent|
12189 and |v_is_scaled=true|.
12191 @c pointer mp_p_times_v (MP mp,pointer p, integer v, small_number t0,
12192 small_number t1, boolean v_is_scaled) {
12193 pointer r,s; /* for list manipulation */
12194 integer w; /* tentative coefficient */
12196 boolean scaling_down;
12197 if ( t0!=t1 ) scaling_down=true; else scaling_down=(!v_is_scaled);
12198 if ( t1==mp_dependent ) threshold=half_fraction_threshold;
12199 else threshold=half_scaled_threshold;
12201 while ( info(p)!=null ) {
12202 if ( scaling_down ) w=mp_take_fraction(mp, v,value(p));
12203 else w=mp_take_scaled(mp, v,value(p));
12204 if ( abs(w)<=threshold ) {
12205 s=link(p); mp_free_node(mp, p,dep_node_size); p=s;
12207 if ( abs(w)>=coef_bound ) {
12208 mp->fix_needed=true; type(info(p))=independent_needing_fix;
12210 link(r)=p; r=p; value(p)=w; p=link(p);
12214 if ( v_is_scaled ) value(p)=mp_take_scaled(mp, value(p),v);
12215 else value(p)=mp_take_fraction(mp, value(p),v);
12216 return link(temp_head);
12219 @ Similarly, we sometimes need to divide a dependency list
12220 by a given |scaled| constant.
12222 @<Declare basic dependency-list subroutines@>=
12223 pointer mp_p_over_v (MP mp,pointer p, scaled v, small_number
12224 t0, small_number t1) ;
12227 pointer mp_p_over_v (MP mp,pointer p, scaled v, small_number
12228 t0, small_number t1) {
12229 pointer r,s; /* for list manipulation */
12230 integer w; /* tentative coefficient */
12232 boolean scaling_down;
12233 if ( t0!=t1 ) scaling_down=true; else scaling_down=false;
12234 if ( t1==mp_dependent ) threshold=half_fraction_threshold;
12235 else threshold=half_scaled_threshold;
12237 while ( info( p)!=null ) {
12238 if ( scaling_down ) {
12239 if ( abs(v)<02000000 ) w=mp_make_scaled(mp, value(p),v*010000);
12240 else w=mp_make_scaled(mp, mp_round_fraction(mp, value(p)),v);
12242 w=mp_make_scaled(mp, value(p),v);
12244 if ( abs(w)<=threshold ) {
12245 s=link(p); mp_free_node(mp, p,dep_node_size); p=s;
12247 if ( abs(w)>=coef_bound ) {
12248 mp->fix_needed=true; type(info(p))=independent_needing_fix;
12250 link(r)=p; r=p; value(p)=w; p=link(p);
12253 link(r)=p; value(p)=mp_make_scaled(mp, value(p),v);
12254 return link(temp_head);
12257 @ Here's another utility routine for dependency lists. When an independent
12258 variable becomes dependent, we want to remove it from all existing
12259 dependencies. The |p_with_x_becoming_q| function computes the
12260 dependency list of~|p| after variable~|x| has been replaced by~|q|.
12262 This procedure has basically the same calling conventions as |p_plus_fq|:
12263 List~|q| is unchanged; list~|p| is destroyed; the constant node and the
12264 final link are inherited from~|p|; and the fourth parameter tells whether
12265 or not |p| is |mp_proto_dependent|. However, the global variable |dep_final|
12266 is not altered if |x| does not occur in list~|p|.
12268 @c pointer mp_p_with_x_becoming_q (MP mp,pointer p,
12269 pointer x, pointer q, small_number t) {
12270 pointer r,s; /* for list manipulation */
12271 integer v; /* coefficient of |x| */
12272 integer sx; /* serial number of |x| */
12273 s=p; r=temp_head; sx=value(x);
12274 while ( value(info(s))>sx ) { r=s; s=link(s); };
12275 if ( info(s)!=x ) {
12278 link(temp_head)=p; link(r)=link(s); v=value(s);
12279 mp_free_node(mp, s,dep_node_size);
12280 return mp_p_plus_fq(mp, link(temp_head),v,q,t,mp_dependent);
12284 @ Here's a simple procedure that reports an error when a variable
12285 has just received a known value that's out of the required range.
12287 @<Declare basic dependency-list subroutines@>=
12288 void mp_val_too_big (MP mp,scaled x) ;
12290 @ @c void mp_val_too_big (MP mp,scaled x) {
12291 if ( mp->internal[mp_warning_check]>0 ) {
12292 print_err("Value is too large ("); mp_print_scaled(mp, x); mp_print_char(mp, ')');
12293 @.Value is too large@>
12294 help4("The equation I just processed has given some variable")
12295 ("a value of 4096 or more. Continue and I'll try to cope")
12296 ("with that big value; but it might be dangerous.")
12297 ("(Set warningcheck:=0 to suppress this message.)");
12302 @ When a dependent variable becomes known, the following routine
12303 removes its dependency list. Here |p| points to the variable, and
12304 |q| points to the dependency list (which is one node long).
12306 @<Declare basic dependency-list subroutines@>=
12307 void mp_make_known (MP mp,pointer p, pointer q) ;
12309 @ @c void mp_make_known (MP mp,pointer p, pointer q) {
12310 int t; /* the previous type */
12311 prev_dep(link(q))=prev_dep(p);
12312 link(prev_dep(p))=link(q); t=type(p);
12313 type(p)=mp_known; value(p)=value(q); mp_free_node(mp, q,dep_node_size);
12314 if ( abs(value(p))>=fraction_one ) mp_val_too_big(mp, value(p));
12315 if (( mp->internal[mp_tracing_equations]>0) && mp_interesting(mp, p) ) {
12316 mp_begin_diagnostic(mp); mp_print_nl(mp, "#### ");
12317 @:]]]\#\#\#\#_}{\.{\#\#\#\#}@>
12318 mp_print_variable_name(mp, p);
12319 mp_print_char(mp, '='); mp_print_scaled(mp, value(p));
12320 mp_end_diagnostic(mp, false);
12322 if (( mp->cur_exp==p ) && mp->cur_type==t ) {
12323 mp->cur_type=mp_known; mp->cur_exp=value(p);
12324 mp_free_node(mp, p,value_node_size);
12328 @ The |fix_dependencies| routine is called into action when |fix_needed|
12329 has been triggered. The program keeps a list~|s| of independent variables
12330 whose coefficients must be divided by~4.
12332 In unusual cases, this fixup process might reduce one or more coefficients
12333 to zero, so that a variable will become known more or less by default.
12335 @<Declare basic dependency-list subroutines@>=
12336 void mp_fix_dependencies (MP mp);
12338 @ @c void mp_fix_dependencies (MP mp) {
12339 pointer p,q,r,s,t; /* list manipulation registers */
12340 pointer x; /* an independent variable */
12341 r=link(dep_head); s=null;
12342 while ( r!=dep_head ){
12344 @<Run through the dependency list for variable |t|, fixing
12345 all nodes, and ending with final link~|q|@>;
12347 if ( q==dep_list(t) ) mp_make_known(mp, t,q);
12349 while ( s!=null ) {
12350 p=link(s); x=info(s); free_avail(s); s=p;
12351 type(x)=mp_independent; value(x)=value(x)+2;
12353 mp->fix_needed=false;
12356 @ @d independent_being_fixed 1 /* this variable already appears in |s| */
12358 @<Run through the dependency list for variable |t|...@>=
12359 r=value_loc(t); /* |link(r)=dep_list(t)| */
12361 q=link(r); x=info(q);
12362 if ( x==null ) break;
12363 if ( type(x)<=independent_being_fixed ) {
12364 if ( type(x)<independent_being_fixed ) {
12365 p=mp_get_avail(mp); link(p)=s; s=p;
12366 info(s)=x; type(x)=independent_being_fixed;
12368 value(q)=value(q) / 4;
12369 if ( value(q)==0 ) {
12370 link(r)=link(q); mp_free_node(mp, q,dep_node_size); q=r;
12377 @ The |new_dep| routine installs a dependency list~|p| into the value node~|q|,
12378 linking it into the list of all known dependencies. We assume that
12379 |dep_final| points to the final node of list~|p|.
12381 @c void mp_new_dep (MP mp,pointer q, pointer p) {
12382 pointer r; /* what used to be the first dependency */
12383 dep_list(q)=p; prev_dep(q)=dep_head;
12384 r=link(dep_head); link(mp->dep_final)=r; prev_dep(r)=mp->dep_final;
12388 @ Here is one of the ways a dependency list gets started.
12389 The |const_dependency| routine produces a list that has nothing but
12392 @c pointer mp_const_dependency (MP mp, scaled v) {
12393 mp->dep_final=mp_get_node(mp, dep_node_size);
12394 value(mp->dep_final)=v; info(mp->dep_final)=null;
12395 return mp->dep_final;
12398 @ And here's a more interesting way to start a dependency list from scratch:
12399 The parameter to |single_dependency| is the location of an
12400 independent variable~|x|, and the result is the simple dependency list
12403 In the unlikely event that the given independent variable has been doubled so
12404 often that we can't refer to it with a nonzero coefficient,
12405 |single_dependency| returns the simple list `0'. This case can be
12406 recognized by testing that the returned list pointer is equal to
12409 @c pointer mp_single_dependency (MP mp,pointer p) {
12410 pointer q; /* the new dependency list */
12411 integer m; /* the number of doublings */
12412 m=value(p) % s_scale;
12414 return mp_const_dependency(mp, 0);
12416 q=mp_get_node(mp, dep_node_size);
12417 value(q)=two_to_the(28-m); info(q)=p;
12418 link(q)=mp_const_dependency(mp, 0);
12423 @ We sometimes need to make an exact copy of a dependency list.
12425 @c pointer mp_copy_dep_list (MP mp,pointer p) {
12426 pointer q; /* the new dependency list */
12427 q=mp_get_node(mp, dep_node_size); mp->dep_final=q;
12429 info(mp->dep_final)=info(p); value(mp->dep_final)=value(p);
12430 if ( info(mp->dep_final)==null ) break;
12431 link(mp->dep_final)=mp_get_node(mp, dep_node_size);
12432 mp->dep_final=link(mp->dep_final); p=link(p);
12437 @ But how do variables normally become known? Ah, now we get to the heart of the
12438 equation-solving mechanism. The |linear_eq| procedure is given a |dependent|
12439 or |mp_proto_dependent| list,~|p|, in which at least one independent variable
12440 appears. It equates this list to zero, by choosing an independent variable
12441 with the largest coefficient and making it dependent on the others. The
12442 newly dependent variable is eliminated from all current dependencies,
12443 thereby possibly making other dependent variables known.
12445 The given list |p| is, of course, totally destroyed by all this processing.
12447 @c void mp_linear_eq (MP mp, pointer p, small_number t) {
12448 pointer q,r,s; /* for link manipulation */
12449 pointer x; /* the variable that loses its independence */
12450 integer n; /* the number of times |x| had been halved */
12451 integer v; /* the coefficient of |x| in list |p| */
12452 pointer prev_r; /* lags one step behind |r| */
12453 pointer final_node; /* the constant term of the new dependency list */
12454 integer w; /* a tentative coefficient */
12455 @<Find a node |q| in list |p| whose coefficient |v| is largest@>;
12456 x=info(q); n=value(x) % s_scale;
12457 @<Divide list |p| by |-v|, removing node |q|@>;
12458 if ( mp->internal[mp_tracing_equations]>0 ) {
12459 @<Display the new dependency@>;
12461 @<Simplify all existing dependencies by substituting for |x|@>;
12462 @<Change variable |x| from |independent| to |dependent| or |known|@>;
12463 if ( mp->fix_needed ) mp_fix_dependencies(mp);
12466 @ @<Find a node |q| in list |p| whose coefficient |v| is largest@>=
12467 q=p; r=link(p); v=value(q);
12468 while ( info(r)!=null ) {
12469 if ( abs(value(r))>abs(v) ) { q=r; v=value(r); };
12473 @ Here we want to change the coefficients from |scaled| to |fraction|,
12474 except in the constant term. In the common case of a trivial equation
12475 like `\.{x=3.14}', we will have |v=-fraction_one|, |q=p|, and |t=mp_dependent|.
12477 @<Divide list |p| by |-v|, removing node |q|@>=
12478 s=temp_head; link(s)=p; r=p;
12481 link(s)=link(r); mp_free_node(mp, r,dep_node_size);
12483 w=mp_make_fraction(mp, value(r),v);
12484 if ( abs(w)<=half_fraction_threshold ) {
12485 link(s)=link(r); mp_free_node(mp, r,dep_node_size);
12491 } while (info(r)!=null);
12492 if ( t==mp_proto_dependent ) {
12493 value(r)=-mp_make_scaled(mp, value(r),v);
12494 } else if ( v!=-fraction_one ) {
12495 value(r)=-mp_make_fraction(mp, value(r),v);
12497 final_node=r; p=link(temp_head)
12499 @ @<Display the new dependency@>=
12500 if ( mp_interesting(mp, x) ) {
12501 mp_begin_diagnostic(mp); mp_print_nl(mp, "## ");
12502 mp_print_variable_name(mp, x);
12503 @:]]]\#\#_}{\.{\#\#}@>
12505 while ( w>0 ) { mp_print(mp, "*4"); w=w-2; };
12506 mp_print_char(mp, '='); mp_print_dependency(mp, p,mp_dependent);
12507 mp_end_diagnostic(mp, false);
12510 @ @<Simplify all existing dependencies by substituting for |x|@>=
12511 prev_r=dep_head; r=link(dep_head);
12512 while ( r!=dep_head ) {
12513 s=dep_list(r); q=mp_p_with_x_becoming_q(mp, s,x,p,type(r));
12514 if ( info(q)==null ) {
12515 mp_make_known(mp, r,q);
12518 do { q=link(q); } while (info(q)!=null);
12524 @ @<Change variable |x| from |independent| to |dependent| or |known|@>=
12525 if ( n>0 ) @<Divide list |p| by $2^n$@>;
12526 if ( info(p)==null ) {
12529 if ( abs(value(x))>=fraction_one ) mp_val_too_big(mp, value(x));
12530 mp_free_node(mp, p,dep_node_size);
12531 if ( mp->cur_exp==x ) if ( mp->cur_type==mp_independent ) {
12532 mp->cur_exp=value(x); mp->cur_type=mp_known;
12533 mp_free_node(mp, x,value_node_size);
12536 type(x)=mp_dependent; mp->dep_final=final_node; mp_new_dep(mp, x,p);
12537 if ( mp->cur_exp==x ) if ( mp->cur_type==mp_independent ) mp->cur_type=mp_dependent;
12540 @ @<Divide list |p| by $2^n$@>=
12542 s=temp_head; link(temp_head)=p; r=p;
12545 else w=value(r) / two_to_the(n);
12546 if ( (abs(w)<=half_fraction_threshold)&&(info(r)!=null) ) {
12548 mp_free_node(mp, r,dep_node_size);
12553 } while (info(s)!=null);
12557 @ The |check_mem| procedure, which is used only when \MP\ is being
12558 debugged, makes sure that the current dependency lists are well formed.
12560 @<Check the list of linear dependencies@>=
12561 q=dep_head; p=link(q);
12562 while ( p!=dep_head ) {
12563 if ( prev_dep(p)!=q ) {
12564 mp_print_nl(mp, "Bad PREVDEP at "); mp_print_int(mp, p);
12569 r=info(p); q=p; p=link(q);
12570 if ( r==null ) break;
12571 if ( value(info(p))>=value(r) ) {
12572 mp_print_nl(mp, "Out of order at "); mp_print_int(mp, p);
12573 @.Out of order...@>
12578 @* \[25] Dynamic nonlinear equations.
12579 Variables of numeric type are maintained by the general scheme of
12580 independent, dependent, and known values that we have just studied;
12581 and the components of pair and transform variables are handled in the
12582 same way. But \MP\ also has five other types of values: \&{boolean},
12583 \&{string}, \&{pen}, \&{path}, and \&{picture}; what about them?
12585 Equations are allowed between nonlinear quantities, but only in a
12586 simple form. Two variables that haven't yet been assigned values are
12587 either equal to each other, or they're not.
12589 Before a boolean variable has received a value, its type is |mp_unknown_boolean|;
12590 similarly, there are variables whose type is |mp_unknown_string|, |mp_unknown_pen|,
12591 |mp_unknown_path|, and |mp_unknown_picture|. In such cases the value is either
12592 |null| (which means that no other variables are equivalent to this one), or
12593 it points to another variable of the same undefined type. The pointers in the
12594 latter case form a cycle of nodes, which we shall call a ``ring.''
12595 Rings of undefined variables may include capsules, which arise as
12596 intermediate results within expressions or as \&{expr} parameters to macros.
12598 When one member of a ring receives a value, the same value is given to
12599 all the other members. In the case of paths and pictures, this implies
12600 making separate copies of a potentially large data structure; users should
12601 restrain their enthusiasm for such generality, unless they have lots and
12602 lots of memory space.
12604 @ The following procedure is called when a capsule node is being
12605 added to a ring (e.g., when an unknown variable is mentioned in an expression).
12607 @c pointer mp_new_ring_entry (MP mp,pointer p) {
12608 pointer q; /* the new capsule node */
12609 q=mp_get_node(mp, value_node_size); name_type(q)=mp_capsule;
12611 if ( value(p)==null ) value(q)=p; else value(q)=value(p);
12616 @ Conversely, we might delete a capsule or a variable before it becomes known.
12617 The following procedure simply detaches a quantity from its ring,
12618 without recycling the storage.
12620 @<Declare the recycling subroutines@>=
12621 void mp_ring_delete (MP mp,pointer p) {
12624 if ( q!=null ) if ( q!=p ){
12625 while ( value(q)!=p ) q=value(q);
12630 @ Eventually there might be an equation that assigns values to all of the
12631 variables in a ring. The |nonlinear_eq| subroutine does the necessary
12632 propagation of values.
12634 If the parameter |flush_p| is |true|, node |p| itself needn't receive a
12635 value, it will soon be recycled.
12637 @c void mp_nonlinear_eq (MP mp,integer v, pointer p, boolean flush_p) {
12638 small_number t; /* the type of ring |p| */
12639 pointer q,r; /* link manipulation registers */
12640 t=type(p)-unknown_tag; q=value(p);
12641 if ( flush_p ) type(p)=mp_vacuous; else p=q;
12643 r=value(q); type(q)=t;
12645 case mp_boolean_type: value(q)=v; break;
12646 case mp_string_type: value(q)=v; add_str_ref(v); break;
12647 case mp_pen_type: value(q)=copy_pen(v); break;
12648 case mp_path_type: value(q)=mp_copy_path(mp, v); break;
12649 case mp_picture_type: value(q)=v; add_edge_ref(v); break;
12650 } /* there ain't no more cases */
12655 @ If two members of rings are equated, and if they have the same type,
12656 the |ring_merge| procedure is called on to make them equivalent.
12658 @c void mp_ring_merge (MP mp,pointer p, pointer q) {
12659 pointer r; /* traverses one list */
12663 @<Exclaim about a redundant equation@>;
12668 r=value(p); value(p)=value(q); value(q)=r;
12671 @ @<Exclaim about a redundant equation@>=
12673 print_err("Redundant equation");
12674 @.Redundant equation@>
12675 help2("I already knew that this equation was true.")
12676 ("But perhaps no harm has been done; let's continue.");
12677 mp_put_get_error(mp);
12680 @* \[26] Introduction to the syntactic routines.
12681 Let's pause a moment now and try to look at the Big Picture.
12682 The \MP\ program consists of three main parts: syntactic routines,
12683 semantic routines, and output routines. The chief purpose of the
12684 syntactic routines is to deliver the user's input to the semantic routines,
12685 while parsing expressions and locating operators and operands. The
12686 semantic routines act as an interpreter responding to these operators,
12687 which may be regarded as commands. And the output routines are
12688 periodically called on to produce compact font descriptions that can be
12689 used for typesetting or for making interim proof drawings. We have
12690 discussed the basic data structures and many of the details of semantic
12691 operations, so we are good and ready to plunge into the part of \MP\ that
12692 actually controls the activities.
12694 Our current goal is to come to grips with the |get_next| procedure,
12695 which is the keystone of \MP's input mechanism. Each call of |get_next|
12696 sets the value of three variables |cur_cmd|, |cur_mod|, and |cur_sym|,
12697 representing the next input token.
12698 $$\vbox{\halign{#\hfil\cr
12699 \hbox{|cur_cmd| denotes a command code from the long list of codes
12701 \hbox{|cur_mod| denotes a modifier of the command code;}\cr
12702 \hbox{|cur_sym| is the hash address of the symbolic token that was
12704 \hbox{\qquad or zero in the case of a numeric or string
12705 or capsule token.}\cr}}$$
12706 Underlying this external behavior of |get_next| is all the machinery
12707 necessary to convert from character files to tokens. At a given time we
12708 may be only partially finished with the reading of several files (for
12709 which \&{input} was specified), and partially finished with the expansion
12710 of some user-defined macros and/or some macro parameters, and partially
12711 finished reading some text that the user has inserted online,
12712 and so on. When reading a character file, the characters must be
12713 converted to tokens; comments and blank spaces must
12714 be removed, numeric and string tokens must be evaluated.
12716 To handle these situations, which might all be present simultaneously,
12717 \MP\ uses various stacks that hold information about the incomplete
12718 activities, and there is a finite state control for each level of the
12719 input mechanism. These stacks record the current state of an implicitly
12720 recursive process, but the |get_next| procedure is not recursive.
12723 eight_bits cur_cmd; /* current command set by |get_next| */
12724 integer cur_mod; /* operand of current command */
12725 halfword cur_sym; /* hash address of current symbol */
12727 @ The |print_cmd_mod| routine prints a symbolic interpretation of a
12728 command code and its modifier.
12729 It consists of a rather tedious sequence of print
12730 commands, and most of it is essentially an inverse to the |primitive|
12731 routine that enters a \MP\ primitive into |hash| and |eqtb|. Therefore almost
12732 all of this procedure appears elsewhere in the program, together with the
12733 corresponding |primitive| calls.
12735 @<Declare the procedure called |print_cmd_mod|@>=
12736 void mp_print_cmd_mod (MP mp,integer c, integer m) {
12738 @<Cases of |print_cmd_mod| for symbolic printing of primitives@>
12739 default: mp_print(mp, "[unknown command code!]"); break;
12743 @ Here is a procedure that displays a given command in braces, in the
12744 user's transcript file.
12746 @d show_cur_cmd_mod mp_show_cmd_mod(mp, mp->cur_cmd,mp->cur_mod)
12749 void mp_show_cmd_mod (MP mp,integer c, integer m) {
12750 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
12751 mp_print_cmd_mod(mp, c,m); mp_print_char(mp, '}');
12752 mp_end_diagnostic(mp, false);
12755 @* \[27] Input stacks and states.
12756 The state of \MP's input mechanism appears in the input stack, whose
12757 entries are records with five fields, called |index|, |start|, |loc|,
12758 |limit|, and |name|. The top element of this stack is maintained in a
12759 global variable for which no subscripting needs to be done; the other
12760 elements of the stack appear in an array. Hence the stack is declared thus:
12764 quarterword index_field;
12765 halfword start_field, loc_field, limit_field, name_field;
12769 in_state_record *input_stack;
12770 integer input_ptr; /* first unused location of |input_stack| */
12771 integer max_in_stack; /* largest value of |input_ptr| when pushing */
12772 in_state_record cur_input; /* the ``top'' input state */
12773 int stack_size; /* maximum number of simultaneous input sources */
12775 @ @<Allocate or initialize ...@>=
12776 mp->stack_size = 300;
12777 mp->input_stack = xmalloc((mp->stack_size+1),sizeof(in_state_record));
12779 @ @<Dealloc variables@>=
12780 xfree(mp->input_stack);
12782 @ We've already defined the special variable |loc==cur_input.loc_field|
12783 in our discussion of basic input-output routines. The other components of
12784 |cur_input| are defined in the same way:
12786 @d iindex mp->cur_input.index_field /* reference for buffer information */
12787 @d start mp->cur_input.start_field /* starting position in |buffer| */
12788 @d limit mp->cur_input.limit_field /* end of current line in |buffer| */
12789 @d name mp->cur_input.name_field /* name of the current file */
12791 @ Let's look more closely now at the five control variables
12792 (|index|,~|start|,~|loc|,~|limit|,~|name|),
12793 assuming that \MP\ is reading a line of characters that have been input
12794 from some file or from the user's terminal. There is an array called
12795 |buffer| that acts as a stack of all lines of characters that are
12796 currently being read from files, including all lines on subsidiary
12797 levels of the input stack that are not yet completed. \MP\ will return to
12798 the other lines when it is finished with the present input file.
12800 (Incidentally, on a machine with byte-oriented addressing, it would be
12801 appropriate to combine |buffer| with the |str_pool| array,
12802 letting the buffer entries grow downward from the top of the string pool
12803 and checking that these two tables don't bump into each other.)
12805 The line we are currently working on begins in position |start| of the
12806 buffer; the next character we are about to read is |buffer[loc]|; and
12807 |limit| is the location of the last character present. We always have
12808 |loc<=limit|. For convenience, |buffer[limit]| has been set to |"%"|, so
12809 that the end of a line is easily sensed.
12811 The |name| variable is a string number that designates the name of
12812 the current file, if we are reading an ordinary text file. Special codes
12813 |is_term..max_spec_src| indicate other sources of input text.
12815 @d is_term 0 /* |name| value when reading from the terminal for normal input */
12816 @d is_read 1 /* |name| value when executing a \&{readstring} or \&{readfrom} */
12817 @d is_scantok 2 /* |name| value when reading text generated by \&{scantokens} */
12818 @d max_spec_src is_scantok
12820 @ Additional information about the current line is available via the
12821 |index| variable, which counts how many lines of characters are present
12822 in the buffer below the current level. We have |index=0| when reading
12823 from the terminal and prompting the user for each line; then if the user types,
12824 e.g., `\.{input figs}', we will have |index=1| while reading
12825 the file \.{figs.mp}. However, it does not follow that |index| is the
12826 same as the input stack pointer, since many of the levels on the input
12827 stack may come from token lists and some |index| values may correspond
12828 to \.{MPX} files that are not currently on the stack.
12830 The global variable |in_open| is equal to the highest |index| value counting
12831 \.{MPX} files but excluding token-list input levels. Thus, the number of
12832 partially read lines in the buffer is |in_open+1| and we have |in_open>=index|
12833 when we are not reading a token list.
12835 If we are not currently reading from the terminal,
12836 we are reading from the file variable |input_file[index]|. We use
12837 the notation |terminal_input| as a convenient abbreviation for |name=is_term|,
12838 and |cur_file| as an abbreviation for |input_file[index]|.
12840 When \MP\ is not reading from the terminal, the global variable |line| contains
12841 the line number in the current file, for use in error messages. More precisely,
12842 |line| is a macro for |line_stack[index]| and the |line_stack| array gives
12843 the line number for each file in the |input_file| array.
12845 When an \.{MPX} file is opened the file name is stored in the |mpx_name|
12846 array so that the name doesn't get lost when the file is temporarily removed
12847 from the input stack.
12848 Thus when |input_file[k]| is an \.{MPX} file, its name is |mpx_name[k]|
12849 and it contains translated \TeX\ pictures for |input_file[k-1]|.
12850 Since this is not an \.{MPX} file, we have
12851 $$ \hbox{|mpx_name[k-1]<=absent|}. $$
12852 This |name| field is set to |finished| when |input_file[k]| is completely
12855 If more information about the input state is needed, it can be
12856 included in small arrays like those shown here. For example,
12857 the current page or segment number in the input file might be put
12858 into a variable |page|, that is really a macro for the current entry
12859 in `\ignorespaces|page_stack:array[0..max_in_open] of integer|\unskip'
12860 by analogy with |line_stack|.
12861 @^system dependencies@>
12863 @d terminal_input (name==is_term) /* are we reading from the terminal? */
12864 @d cur_file mp->input_file[iindex] /* the current |void *| variable */
12865 @d line mp->line_stack[iindex] /* current line number in the current source file */
12866 @d in_name mp->iname_stack[iindex] /* a string used to construct \.{MPX} file names */
12867 @d in_area mp->iarea_stack[iindex] /* another string for naming \.{MPX} files */
12868 @d absent 1 /* |name_field| value for unused |mpx_in_stack| entries */
12869 @d mpx_reading (mp->mpx_name[iindex]>absent)
12870 /* when reading a file, is it an \.{MPX} file? */
12872 /* |name_field| value when the corresponding \.{MPX} file is finished */
12875 integer in_open; /* the number of lines in the buffer, less one */
12876 unsigned int open_parens; /* the number of open text files */
12877 void * *input_file ;
12878 integer *line_stack ; /* the line number for each file */
12879 char * *iname_stack; /* used for naming \.{MPX} files */
12880 char * *iarea_stack; /* used for naming \.{MPX} files */
12881 halfword*mpx_name ;
12883 @ @<Allocate or ...@>=
12884 mp->input_file = xmalloc((mp->max_in_open+1),sizeof(void *));
12885 mp->line_stack = xmalloc((mp->max_in_open+1),sizeof(integer));
12886 mp->iname_stack = xmalloc((mp->max_in_open+1),sizeof(char *));
12887 mp->iarea_stack = xmalloc((mp->max_in_open+1),sizeof(char *));
12888 mp->mpx_name = xmalloc((mp->max_in_open+1),sizeof(halfword));
12891 for (k=0;k<=mp->max_in_open;k++) {
12892 mp->iname_stack[k] =NULL;
12893 mp->iarea_stack[k] =NULL;
12897 @ @<Dealloc variables@>=
12900 for (l=0;l<=mp->max_in_open;l++) {
12901 xfree(mp->iname_stack[l]);
12902 xfree(mp->iarea_stack[l]);
12905 xfree(mp->input_file);
12906 xfree(mp->line_stack);
12907 xfree(mp->iname_stack);
12908 xfree(mp->iarea_stack);
12909 xfree(mp->mpx_name);
12912 @ However, all this discussion about input state really applies only to the
12913 case that we are inputting from a file. There is another important case,
12914 namely when we are currently getting input from a token list. In this case
12915 |iindex>max_in_open|, and the conventions about the other state variables
12918 \yskip\hang|loc| is a pointer to the current node in the token list, i.e.,
12919 the node that will be read next. If |loc=null|, the token list has been
12922 \yskip\hang|start| points to the first node of the token list; this node
12923 may or may not contain a reference count, depending on the type of token
12926 \yskip\hang|token_type|, which takes the place of |iindex| in the
12927 discussion above, is a code number that explains what kind of token list
12930 \yskip\hang|name| points to the |eqtb| address of the control sequence
12931 being expanded, if the current token list is a macro not defined by
12932 \&{vardef}. Macros defined by \&{vardef} have |name=null|; their name
12933 can be deduced by looking at their first two parameters.
12935 \yskip\hang|param_start|, which takes the place of |limit|, tells where
12936 the parameters of the current macro or loop text begin in the |param_stack|.
12938 \yskip\noindent The |token_type| can take several values, depending on
12939 where the current token list came from:
12942 \indent|forever_text|, if the token list being scanned is the body of
12943 a \&{forever} loop;
12945 \indent|loop_text|, if the token list being scanned is the body of
12946 a \&{for} or \&{forsuffixes} loop;
12948 \indent|parameter|, if a \&{text} or \&{suffix} parameter is being scanned;
12950 \indent|backed_up|, if the token list being scanned has been inserted as
12951 `to be read again'.
12953 \indent|inserted|, if the token list being scanned has been inserted as
12954 part of error recovery;
12956 \indent|macro|, if the expansion of a user-defined symbolic token is being
12960 The token list begins with a reference count if and only if |token_type=
12962 @^reference counts@>
12964 @d token_type iindex /* type of current token list */
12965 @d token_state (iindex>(int)mp->max_in_open) /* are we scanning a token list? */
12966 @d file_state (iindex<=(int)mp->max_in_open) /* are we scanning a file line? */
12967 @d param_start limit /* base of macro parameters in |param_stack| */
12968 @d forever_text (mp->max_in_open+1) /* |token_type| code for loop texts */
12969 @d loop_text (mp->max_in_open+2) /* |token_type| code for loop texts */
12970 @d parameter (mp->max_in_open+3) /* |token_type| code for parameter texts */
12971 @d backed_up (mp->max_in_open+4) /* |token_type| code for texts to be reread */
12972 @d inserted (mp->max_in_open+5) /* |token_type| code for inserted texts */
12973 @d macro (mp->max_in_open+6) /* |token_type| code for macro replacement texts */
12975 @ The |param_stack| is an auxiliary array used to hold pointers to the token
12976 lists for parameters at the current level and subsidiary levels of input.
12977 This stack grows at a different rate from the others.
12980 pointer *param_stack; /* token list pointers for parameters */
12981 integer param_ptr; /* first unused entry in |param_stack| */
12982 integer max_param_stack; /* largest value of |param_ptr| */
12984 @ @<Allocate or initialize ...@>=
12985 mp->param_stack = xmalloc((mp->param_size+1),sizeof(pointer));
12987 @ @<Dealloc variables@>=
12988 xfree(mp->param_stack);
12990 @ Notice that the |line| isn't valid when |token_state| is true because it
12991 depends on |iindex|. If we really need to know the line number for the
12992 topmost file in the iindex stack we use the following function. If a page
12993 number or other information is needed, this routine should be modified to
12994 compute it as well.
12995 @^system dependencies@>
12997 @<Declare a function called |true_line|@>=
12998 integer mp_true_line (MP mp) {
12999 int k; /* an index into the input stack */
13000 if ( file_state && (name>max_spec_src) ) {
13005 ((mp->input_stack[(k-1)].index_field>mp->max_in_open)||
13006 (mp->input_stack[(k-1)].name_field<=max_spec_src))) {
13009 return (k>0 ? mp->line_stack[(k-1)] : 0 );
13013 @ Thus, the ``current input state'' can be very complicated indeed; there
13014 can be many levels and each level can arise in a variety of ways. The
13015 |show_context| procedure, which is used by \MP's error-reporting routine to
13016 print out the current input state on all levels down to the most recent
13017 line of characters from an input file, illustrates most of these conventions.
13018 The global variable |file_ptr| contains the lowest level that was
13019 displayed by this procedure.
13022 integer file_ptr; /* shallowest level shown by |show_context| */
13024 @ The status at each level is indicated by printing two lines, where the first
13025 line indicates what was read so far and the second line shows what remains
13026 to be read. The context is cropped, if necessary, so that the first line
13027 contains at most |half_error_line| characters, and the second contains
13028 at most |error_line|. Non-current input levels whose |token_type| is
13029 `|backed_up|' are shown only if they have not been fully read.
13031 @c void mp_show_context (MP mp) { /* prints where the scanner is */
13032 int old_setting; /* saved |selector| setting */
13033 @<Local variables for formatting calculations@>
13034 mp->file_ptr=mp->input_ptr; mp->input_stack[mp->file_ptr]=mp->cur_input;
13035 /* store current state */
13037 mp->cur_input=mp->input_stack[mp->file_ptr]; /* enter into the context */
13038 @<Display the current context@>;
13040 if ( (name>max_spec_src) || (mp->file_ptr==0) ) break;
13041 decr(mp->file_ptr);
13043 mp->cur_input=mp->input_stack[mp->input_ptr]; /* restore original state */
13046 @ @<Display the current context@>=
13047 if ( (mp->file_ptr==mp->input_ptr) || file_state ||
13048 (token_type!=backed_up) || (loc!=null) ) {
13049 /* we omit backed-up token lists that have already been read */
13050 mp->tally=0; /* get ready to count characters */
13051 old_setting=mp->selector;
13052 if ( file_state ) {
13053 @<Print location of current line@>;
13054 @<Pseudoprint the line@>;
13056 @<Print type of token list@>;
13057 @<Pseudoprint the token list@>;
13059 mp->selector=old_setting; /* stop pseudoprinting */
13060 @<Print two lines using the tricky pseudoprinted information@>;
13063 @ This routine should be changed, if necessary, to give the best possible
13064 indication of where the current line resides in the input file.
13065 For example, on some systems it is best to print both a page and line number.
13066 @^system dependencies@>
13068 @<Print location of current line@>=
13069 if ( name>max_spec_src ) {
13070 mp_print_nl(mp, "l."); mp_print_int(mp, mp_true_line(mp));
13071 } else if ( terminal_input ) {
13072 if ( mp->file_ptr==0 ) mp_print_nl(mp, "<*>");
13073 else mp_print_nl(mp, "<insert>");
13074 } else if ( name==is_scantok ) {
13075 mp_print_nl(mp, "<scantokens>");
13077 mp_print_nl(mp, "<read>");
13079 mp_print_char(mp, ' ')
13081 @ Can't use case statement here because the |token_type| is not
13082 a constant expression.
13084 @<Print type of token list@>=
13086 if(token_type==forever_text) {
13087 mp_print_nl(mp, "<forever> ");
13088 } else if (token_type==loop_text) {
13089 @<Print the current loop value@>;
13090 } else if (token_type==parameter) {
13091 mp_print_nl(mp, "<argument> ");
13092 } else if (token_type==backed_up) {
13093 if ( loc==null ) mp_print_nl(mp, "<recently read> ");
13094 else mp_print_nl(mp, "<to be read again> ");
13095 } else if (token_type==inserted) {
13096 mp_print_nl(mp, "<inserted text> ");
13097 } else if (token_type==macro) {
13099 if ( name!=null ) mp_print_text(name);
13100 else @<Print the name of a \&{vardef}'d macro@>;
13101 mp_print(mp, "->");
13103 mp_print_nl(mp, "?");/* this should never happen */
13108 @ The parameter that corresponds to a loop text is either a token list
13109 (in the case of \&{forsuffixes}) or a ``capsule'' (in the case of \&{for}).
13110 We'll discuss capsules later; for now, all we need to know is that
13111 the |link| field in a capsule parameter is |void| and that
13112 |print_exp(p,0)| displays the value of capsule~|p| in abbreviated form.
13114 @<Print the current loop value@>=
13115 { mp_print_nl(mp, "<for("); p=mp->param_stack[param_start];
13117 if ( link(p)==mp_void ) mp_print_exp(mp, p,0); /* we're in a \&{for} loop */
13118 else mp_show_token_list(mp, p,null,20,mp->tally);
13120 mp_print(mp, ")> ");
13123 @ The first two parameters of a macro defined by \&{vardef} will be token
13124 lists representing the macro's prefix and ``at point.'' By putting these
13125 together, we get the macro's full name.
13127 @<Print the name of a \&{vardef}'d macro@>=
13128 { p=mp->param_stack[param_start];
13130 mp_show_token_list(mp, mp->param_stack[param_start+1],null,20,mp->tally);
13133 while ( link(q)!=null ) q=link(q);
13134 link(q)=mp->param_stack[param_start+1];
13135 mp_show_token_list(mp, p,null,20,mp->tally);
13140 @ Now it is necessary to explain a little trick. We don't want to store a long
13141 string that corresponds to a token list, because that string might take up
13142 lots of memory; and we are printing during a time when an error message is
13143 being given, so we dare not do anything that might overflow one of \MP's
13144 tables. So `pseudoprinting' is the answer: We enter a mode of printing
13145 that stores characters into a buffer of length |error_line|, where character
13146 $k+1$ is placed into \hbox{|trick_buf[k mod error_line]|} if
13147 |k<trick_count|, otherwise character |k| is dropped. Initially we set
13148 |tally:=0| and |trick_count:=1000000|; then when we reach the
13149 point where transition from line 1 to line 2 should occur, we
13150 set |first_count:=tally| and |trick_count:=@tmax@>(error_line,
13151 tally+1+error_line-half_error_line)|. At the end of the
13152 pseudoprinting, the values of |first_count|, |tally|, and
13153 |trick_count| give us all the information we need to print the two lines,
13154 and all of the necessary text is in |trick_buf|.
13156 Namely, let |l| be the length of the descriptive information that appears
13157 on the first line. The length of the context information gathered for that
13158 line is |k=first_count|, and the length of the context information
13159 gathered for line~2 is $m=\min(|tally|, |trick_count|)-k$. If |l+k<=h|,
13160 where |h=half_error_line|, we print |trick_buf[0..k-1]| after the
13161 descriptive information on line~1, and set |n:=l+k|; here |n| is the
13162 length of line~1. If $l+k>h$, some cropping is necessary, so we set |n:=h|
13163 and print `\.{...}' followed by
13164 $$\hbox{|trick_buf[(l+k-h+3)..k-1]|,}$$
13165 where subscripts of |trick_buf| are circular modulo |error_line|. The
13166 second line consists of |n|~spaces followed by |trick_buf[k..(k+m-1)]|,
13167 unless |n+m>error_line|; in the latter case, further cropping is done.
13168 This is easier to program than to explain.
13170 @<Local variables for formatting...@>=
13171 int i; /* index into |buffer| */
13172 integer l; /* length of descriptive information on line 1 */
13173 integer m; /* context information gathered for line 2 */
13174 int n; /* length of line 1 */
13175 integer p; /* starting or ending place in |trick_buf| */
13176 integer q; /* temporary index */
13178 @ The following code tells the print routines to gather
13179 the desired information.
13181 @d begin_pseudoprint {
13182 l=mp->tally; mp->tally=0; mp->selector=pseudo;
13183 mp->trick_count=1000000;
13185 @d set_trick_count {
13186 mp->first_count=mp->tally;
13187 mp->trick_count=mp->tally+1+mp->error_line-mp->half_error_line;
13188 if ( mp->trick_count<mp->error_line ) mp->trick_count=mp->error_line;
13191 @ And the following code uses the information after it has been gathered.
13193 @<Print two lines using the tricky pseudoprinted information@>=
13194 if ( mp->trick_count==1000000 ) set_trick_count;
13195 /* |set_trick_count| must be performed */
13196 if ( mp->tally<mp->trick_count ) m=mp->tally-mp->first_count;
13197 else m=mp->trick_count-mp->first_count; /* context on line 2 */
13198 if ( l+mp->first_count<=mp->half_error_line ) {
13199 p=0; n=l+mp->first_count;
13201 mp_print(mp, "..."); p=l+mp->first_count-mp->half_error_line+3;
13202 n=mp->half_error_line;
13204 for (q=p;q<=mp->first_count-1;q++) {
13205 mp_print_char(mp, mp->trick_buf[q % mp->error_line]);
13208 for (q=1;q<=n;q++) {
13209 mp_print_char(mp, ' '); /* print |n| spaces to begin line~2 */
13211 if ( m+n<=mp->error_line ) p=mp->first_count+m;
13212 else p=mp->first_count+(mp->error_line-n-3);
13213 for (q=mp->first_count;q<=p-1;q++) {
13214 mp_print_char(mp, mp->trick_buf[q % mp->error_line]);
13216 if ( m+n>mp->error_line ) mp_print(mp, "...")
13218 @ But the trick is distracting us from our current goal, which is to
13219 understand the input state. So let's concentrate on the data structures that
13220 are being pseudoprinted as we finish up the |show_context| procedure.
13222 @<Pseudoprint the line@>=
13225 for (i=start;i<=limit-1;i++) {
13226 if ( i==loc ) set_trick_count;
13227 mp_print_str(mp, mp->buffer[i]);
13231 @ @<Pseudoprint the token list@>=
13233 if ( token_type!=macro ) mp_show_token_list(mp, start,loc,100000,0);
13234 else mp_show_macro(mp, start,loc,100000)
13236 @ Here is the missing piece of |show_token_list| that is activated when the
13237 token beginning line~2 is about to be shown:
13239 @<Do magic computation@>=set_trick_count
13241 @* \[28] Maintaining the input stacks.
13242 The following subroutines change the input status in commonly needed ways.
13244 First comes |push_input|, which stores the current state and creates a
13245 new level (having, initially, the same properties as the old).
13247 @d push_input { /* enter a new input level, save the old */
13248 if ( mp->input_ptr>mp->max_in_stack ) {
13249 mp->max_in_stack=mp->input_ptr;
13250 if ( mp->input_ptr==mp->stack_size ) {
13251 int l = (mp->stack_size+(mp->stack_size>>2));
13252 XREALLOC(mp->input_stack, l, in_state_record);
13253 mp->stack_size = l;
13256 mp->input_stack[mp->input_ptr]=mp->cur_input; /* stack the record */
13257 incr(mp->input_ptr);
13260 @ And of course what goes up must come down.
13262 @d pop_input { /* leave an input level, re-enter the old */
13263 decr(mp->input_ptr); mp->cur_input=mp->input_stack[mp->input_ptr];
13266 @ Here is a procedure that starts a new level of token-list input, given
13267 a token list |p| and its type |t|. If |t=macro|, the calling routine should
13268 set |name|, reset~|loc|, and increase the macro's reference count.
13270 @d back_list(A) mp_begin_token_list(mp, (A),backed_up) /* backs up a simple token list */
13272 @c void mp_begin_token_list (MP mp,pointer p, quarterword t) {
13273 push_input; start=p; token_type=t;
13274 param_start=mp->param_ptr; loc=p;
13277 @ When a token list has been fully scanned, the following computations
13278 should be done as we leave that level of input.
13281 @c void mp_end_token_list (MP mp) { /* leave a token-list input level */
13282 pointer p; /* temporary register */
13283 if ( token_type>=backed_up ) { /* token list to be deleted */
13284 if ( token_type<=inserted ) {
13285 mp_flush_token_list(mp, start); goto DONE;
13287 mp_delete_mac_ref(mp, start); /* update reference count */
13290 while ( mp->param_ptr>param_start ) { /* parameters must be flushed */
13291 decr(mp->param_ptr);
13292 p=mp->param_stack[mp->param_ptr];
13294 if ( link(p)==mp_void ) { /* it's an \&{expr} parameter */
13295 mp_recycle_value(mp, p); mp_free_node(mp, p,value_node_size);
13297 mp_flush_token_list(mp, p); /* it's a \&{suffix} or \&{text} parameter */
13302 pop_input; check_interrupt;
13305 @ The contents of |cur_cmd,cur_mod,cur_sym| are placed into an equivalent
13306 token by the |cur_tok| routine.
13309 @c @<Declare the procedure called |make_exp_copy|@>
13310 pointer mp_cur_tok (MP mp) {
13311 pointer p; /* a new token node */
13312 small_number save_type; /* |cur_type| to be restored */
13313 integer save_exp; /* |cur_exp| to be restored */
13314 if ( mp->cur_sym==0 ) {
13315 if ( mp->cur_cmd==capsule_token ) {
13316 save_type=mp->cur_type; save_exp=mp->cur_exp;
13317 mp_make_exp_copy(mp, mp->cur_mod); p=mp_stash_cur_exp(mp); link(p)=null;
13318 mp->cur_type=save_type; mp->cur_exp=save_exp;
13320 p=mp_get_node(mp, token_node_size);
13321 value(p)=mp->cur_mod; name_type(p)=mp_token;
13322 if ( mp->cur_cmd==numeric_token ) type(p)=mp_known;
13323 else type(p)=mp_string_type;
13326 fast_get_avail(p); info(p)=mp->cur_sym;
13331 @ Sometimes \MP\ has read too far and wants to ``unscan'' what it has
13332 seen. The |back_input| procedure takes care of this by putting the token
13333 just scanned back into the input stream, ready to be read again.
13334 If |cur_sym<>0|, the values of |cur_cmd| and |cur_mod| are irrelevant.
13337 void mp_back_input (MP mp);
13339 @ @c void mp_back_input (MP mp) {/* undoes one token of input */
13340 pointer p; /* a token list of length one */
13342 while ( token_state &&(loc==null) )
13343 mp_end_token_list(mp); /* conserve stack space */
13347 @ The |back_error| routine is used when we want to restore or replace an
13348 offending token just before issuing an error message. We disable interrupts
13349 during the call of |back_input| so that the help message won't be lost.
13352 void mp_error (MP mp);
13353 void mp_back_error (MP mp);
13355 @ @c void mp_back_error (MP mp) { /* back up one token and call |error| */
13356 mp->OK_to_interrupt=false;
13358 mp->OK_to_interrupt=true; mp_error(mp);
13360 void mp_ins_error (MP mp) { /* back up one inserted token and call |error| */
13361 mp->OK_to_interrupt=false;
13362 mp_back_input(mp); token_type=inserted;
13363 mp->OK_to_interrupt=true; mp_error(mp);
13366 @ The |begin_file_reading| procedure starts a new level of input for lines
13367 of characters to be read from a file, or as an insertion from the
13368 terminal. It does not take care of opening the file, nor does it set |loc|
13369 or |limit| or |line|.
13370 @^system dependencies@>
13372 @c void mp_begin_file_reading (MP mp) {
13373 if ( mp->in_open==mp->max_in_open )
13374 mp_overflow(mp, "text input levels",mp->max_in_open);
13375 @:MetaPost capacity exceeded text input levels}{\quad text input levels@>
13376 if ( mp->first==mp->buf_size )
13377 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
13378 incr(mp->in_open); push_input; iindex=mp->in_open;
13379 mp->mpx_name[iindex]=absent;
13381 name=is_term; /* |terminal_input| is now |true| */
13384 @ Conversely, the variables must be downdated when such a level of input
13385 is finished. Any associated \.{MPX} file must also be closed and popped
13386 off the file stack.
13388 @c void mp_end_file_reading (MP mp) {
13389 if ( mp->in_open>iindex ) {
13390 if ( (mp->mpx_name[mp->in_open]==absent)||(name<=max_spec_src) ) {
13391 mp_confusion(mp, "endinput");
13392 @:this can't happen endinput}{\quad endinput@>
13394 (mp->close_file)(mp,mp->input_file[mp->in_open]); /* close an \.{MPX} file */
13395 delete_str_ref(mp->mpx_name[mp->in_open]);
13400 if ( iindex!=mp->in_open ) mp_confusion(mp, "endinput");
13401 if ( name>max_spec_src ) {
13402 (mp->close_file)(mp,cur_file);
13403 delete_str_ref(name);
13407 pop_input; decr(mp->in_open);
13410 @ Here is a function that tries to resume input from an \.{MPX} file already
13411 associated with the current input file. It returns |false| if this doesn't
13414 @c boolean mp_begin_mpx_reading (MP mp) {
13415 if ( mp->in_open!=iindex+1 ) {
13418 if ( mp->mpx_name[mp->in_open]<=absent ) mp_confusion(mp, "mpx");
13419 @:this can't happen mpx}{\quad mpx@>
13420 if ( mp->first==mp->buf_size )
13421 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
13422 push_input; iindex=mp->in_open;
13424 name=mp->mpx_name[mp->in_open]; add_str_ref(name);
13425 @<Put an empty line in the input buffer@>;
13430 @ This procedure temporarily stops reading an \.{MPX} file.
13432 @c void mp_end_mpx_reading (MP mp) {
13433 if ( mp->in_open!=iindex ) mp_confusion(mp, "mpx");
13434 @:this can't happen mpx}{\quad mpx@>
13436 @<Complain that we are not at the end of a line in the \.{MPX} file@>;
13442 @ Here we enforce a restriction that simplifies the input stacks considerably.
13443 This should not inconvenience the user because \.{MPX} files are generated
13444 by an auxiliary program called \.{DVItoMP}.
13446 @ @<Complain that we are not at the end of a line in the \.{MPX} file@>=
13448 print_err("`mpxbreak' must be at the end of a line");
13449 help4("This file contains picture expressions for btex...etex")
13450 ("blocks. Such files are normally generated automatically")
13451 ("but this one seems to be messed up. I'm going to ignore")
13452 ("the rest of this line.");
13456 @ In order to keep the stack from overflowing during a long sequence of
13457 inserted `\.{show}' commands, the following routine removes completed
13458 error-inserted lines from memory.
13460 @c void mp_clear_for_error_prompt (MP mp) {
13461 while ( file_state && terminal_input &&
13462 (mp->input_ptr>0)&&(loc==limit) ) mp_end_file_reading(mp);
13463 mp_print_ln(mp); clear_terminal;
13466 @ To get \MP's whole input mechanism going, we perform the following
13469 @<Initialize the input routines@>=
13470 { mp->input_ptr=0; mp->max_in_stack=0;
13471 mp->in_open=0; mp->open_parens=0; mp->max_buf_stack=0;
13472 mp->param_ptr=0; mp->max_param_stack=0;
13474 start=1; iindex=0; line=0; name=is_term;
13475 mp->mpx_name[0]=absent;
13476 mp->force_eof=false;
13477 if ( ! mp_init_terminal(mp) ) mp_jump_out(mp);
13478 limit=mp->last; mp->first=mp->last+1;
13479 /* |init_terminal| has set |loc| and |last| */
13482 @* \[29] Getting the next token.
13483 The heart of \MP's input mechanism is the |get_next| procedure, which
13484 we shall develop in the next few sections of the program. Perhaps we
13485 shouldn't actually call it the ``heart,'' however; it really acts as \MP's
13486 eyes and mouth, reading the source files and gobbling them up. And it also
13487 helps \MP\ to regurgitate stored token lists that are to be processed again.
13489 The main duty of |get_next| is to input one token and to set |cur_cmd|
13490 and |cur_mod| to that token's command code and modifier. Furthermore, if
13491 the input token is a symbolic token, that token's |hash| address
13492 is stored in |cur_sym|; otherwise |cur_sym| is set to zero.
13494 Underlying this simple description is a certain amount of complexity
13495 because of all the cases that need to be handled.
13496 However, the inner loop of |get_next| is reasonably short and fast.
13498 @ Before getting into |get_next|, we need to consider a mechanism by which
13499 \MP\ helps keep errors from propagating too far. Whenever the program goes
13500 into a mode where it keeps calling |get_next| repeatedly until a certain
13501 condition is met, it sets |scanner_status| to some value other than |normal|.
13502 Then if an input file ends, or if an `\&{outer}' symbol appears,
13503 an appropriate error recovery will be possible.
13505 The global variable |warning_info| helps in this error recovery by providing
13506 additional information. For example, |warning_info| might indicate the
13507 name of a macro whose replacement text is being scanned.
13509 @d normal 0 /* |scanner_status| at ``quiet times'' */
13510 @d skipping 1 /* |scanner_status| when false conditional text is being skipped */
13511 @d flushing 2 /* |scanner_status| when junk after a statement is being ignored */
13512 @d absorbing 3 /* |scanner_status| when a \&{text} parameter is being scanned */
13513 @d var_defining 4 /* |scanner_status| when a \&{vardef} is being scanned */
13514 @d op_defining 5 /* |scanner_status| when a macro \&{def} is being scanned */
13515 @d loop_defining 6 /* |scanner_status| when a \&{for} loop is being scanned */
13516 @d tex_flushing 7 /* |scanner_status| when skipping \TeX\ material */
13519 integer scanner_status; /* are we scanning at high speed? */
13520 integer warning_info; /* if so, what else do we need to know,
13521 in case an error occurs? */
13523 @ @<Initialize the input routines@>=
13524 mp->scanner_status=normal;
13526 @ The following subroutine
13527 is called when an `\&{outer}' symbolic token has been scanned or
13528 when the end of a file has been reached. These two cases are distinguished
13529 by |cur_sym|, which is zero at the end of a file.
13531 @c boolean mp_check_outer_validity (MP mp) {
13532 pointer p; /* points to inserted token list */
13533 if ( mp->scanner_status==normal ) {
13535 } else if ( mp->scanner_status==tex_flushing ) {
13536 @<Check if the file has ended while flushing \TeX\ material and set the
13537 result value for |check_outer_validity|@>;
13539 mp->deletions_allowed=false;
13540 @<Back up an outer symbolic token so that it can be reread@>;
13541 if ( mp->scanner_status>skipping ) {
13542 @<Tell the user what has run away and try to recover@>;
13544 print_err("Incomplete if; all text was ignored after line ");
13545 @.Incomplete if...@>
13546 mp_print_int(mp, mp->warning_info);
13547 help3("A forbidden `outer' token occurred in skipped text.")
13548 ("This kind of error happens when you say `if...' and forget")
13549 ("the matching `fi'. I've inserted a `fi'; this might work.");
13550 if ( mp->cur_sym==0 )
13551 mp->help_line[2]="The file ended while I was skipping conditional text.";
13552 mp->cur_sym=frozen_fi; mp_ins_error(mp);
13554 mp->deletions_allowed=true;
13559 @ @<Check if the file has ended while flushing \TeX\ material and set...@>=
13560 if ( mp->cur_sym!=0 ) {
13563 mp->deletions_allowed=false;
13564 print_err("TeX mode didn't end; all text was ignored after line ");
13565 mp_print_int(mp, mp->warning_info);
13566 help2("The file ended while I was looking for the `etex' to")
13567 ("finish this TeX material. I've inserted `etex' now.");
13568 mp->cur_sym = frozen_etex;
13570 mp->deletions_allowed=true;
13574 @ @<Back up an outer symbolic token so that it can be reread@>=
13575 if ( mp->cur_sym!=0 ) {
13576 p=mp_get_avail(mp); info(p)=mp->cur_sym;
13577 back_list(p); /* prepare to read the symbolic token again */
13580 @ @<Tell the user what has run away...@>=
13582 mp_runaway(mp); /* print the definition-so-far */
13583 if ( mp->cur_sym==0 ) {
13584 print_err("File ended");
13585 @.File ended while scanning...@>
13587 print_err("Forbidden token found");
13588 @.Forbidden token found...@>
13590 mp_print(mp, " while scanning ");
13591 help4("I suspect you have forgotten an `enddef',")
13592 ("causing me to read past where you wanted me to stop.")
13593 ("I'll try to recover; but if the error is serious,")
13594 ("you'd better type `E' or `X' now and fix your file.");
13595 switch (mp->scanner_status) {
13596 @<Complete the error message,
13597 and set |cur_sym| to a token that might help recover from the error@>
13598 } /* there are no other cases */
13602 @ As we consider various kinds of errors, it is also appropriate to
13603 change the first line of the help message just given; |help_line[3]|
13604 points to the string that might be changed.
13606 @<Complete the error message,...@>=
13608 mp_print(mp, "to the end of the statement");
13609 mp->help_line[3]="A previous error seems to have propagated,";
13610 mp->cur_sym=frozen_semicolon;
13613 mp_print(mp, "a text argument");
13614 mp->help_line[3]="It seems that a right delimiter was left out,";
13615 if ( mp->warning_info==0 ) {
13616 mp->cur_sym=frozen_end_group;
13618 mp->cur_sym=frozen_right_delimiter;
13619 equiv(frozen_right_delimiter)=mp->warning_info;
13624 mp_print(mp, "the definition of ");
13625 if ( mp->scanner_status==op_defining )
13626 mp_print_text(mp->warning_info);
13628 mp_print_variable_name(mp, mp->warning_info);
13629 mp->cur_sym=frozen_end_def;
13631 case loop_defining:
13632 mp_print(mp, "the text of a ");
13633 mp_print_text(mp->warning_info);
13634 mp_print(mp, " loop");
13635 mp->help_line[3]="I suspect you have forgotten an `endfor',";
13636 mp->cur_sym=frozen_end_for;
13639 @ The |runaway| procedure displays the first part of the text that occurred
13640 when \MP\ began its special |scanner_status|, if that text has been saved.
13642 @<Declare the procedure called |runaway|@>=
13643 void mp_runaway (MP mp) {
13644 if ( mp->scanner_status>flushing ) {
13645 mp_print_nl(mp, "Runaway ");
13646 switch (mp->scanner_status) {
13647 case absorbing: mp_print(mp, "text?"); break;
13649 case op_defining: mp_print(mp,"definition?"); break;
13650 case loop_defining: mp_print(mp, "loop?"); break;
13651 } /* there are no other cases */
13653 mp_show_token_list(mp, link(hold_head),null,mp->error_line-10,0);
13657 @ We need to mention a procedure that may be called by |get_next|.
13660 void mp_firm_up_the_line (MP mp);
13662 @ And now we're ready to take the plunge into |get_next| itself.
13663 Note that the behavior depends on the |scanner_status| because percent signs
13664 and double quotes need to be passed over when skipping TeX material.
13667 void mp_get_next (MP mp) {
13668 /* sets |cur_cmd|, |cur_mod|, |cur_sym| to next token */
13670 /*restart*/ /* go here to get the next input token */
13671 /*exit*/ /* go here when the next input token has been got */
13672 /*|common_ending|*/ /* go here to finish getting a symbolic token */
13673 /*found*/ /* go here when the end of a symbolic token has been found */
13674 /*switch*/ /* go here to branch on the class of an input character */
13675 /*|start_numeric_token|,|start_decimal_token|,|fin_numeric_token|,|done|*/
13676 /* go here at crucial stages when scanning a number */
13677 int k; /* an index into |buffer| */
13678 ASCII_code c; /* the current character in the buffer */
13679 ASCII_code class; /* its class number */
13680 integer n,f; /* registers for decimal-to-binary conversion */
13683 if ( file_state ) {
13684 @<Input from external file; |goto restart| if no input found,
13685 or |return| if a non-symbolic token is found@>;
13687 @<Input from token list; |goto restart| if end of list or
13688 if a parameter needs to be expanded,
13689 or |return| if a non-symbolic token is found@>;
13692 @<Finish getting the symbolic token in |cur_sym|;
13693 |goto restart| if it is illegal@>;
13696 @ When a symbolic token is declared to be `\&{outer}', its command code
13697 is increased by |outer_tag|.
13700 @<Finish getting the symbolic token in |cur_sym|...@>=
13701 mp->cur_cmd=eq_type(mp->cur_sym); mp->cur_mod=equiv(mp->cur_sym);
13702 if ( mp->cur_cmd>=outer_tag ) {
13703 if ( mp_check_outer_validity(mp) )
13704 mp->cur_cmd=mp->cur_cmd-outer_tag;
13709 @ A percent sign appears in |buffer[limit]|; this makes it unnecessary
13710 to have a special test for end-of-line.
13713 @<Input from external file;...@>=
13716 c=mp->buffer[loc]; incr(loc); class=mp->char_class[c];
13718 case digit_class: goto START_NUMERIC_TOKEN; break;
13720 class=mp->char_class[mp->buffer[loc]];
13721 if ( class>period_class ) {
13723 } else if ( class<period_class ) { /* |class=digit_class| */
13724 n=0; goto START_DECIMAL_TOKEN;
13728 case space_class: goto SWITCH; break;
13729 case percent_class:
13730 if ( mp->scanner_status==tex_flushing ) {
13731 if ( loc<limit ) goto SWITCH;
13733 @<Move to next line of file, or |goto restart| if there is no next line@>;
13738 if ( mp->scanner_status==tex_flushing ) goto SWITCH;
13739 else @<Get a string token and |return|@>;
13741 case isolated_classes:
13742 k=loc-1; goto FOUND; break;
13743 case invalid_class:
13744 if ( mp->scanner_status==tex_flushing ) goto SWITCH;
13745 else @<Decry the invalid character and |goto restart|@>;
13747 default: break; /* letters, etc. */
13750 while ( mp->char_class[mp->buffer[loc]]==class ) incr(loc);
13752 START_NUMERIC_TOKEN:
13753 @<Get the integer part |n| of a numeric token;
13754 set |f:=0| and |goto fin_numeric_token| if there is no decimal point@>;
13755 START_DECIMAL_TOKEN:
13756 @<Get the fraction part |f| of a numeric token@>;
13758 @<Pack the numeric and fraction parts of a numeric token
13761 mp->cur_sym=mp_id_lookup(mp, k,loc-k);
13764 @ We go to |restart| instead of to |SWITCH|, because we might enter
13765 |token_state| after the error has been dealt with
13766 (cf.\ |clear_for_error_prompt|).
13768 @<Decry the invalid...@>=
13770 print_err("Text line contains an invalid character");
13771 @.Text line contains...@>
13772 help2("A funny symbol that I can\'t read has just been input.")
13773 ("Continue, and I'll forget that it ever happened.");
13774 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
13778 @ @<Get a string token and |return|@>=
13780 if ( mp->buffer[loc]=='"' ) {
13781 mp->cur_mod=rts("");
13783 k=loc; mp->buffer[limit+1]='"';
13786 } while (mp->buffer[loc]!='"');
13788 @<Decry the missing string delimiter and |goto restart|@>;
13791 mp->cur_mod=mp->buffer[k];
13795 append_char(mp->buffer[k]); incr(k);
13797 mp->cur_mod=mp_make_string(mp);
13800 incr(loc); mp->cur_cmd=string_token;
13804 @ We go to |restart| after this error message, not to |SWITCH|,
13805 because the |clear_for_error_prompt| routine might have reinstated
13806 |token_state| after |error| has finished.
13808 @<Decry the missing string delimiter and |goto restart|@>=
13810 loc=limit; /* the next character to be read on this line will be |"%"| */
13811 print_err("Incomplete string token has been flushed");
13812 @.Incomplete string token...@>
13813 help3("Strings should finish on the same line as they began.")
13814 ("I've deleted the partial string; you might want to")
13815 ("insert another by typing, e.g., `I\"new string\"'.");
13816 mp->deletions_allowed=false; mp_error(mp);
13817 mp->deletions_allowed=true;
13821 @ @<Get the integer part |n| of a numeric token...@>=
13823 while ( mp->char_class[mp->buffer[loc]]==digit_class ) {
13824 if ( n<32768 ) n=10*n+mp->buffer[loc]-'0';
13827 if ( mp->buffer[loc]=='.' )
13828 if ( mp->char_class[mp->buffer[loc+1]]==digit_class )
13831 goto FIN_NUMERIC_TOKEN;
13834 @ @<Get the fraction part |f| of a numeric token@>=
13837 if ( k<17 ) { /* digits for |k>=17| cannot affect the result */
13838 mp->dig[k]=mp->buffer[loc]-'0'; incr(k);
13841 } while (mp->char_class[mp->buffer[loc]]==digit_class);
13842 f=mp_round_decimals(mp, k);
13847 @ @<Pack the numeric and fraction parts of a numeric token and |return|@>=
13849 @<Set |cur_mod:=n*unity+f| and check if it is uncomfortably large@>;
13850 } else if ( mp->scanner_status!=tex_flushing ) {
13851 print_err("Enormous number has been reduced");
13852 @.Enormous number...@>
13853 help2("I can\'t handle numbers bigger than 32767.99998;")
13854 ("so I've changed your constant to that maximum amount.");
13855 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
13856 mp->cur_mod=el_gordo;
13858 mp->cur_cmd=numeric_token; return
13860 @ @<Set |cur_mod:=n*unity+f| and check if it is uncomfortably large@>=
13862 mp->cur_mod=n*unity+f;
13863 if ( mp->cur_mod>=fraction_one ) {
13864 if ( (mp->internal[mp_warning_check]>0) &&
13865 (mp->scanner_status!=tex_flushing) ) {
13866 print_err("Number is too large (");
13867 mp_print_scaled(mp, mp->cur_mod);
13868 mp_print_char(mp, ')');
13869 help3("It is at least 4096. Continue and I'll try to cope")
13870 ("with that big value; but it might be dangerous.")
13871 ("(Set warningcheck:=0 to suppress this message.)");
13877 @ Let's consider now what happens when |get_next| is looking at a token list.
13880 @<Input from token list;...@>=
13881 if ( loc>=mp->hi_mem_min ) { /* one-word token */
13882 mp->cur_sym=info(loc); loc=link(loc); /* move to next */
13883 if ( mp->cur_sym>=expr_base ) {
13884 if ( mp->cur_sym>=suffix_base ) {
13885 @<Insert a suffix or text parameter and |goto restart|@>;
13887 mp->cur_cmd=capsule_token;
13888 mp->cur_mod=mp->param_stack[param_start+mp->cur_sym-(expr_base)];
13889 mp->cur_sym=0; return;
13892 } else if ( loc>null ) {
13893 @<Get a stored numeric or string or capsule token and |return|@>
13894 } else { /* we are done with this token list */
13895 mp_end_token_list(mp); goto RESTART; /* resume previous level */
13898 @ @<Insert a suffix or text parameter...@>=
13900 if ( mp->cur_sym>=text_base ) mp->cur_sym=mp->cur_sym-mp->param_size;
13901 /* |param_size=text_base-suffix_base| */
13902 mp_begin_token_list(mp,
13903 mp->param_stack[param_start+mp->cur_sym-(suffix_base)],
13908 @ @<Get a stored numeric or string or capsule token...@>=
13910 if ( name_type(loc)==mp_token ) {
13911 mp->cur_mod=value(loc);
13912 if ( type(loc)==mp_known ) {
13913 mp->cur_cmd=numeric_token;
13915 mp->cur_cmd=string_token; add_str_ref(mp->cur_mod);
13918 mp->cur_mod=loc; mp->cur_cmd=capsule_token;
13920 loc=link(loc); return;
13923 @ All of the easy branches of |get_next| have now been taken care of.
13924 There is one more branch.
13926 @<Move to next line of file, or |goto restart|...@>=
13927 if ( name>max_spec_src) {
13928 @<Read next line of file into |buffer|, or
13929 |goto restart| if the file has ended@>;
13931 if ( mp->input_ptr>0 ) {
13932 /* text was inserted during error recovery or by \&{scantokens} */
13933 mp_end_file_reading(mp); goto RESTART; /* resume previous level */
13935 if (mp->job_name == NULL && ( mp->selector<log_only || mp->selector>=write_file))
13936 mp_open_log_file(mp);
13937 if ( mp->interaction>mp_nonstop_mode ) {
13938 if ( limit==start ) /* previous line was empty */
13939 mp_print_nl(mp, "(Please type a command or say `end')");
13941 mp_print_ln(mp); mp->first=start;
13942 prompt_input("*"); /* input on-line into |buffer| */
13944 limit=mp->last; mp->buffer[limit]='%';
13945 mp->first=limit+1; loc=start;
13947 mp_fatal_error(mp, "*** (job aborted, no legal end found)");
13949 /* nonstop mode, which is intended for overnight batch processing,
13950 never waits for on-line input */
13954 @ The global variable |force_eof| is normally |false|; it is set |true|
13955 by an \&{endinput} command.
13958 boolean force_eof; /* should the next \&{input} be aborted early? */
13960 @ We must decrement |loc| in order to leave the buffer in a valid state
13961 when an error condition causes us to |goto restart| without calling
13962 |end_file_reading|.
13964 @<Read next line of file into |buffer|, or
13965 |goto restart| if the file has ended@>=
13967 incr(line); mp->first=start;
13968 if ( ! mp->force_eof ) {
13969 if ( mp_input_ln(mp, cur_file ) ) /* not end of file */
13970 mp_firm_up_the_line(mp); /* this sets |limit| */
13972 mp->force_eof=true;
13974 if ( mp->force_eof ) {
13975 mp->force_eof=false;
13977 if ( mpx_reading ) {
13978 @<Complain that the \.{MPX} file ended unexpectly; then set
13979 |cur_sym:=frozen_mpx_break| and |goto comon_ending|@>;
13981 mp_print_char(mp, ')'); decr(mp->open_parens);
13982 update_terminal; /* show user that file has been read */
13983 mp_end_file_reading(mp); /* resume previous level */
13984 if ( mp_check_outer_validity(mp) ) goto RESTART;
13988 mp->buffer[limit]='%'; mp->first=limit+1; loc=start; /* ready to read */
13991 @ We should never actually come to the end of an \.{MPX} file because such
13992 files should have an \&{mpxbreak} after the translation of the last
13993 \&{btex}$\,\ldots\,$\&{etex} block.
13995 @<Complain that the \.{MPX} file ended unexpectly; then set...@>=
13997 mp->mpx_name[iindex]=mpx_finished;
13998 print_err("mpx file ended unexpectedly");
13999 help4("The file had too few picture expressions for btex...etex")
14000 ("blocks. Such files are normally generated automatically")
14001 ("but this one got messed up. You might want to insert a")
14002 ("picture expression now.");
14003 mp->deletions_allowed=false; mp_error(mp); mp->deletions_allowed=true;
14004 mp->cur_sym=frozen_mpx_break; goto COMMON_ENDING;
14007 @ Sometimes we want to make it look as though we have just read a blank line
14008 without really doing so.
14010 @<Put an empty line in the input buffer@>=
14011 mp->last=mp->first; limit=mp->last; /* simulate |input_ln| and |firm_up_the_line| */
14012 mp->buffer[limit]='%'; mp->first=limit+1; loc=start
14014 @ If the user has set the |mp_pausing| parameter to some positive value,
14015 and if nonstop mode has not been selected, each line of input is displayed
14016 on the terminal and the transcript file, followed by `\.{=>}'.
14017 \MP\ waits for a response. If the response is null (i.e., if nothing is
14018 typed except perhaps a few blank spaces), the original
14019 line is accepted as it stands; otherwise the line typed is
14020 used instead of the line in the file.
14022 @c void mp_firm_up_the_line (MP mp) {
14023 size_t k; /* an index into |buffer| */
14025 if ((!mp->noninteractive)
14026 && (mp->internal[mp_pausing]>0 )
14027 && (mp->interaction>mp_nonstop_mode )) {
14028 wake_up_terminal; mp_print_ln(mp);
14029 if ( start<limit ) {
14030 for (k=(size_t)start;k<=(size_t)(limit-1);k++) {
14031 mp_print_str(mp, mp->buffer[k]);
14034 mp->first=limit; prompt_input("=>"); /* wait for user response */
14036 if ( mp->last>mp->first ) {
14037 for (k=mp->first;k<=mp->last-1;k++) { /* move line down in buffer */
14038 mp->buffer[k+start-mp->first]=mp->buffer[k];
14040 limit=start+mp->last-mp->first;
14045 @* \[30] Dealing with \TeX\ material.
14046 The \&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}$\,\ldots\,$\&{etex}
14047 features need to be implemented at a low level in the scanning process
14048 so that \MP\ can stay in synch with the a preprocessor that treats
14049 blocks of \TeX\ material as they occur in the input file without trying
14050 to expand \MP\ macros. Thus we need a special version of |get_next|
14051 that does not expand macros and such but does handle \&{btex},
14052 \&{verbatimtex}, etc.
14054 The special version of |get_next| is called |get_t_next|. It works by flushing
14055 \&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}\allowbreak
14056 $\,\ldots\,$\&{etex} blocks, switching to the \.{MPX} file when it sees
14057 \&{btex}, and switching back when it sees \&{mpxbreak}.
14063 mp_primitive(mp, "btex",start_tex,btex_code);
14064 @:btex_}{\&{btex} primitive@>
14065 mp_primitive(mp, "verbatimtex",start_tex,verbatim_code);
14066 @:verbatimtex_}{\&{verbatimtex} primitive@>
14067 mp_primitive(mp, "etex",etex_marker,0); mp->eqtb[frozen_etex]=mp->eqtb[mp->cur_sym];
14068 @:etex_}{\&{etex} primitive@>
14069 mp_primitive(mp, "mpxbreak",mpx_break,0); mp->eqtb[frozen_mpx_break]=mp->eqtb[mp->cur_sym];
14070 @:mpx_break_}{\&{mpxbreak} primitive@>
14072 @ @<Cases of |print_cmd...@>=
14073 case start_tex: if ( m==btex_code ) mp_print(mp, "btex");
14074 else mp_print(mp, "verbatimtex"); break;
14075 case etex_marker: mp_print(mp, "etex"); break;
14076 case mpx_break: mp_print(mp, "mpxbreak"); break;
14078 @ Actually, |get_t_next| is a macro that avoids procedure overhead except
14079 in the unusual case where \&{btex}, \&{verbatimtex}, \&{etex}, or \&{mpxbreak}
14082 @d get_t_next {mp_get_next(mp); if ( mp->cur_cmd<=max_pre_command ) mp_t_next(mp); }
14085 void mp_start_mpx_input (MP mp);
14088 void mp_t_next (MP mp) {
14089 int old_status; /* saves the |scanner_status| */
14090 integer old_info; /* saves the |warning_info| */
14091 while ( mp->cur_cmd<=max_pre_command ) {
14092 if ( mp->cur_cmd==mpx_break ) {
14093 if ( ! file_state || (mp->mpx_name[iindex]==absent) ) {
14094 @<Complain about a misplaced \&{mpxbreak}@>;
14096 mp_end_mpx_reading(mp);
14099 } else if ( mp->cur_cmd==start_tex ) {
14100 if ( token_state || (name<=max_spec_src) ) {
14101 @<Complain that we are not reading a file@>;
14102 } else if ( mpx_reading ) {
14103 @<Complain that \.{MPX} files cannot contain \TeX\ material@>;
14104 } else if ( (mp->cur_mod!=verbatim_code)&&
14105 (mp->mpx_name[iindex]!=mpx_finished) ) {
14106 if ( ! mp_begin_mpx_reading(mp) ) mp_start_mpx_input(mp);
14111 @<Complain about a misplaced \&{etex}@>;
14113 goto COMMON_ENDING;
14115 @<Flush the \TeX\ material@>;
14121 @ We could be in the middle of an operation such as skipping false conditional
14122 text when \TeX\ material is encountered, so we must be careful to save the
14125 @<Flush the \TeX\ material@>=
14126 old_status=mp->scanner_status;
14127 old_info=mp->warning_info;
14128 mp->scanner_status=tex_flushing;
14129 mp->warning_info=line;
14130 do { mp_get_next(mp); } while (mp->cur_cmd!=etex_marker);
14131 mp->scanner_status=old_status;
14132 mp->warning_info=old_info
14134 @ @<Complain that \.{MPX} files cannot contain \TeX\ material@>=
14135 { print_err("An mpx file cannot contain btex or verbatimtex blocks");
14136 help4("This file contains picture expressions for btex...etex")
14137 ("blocks. Such files are normally generated automatically")
14138 ("but this one seems to be messed up. I'll just keep going")
14139 ("and hope for the best.");
14143 @ @<Complain that we are not reading a file@>=
14144 { print_err("You can only use `btex' or `verbatimtex' in a file");
14145 help3("I'll have to ignore this preprocessor command because it")
14146 ("only works when there is a file to preprocess. You might")
14147 ("want to delete everything up to the next `etex`.");
14151 @ @<Complain about a misplaced \&{mpxbreak}@>=
14152 { print_err("Misplaced mpxbreak");
14153 help2("I'll ignore this preprocessor command because it")
14154 ("doesn't belong here");
14158 @ @<Complain about a misplaced \&{etex}@>=
14159 { print_err("Extra etex will be ignored");
14160 help1("There is no btex or verbatimtex for this to match");
14164 @* \[31] Scanning macro definitions.
14165 \MP\ has a variety of ways to tuck tokens away into token lists for later
14166 use: Macros can be defined with \&{def}, \&{vardef}, \&{primarydef}, etc.;
14167 repeatable code can be defined with \&{for}, \&{forever}, \&{forsuffixes}.
14168 All such operations are handled by the routines in this part of the program.
14170 The modifier part of each command code is zero for the ``ending delimiters''
14171 like \&{enddef} and \&{endfor}.
14173 @d start_def 1 /* command modifier for \&{def} */
14174 @d var_def 2 /* command modifier for \&{vardef} */
14175 @d end_def 0 /* command modifier for \&{enddef} */
14176 @d start_forever 1 /* command modifier for \&{forever} */
14177 @d end_for 0 /* command modifier for \&{endfor} */
14180 mp_primitive(mp, "def",macro_def,start_def);
14181 @:def_}{\&{def} primitive@>
14182 mp_primitive(mp, "vardef",macro_def,var_def);
14183 @:var_def_}{\&{vardef} primitive@>
14184 mp_primitive(mp, "primarydef",macro_def,secondary_primary_macro);
14185 @:primary_def_}{\&{primarydef} primitive@>
14186 mp_primitive(mp, "secondarydef",macro_def,tertiary_secondary_macro);
14187 @:secondary_def_}{\&{secondarydef} primitive@>
14188 mp_primitive(mp, "tertiarydef",macro_def,expression_tertiary_macro);
14189 @:tertiary_def_}{\&{tertiarydef} primitive@>
14190 mp_primitive(mp, "enddef",macro_def,end_def); mp->eqtb[frozen_end_def]=mp->eqtb[mp->cur_sym];
14191 @:end_def_}{\&{enddef} primitive@>
14193 mp_primitive(mp, "for",iteration,expr_base);
14194 @:for_}{\&{for} primitive@>
14195 mp_primitive(mp, "forsuffixes",iteration,suffix_base);
14196 @:for_suffixes_}{\&{forsuffixes} primitive@>
14197 mp_primitive(mp, "forever",iteration,start_forever);
14198 @:forever_}{\&{forever} primitive@>
14199 mp_primitive(mp, "endfor",iteration,end_for); mp->eqtb[frozen_end_for]=mp->eqtb[mp->cur_sym];
14200 @:end_for_}{\&{endfor} primitive@>
14202 @ @<Cases of |print_cmd...@>=
14204 if ( m<=var_def ) {
14205 if ( m==start_def ) mp_print(mp, "def");
14206 else if ( m<start_def ) mp_print(mp, "enddef");
14207 else mp_print(mp, "vardef");
14208 } else if ( m==secondary_primary_macro ) {
14209 mp_print(mp, "primarydef");
14210 } else if ( m==tertiary_secondary_macro ) {
14211 mp_print(mp, "secondarydef");
14213 mp_print(mp, "tertiarydef");
14217 if ( m<=start_forever ) {
14218 if ( m==start_forever ) mp_print(mp, "forever");
14219 else mp_print(mp, "endfor");
14220 } else if ( m==expr_base ) {
14221 mp_print(mp, "for");
14223 mp_print(mp, "forsuffixes");
14227 @ Different macro-absorbing operations have different syntaxes, but they
14228 also have a lot in common. There is a list of special symbols that are to
14229 be replaced by parameter tokens; there is a special command code that
14230 ends the definition; the quotation conventions are identical. Therefore
14231 it makes sense to have most of the work done by a single subroutine. That
14232 subroutine is called |scan_toks|.
14234 The first parameter to |scan_toks| is the command code that will
14235 terminate scanning (either |macro_def| or |iteration|).
14237 The second parameter, |subst_list|, points to a (possibly empty) list
14238 of two-word nodes whose |info| and |value| fields specify symbol tokens
14239 before and after replacement. The list will be returned to free storage
14242 The third parameter is simply appended to the token list that is built.
14243 And the final parameter tells how many of the special operations
14244 \.{\#\AT!}, \.{\AT!}, and \.{\AT!\#} are to be replaced by suffix parameters.
14245 When such parameters are present, they are called \.{(SUFFIX0)},
14246 \.{(SUFFIX1)}, and \.{(SUFFIX2)}.
14248 @c pointer mp_scan_toks (MP mp,command_code terminator, pointer
14249 subst_list, pointer tail_end, small_number suffix_count) {
14250 pointer p; /* tail of the token list being built */
14251 pointer q; /* temporary for link management */
14252 integer balance; /* left delimiters minus right delimiters */
14253 p=hold_head; balance=1; link(hold_head)=null;
14256 if ( mp->cur_sym>0 ) {
14257 @<Substitute for |cur_sym|, if it's on the |subst_list|@>;
14258 if ( mp->cur_cmd==terminator ) {
14259 @<Adjust the balance; |break| if it's zero@>;
14260 } else if ( mp->cur_cmd==macro_special ) {
14261 @<Handle quoted symbols, \.{\#\AT!}, \.{\AT!}, or \.{\AT!\#}@>;
14264 link(p)=mp_cur_tok(mp); p=link(p);
14266 link(p)=tail_end; mp_flush_node_list(mp, subst_list);
14267 return link(hold_head);
14270 @ @<Substitute for |cur_sym|...@>=
14273 while ( q!=null ) {
14274 if ( info(q)==mp->cur_sym ) {
14275 mp->cur_sym=value(q); mp->cur_cmd=relax; break;
14281 @ @<Adjust the balance; |break| if it's zero@>=
14282 if ( mp->cur_mod>0 ) {
14290 @ Four commands are intended to be used only within macro texts: \&{quote},
14291 \.{\#\AT!}, \.{\AT!}, and \.{\AT!\#}. They are variants of a single command
14292 code called |macro_special|.
14294 @d quote 0 /* |macro_special| modifier for \&{quote} */
14295 @d macro_prefix 1 /* |macro_special| modifier for \.{\#\AT!} */
14296 @d macro_at 2 /* |macro_special| modifier for \.{\AT!} */
14297 @d macro_suffix 3 /* |macro_special| modifier for \.{\AT!\#} */
14300 mp_primitive(mp, "quote",macro_special,quote);
14301 @:quote_}{\&{quote} primitive@>
14302 mp_primitive(mp, "#@@",macro_special,macro_prefix);
14303 @:]]]\#\AT!_}{\.{\#\AT!} primitive@>
14304 mp_primitive(mp, "@@",macro_special,macro_at);
14305 @:]]]\AT!_}{\.{\AT!} primitive@>
14306 mp_primitive(mp, "@@#",macro_special,macro_suffix);
14307 @:]]]\AT!\#_}{\.{\AT!\#} primitive@>
14309 @ @<Cases of |print_cmd...@>=
14310 case macro_special:
14312 case macro_prefix: mp_print(mp, "#@@"); break;
14313 case macro_at: mp_print_char(mp, '@@'); break;
14314 case macro_suffix: mp_print(mp, "@@#"); break;
14315 default: mp_print(mp, "quote"); break;
14319 @ @<Handle quoted...@>=
14321 if ( mp->cur_mod==quote ) { get_t_next; }
14322 else if ( mp->cur_mod<=suffix_count )
14323 mp->cur_sym=suffix_base-1+mp->cur_mod;
14326 @ Here is a routine that's used whenever a token will be redefined. If
14327 the user's token is unredefinable, the `|frozen_inaccessible|' token is
14328 substituted; the latter is redefinable but essentially impossible to use,
14329 hence \MP's tables won't get fouled up.
14331 @c void mp_get_symbol (MP mp) { /* sets |cur_sym| to a safe symbol */
14334 if ( (mp->cur_sym==0)||(mp->cur_sym>frozen_inaccessible) ) {
14335 print_err("Missing symbolic token inserted");
14336 @.Missing symbolic token...@>
14337 help3("Sorry: You can\'t redefine a number, string, or expr.")
14338 ("I've inserted an inaccessible symbol so that your")
14339 ("definition will be completed without mixing me up too badly.");
14340 if ( mp->cur_sym>0 )
14341 mp->help_line[2]="Sorry: You can\'t redefine my error-recovery tokens.";
14342 else if ( mp->cur_cmd==string_token )
14343 delete_str_ref(mp->cur_mod);
14344 mp->cur_sym=frozen_inaccessible; mp_ins_error(mp); goto RESTART;
14348 @ Before we actually redefine a symbolic token, we need to clear away its
14349 former value, if it was a variable. The following stronger version of
14350 |get_symbol| does that.
14352 @c void mp_get_clear_symbol (MP mp) {
14353 mp_get_symbol(mp); mp_clear_symbol(mp, mp->cur_sym,false);
14356 @ Here's another little subroutine; it checks that an equals sign
14357 or assignment sign comes along at the proper place in a macro definition.
14359 @c void mp_check_equals (MP mp) {
14360 if ( mp->cur_cmd!=equals ) if ( mp->cur_cmd!=assignment ) {
14361 mp_missing_err(mp, "=");
14363 help5("The next thing in this `def' should have been `=',")
14364 ("because I've already looked at the definition heading.")
14365 ("But don't worry; I'll pretend that an equals sign")
14366 ("was present. Everything from here to `enddef'")
14367 ("will be the replacement text of this macro.");
14372 @ A \&{primarydef}, \&{secondarydef}, or \&{tertiarydef} is rather easily
14373 handled now that we have |scan_toks|. In this case there are
14374 two parameters, which will be \.{EXPR0} and \.{EXPR1} (i.e.,
14375 |expr_base| and |expr_base+1|).
14377 @c void mp_make_op_def (MP mp) {
14378 command_code m; /* the type of definition */
14379 pointer p,q,r; /* for list manipulation */
14381 mp_get_symbol(mp); q=mp_get_node(mp, token_node_size);
14382 info(q)=mp->cur_sym; value(q)=expr_base;
14383 mp_get_clear_symbol(mp); mp->warning_info=mp->cur_sym;
14384 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
14385 info(p)=mp->cur_sym; value(p)=expr_base+1; link(p)=q;
14386 get_t_next; mp_check_equals(mp);
14387 mp->scanner_status=op_defining; q=mp_get_avail(mp); ref_count(q)=null;
14388 r=mp_get_avail(mp); link(q)=r; info(r)=general_macro;
14389 link(r)=mp_scan_toks(mp, macro_def,p,null,0);
14390 mp->scanner_status=normal; eq_type(mp->warning_info)=m;
14391 equiv(mp->warning_info)=q; mp_get_x_next(mp);
14394 @ Parameters to macros are introduced by the keywords \&{expr},
14395 \&{suffix}, \&{text}, \&{primary}, \&{secondary}, and \&{tertiary}.
14398 mp_primitive(mp, "expr",param_type,expr_base);
14399 @:expr_}{\&{expr} primitive@>
14400 mp_primitive(mp, "suffix",param_type,suffix_base);
14401 @:suffix_}{\&{suffix} primitive@>
14402 mp_primitive(mp, "text",param_type,text_base);
14403 @:text_}{\&{text} primitive@>
14404 mp_primitive(mp, "primary",param_type,primary_macro);
14405 @:primary_}{\&{primary} primitive@>
14406 mp_primitive(mp, "secondary",param_type,secondary_macro);
14407 @:secondary_}{\&{secondary} primitive@>
14408 mp_primitive(mp, "tertiary",param_type,tertiary_macro);
14409 @:tertiary_}{\&{tertiary} primitive@>
14411 @ @<Cases of |print_cmd...@>=
14413 if ( m>=expr_base ) {
14414 if ( m==expr_base ) mp_print(mp, "expr");
14415 else if ( m==suffix_base ) mp_print(mp, "suffix");
14416 else mp_print(mp, "text");
14417 } else if ( m<secondary_macro ) {
14418 mp_print(mp, "primary");
14419 } else if ( m==secondary_macro ) {
14420 mp_print(mp, "secondary");
14422 mp_print(mp, "tertiary");
14426 @ Let's turn next to the more complex processing associated with \&{def}
14427 and \&{vardef}. When the following procedure is called, |cur_mod|
14428 should be either |start_def| or |var_def|.
14430 @c @<Declare the procedure called |check_delimiter|@>
14431 @<Declare the function called |scan_declared_variable|@>
14432 void mp_scan_def (MP mp) {
14433 int m; /* the type of definition */
14434 int n; /* the number of special suffix parameters */
14435 int k; /* the total number of parameters */
14436 int c; /* the kind of macro we're defining */
14437 pointer r; /* parameter-substitution list */
14438 pointer q; /* tail of the macro token list */
14439 pointer p; /* temporary storage */
14440 halfword base; /* |expr_base|, |suffix_base|, or |text_base| */
14441 pointer l_delim,r_delim; /* matching delimiters */
14442 m=mp->cur_mod; c=general_macro; link(hold_head)=null;
14443 q=mp_get_avail(mp); ref_count(q)=null; r=null;
14444 @<Scan the token or variable to be defined;
14445 set |n|, |scanner_status|, and |warning_info|@>;
14447 if ( mp->cur_cmd==left_delimiter ) {
14448 @<Absorb delimited parameters, putting them into lists |q| and |r|@>;
14450 if ( mp->cur_cmd==param_type ) {
14451 @<Absorb undelimited parameters, putting them into list |r|@>;
14453 mp_check_equals(mp);
14454 p=mp_get_avail(mp); info(p)=c; link(q)=p;
14455 @<Attach the replacement text to the tail of node |p|@>;
14456 mp->scanner_status=normal; mp_get_x_next(mp);
14459 @ We don't put `|frozen_end_group|' into the replacement text of
14460 a \&{vardef}, because the user may want to redefine `\.{endgroup}'.
14462 @<Attach the replacement text to the tail of node |p|@>=
14463 if ( m==start_def ) {
14464 link(p)=mp_scan_toks(mp, macro_def,r,null,n);
14466 q=mp_get_avail(mp); info(q)=mp->bg_loc; link(p)=q;
14467 p=mp_get_avail(mp); info(p)=mp->eg_loc;
14468 link(q)=mp_scan_toks(mp, macro_def,r,p,n);
14470 if ( mp->warning_info==bad_vardef )
14471 mp_flush_token_list(mp, value(bad_vardef))
14475 int eg_loc; /* hash addresses of `\.{begingroup}' and `\.{endgroup}' */
14477 @ @<Scan the token or variable to be defined;...@>=
14478 if ( m==start_def ) {
14479 mp_get_clear_symbol(mp); mp->warning_info=mp->cur_sym; get_t_next;
14480 mp->scanner_status=op_defining; n=0;
14481 eq_type(mp->warning_info)=defined_macro; equiv(mp->warning_info)=q;
14483 p=mp_scan_declared_variable(mp);
14484 mp_flush_variable(mp, equiv(info(p)),link(p),true);
14485 mp->warning_info=mp_find_variable(mp, p); mp_flush_list(mp, p);
14486 if ( mp->warning_info==null ) @<Change to `\.{a bad variable}'@>;
14487 mp->scanner_status=var_defining; n=2;
14488 if ( mp->cur_cmd==macro_special ) if ( mp->cur_mod==macro_suffix ) {/* \.{\AT!\#} */
14491 type(mp->warning_info)=mp_unsuffixed_macro-2+n; value(mp->warning_info)=q;
14492 } /* |mp_suffixed_macro=mp_unsuffixed_macro+1| */
14494 @ @<Change to `\.{a bad variable}'@>=
14496 print_err("This variable already starts with a macro");
14497 @.This variable already...@>
14498 help2("After `vardef a' you can\'t say `vardef a.b'.")
14499 ("So I'll have to discard this definition.");
14500 mp_error(mp); mp->warning_info=bad_vardef;
14503 @ @<Initialize table entries...@>=
14504 name_type(bad_vardef)=mp_root; link(bad_vardef)=frozen_bad_vardef;
14505 equiv(frozen_bad_vardef)=bad_vardef; eq_type(frozen_bad_vardef)=tag_token;
14507 @ @<Absorb delimited parameters, putting them into lists |q| and |r|@>=
14509 l_delim=mp->cur_sym; r_delim=mp->cur_mod; get_t_next;
14510 if ( (mp->cur_cmd==param_type)&&(mp->cur_mod>=expr_base) ) {
14513 print_err("Missing parameter type; `expr' will be assumed");
14514 @.Missing parameter type@>
14515 help1("You should've had `expr' or `suffix' or `text' here.");
14516 mp_back_error(mp); base=expr_base;
14518 @<Absorb parameter tokens for type |base|@>;
14519 mp_check_delimiter(mp, l_delim,r_delim);
14521 } while (mp->cur_cmd==left_delimiter)
14523 @ @<Absorb parameter tokens for type |base|@>=
14525 link(q)=mp_get_avail(mp); q=link(q); info(q)=base+k;
14526 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
14527 value(p)=base+k; info(p)=mp->cur_sym;
14528 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14529 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
14530 incr(k); link(p)=r; r=p; get_t_next;
14531 } while (mp->cur_cmd==comma)
14533 @ @<Absorb undelimited parameters, putting them into list |r|@>=
14535 p=mp_get_node(mp, token_node_size);
14536 if ( mp->cur_mod<expr_base ) {
14537 c=mp->cur_mod; value(p)=expr_base+k;
14539 value(p)=mp->cur_mod+k;
14540 if ( mp->cur_mod==expr_base ) c=expr_macro;
14541 else if ( mp->cur_mod==suffix_base ) c=suffix_macro;
14544 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14545 incr(k); mp_get_symbol(mp); info(p)=mp->cur_sym; link(p)=r; r=p; get_t_next;
14546 if ( c==expr_macro ) if ( mp->cur_cmd==of_token ) {
14547 c=of_macro; p=mp_get_node(mp, token_node_size);
14548 if ( k==mp->param_size ) mp_overflow(mp, "parameter stack size",mp->param_size);
14549 value(p)=expr_base+k; mp_get_symbol(mp); info(p)=mp->cur_sym;
14550 link(p)=r; r=p; get_t_next;
14554 @* \[32] Expanding the next token.
14555 Only a few command codes |<min_command| can possibly be returned by
14556 |get_t_next|; in increasing order, they are
14557 |if_test|, |fi_or_else|, |input|, |iteration|, |repeat_loop|,
14558 |exit_test|, |relax|, |scan_tokens|, |expand_after|, and |defined_macro|.
14560 \MP\ usually gets the next token of input by saying |get_x_next|. This is
14561 like |get_t_next| except that it keeps getting more tokens until
14562 finding |cur_cmd>=min_command|. In other words, |get_x_next| expands
14563 macros and removes conditionals or iterations or input instructions that
14566 It follows that |get_x_next| might invoke itself recursively. In fact,
14567 there is massive recursion, since macro expansion can involve the
14568 scanning of arbitrarily complex expressions, which in turn involve
14569 macro expansion and conditionals, etc.
14572 Therefore it's necessary to declare a whole bunch of |forward|
14573 procedures at this point, and to insert some other procedures
14574 that will be invoked by |get_x_next|.
14577 void mp_scan_primary (MP mp);
14578 void mp_scan_secondary (MP mp);
14579 void mp_scan_tertiary (MP mp);
14580 void mp_scan_expression (MP mp);
14581 void mp_scan_suffix (MP mp);
14582 @<Declare the procedure called |macro_call|@>
14583 void mp_get_boolean (MP mp);
14584 void mp_pass_text (MP mp);
14585 void mp_conditional (MP mp);
14586 void mp_start_input (MP mp);
14587 void mp_begin_iteration (MP mp);
14588 void mp_resume_iteration (MP mp);
14589 void mp_stop_iteration (MP mp);
14591 @ An auxiliary subroutine called |expand| is used by |get_x_next|
14592 when it has to do exotic expansion commands.
14594 @c void mp_expand (MP mp) {
14595 pointer p; /* for list manipulation */
14596 size_t k; /* something that we hope is |<=buf_size| */
14597 pool_pointer j; /* index into |str_pool| */
14598 if ( mp->internal[mp_tracing_commands]>unity )
14599 if ( mp->cur_cmd!=defined_macro )
14601 switch (mp->cur_cmd) {
14603 mp_conditional(mp); /* this procedure is discussed in Part 36 below */
14606 @<Terminate the current conditional and skip to \&{fi}@>;
14609 @<Initiate or terminate input from a file@>;
14612 if ( mp->cur_mod==end_for ) {
14613 @<Scold the user for having an extra \&{endfor}@>;
14615 mp_begin_iteration(mp); /* this procedure is discussed in Part 37 below */
14622 @<Exit a loop if the proper time has come@>;
14627 @<Expand the token after the next token@>;
14630 @<Put a string into the input buffer@>;
14632 case defined_macro:
14633 mp_macro_call(mp, mp->cur_mod,null,mp->cur_sym);
14635 }; /* there are no other cases */
14638 @ @<Scold the user...@>=
14640 print_err("Extra `endfor'");
14642 help2("I'm not currently working on a for loop,")
14643 ("so I had better not try to end anything.");
14647 @ The processing of \&{input} involves the |start_input| subroutine,
14648 which will be declared later; the processing of \&{endinput} is trivial.
14651 mp_primitive(mp, "input",input,0);
14652 @:input_}{\&{input} primitive@>
14653 mp_primitive(mp, "endinput",input,1);
14654 @:end_input_}{\&{endinput} primitive@>
14656 @ @<Cases of |print_cmd_mod|...@>=
14658 if ( m==0 ) mp_print(mp, "input");
14659 else mp_print(mp, "endinput");
14662 @ @<Initiate or terminate input...@>=
14663 if ( mp->cur_mod>0 ) mp->force_eof=true;
14664 else mp_start_input(mp)
14666 @ We'll discuss the complicated parts of loop operations later. For now
14667 it suffices to know that there's a global variable called |loop_ptr|
14668 that will be |null| if no loop is in progress.
14671 { while ( token_state &&(loc==null) )
14672 mp_end_token_list(mp); /* conserve stack space */
14673 if ( mp->loop_ptr==null ) {
14674 print_err("Lost loop");
14676 help2("I'm confused; after exiting from a loop, I still seem")
14677 ("to want to repeat it. I'll try to forget the problem.");
14680 mp_resume_iteration(mp); /* this procedure is in Part 37 below */
14684 @ @<Exit a loop if the proper time has come@>=
14685 { mp_get_boolean(mp);
14686 if ( mp->internal[mp_tracing_commands]>unity )
14687 mp_show_cmd_mod(mp, nullary,mp->cur_exp);
14688 if ( mp->cur_exp==true_code ) {
14689 if ( mp->loop_ptr==null ) {
14690 print_err("No loop is in progress");
14691 @.No loop is in progress@>
14692 help1("Why say `exitif' when there's nothing to exit from?");
14693 if ( mp->cur_cmd==semicolon ) mp_error(mp); else mp_back_error(mp);
14695 @<Exit prematurely from an iteration@>;
14697 } else if ( mp->cur_cmd!=semicolon ) {
14698 mp_missing_err(mp, ";");
14700 help2("After `exitif <boolean exp>' I expect to see a semicolon.")
14701 ("I shall pretend that one was there."); mp_back_error(mp);
14705 @ Here we use the fact that |forever_text| is the only |token_type| that
14706 is less than |loop_text|.
14708 @<Exit prematurely...@>=
14711 if ( file_state ) {
14712 mp_end_file_reading(mp);
14714 if ( token_type<=loop_text ) p=start;
14715 mp_end_token_list(mp);
14718 if ( p!=info(mp->loop_ptr) ) mp_fatal_error(mp, "*** (loop confusion)");
14720 mp_stop_iteration(mp); /* this procedure is in Part 34 below */
14723 @ @<Expand the token after the next token@>=
14725 p=mp_cur_tok(mp); get_t_next;
14726 if ( mp->cur_cmd<min_command ) mp_expand(mp);
14727 else mp_back_input(mp);
14731 @ @<Put a string into the input buffer@>=
14732 { mp_get_x_next(mp); mp_scan_primary(mp);
14733 if ( mp->cur_type!=mp_string_type ) {
14734 mp_disp_err(mp, null,"Not a string");
14736 help2("I'm going to flush this expression, since")
14737 ("scantokens should be followed by a known string.");
14738 mp_put_get_flush_error(mp, 0);
14741 if ( length(mp->cur_exp)>0 )
14742 @<Pretend we're reading a new one-line file@>;
14746 @ @<Pretend we're reading a new one-line file@>=
14747 { mp_begin_file_reading(mp); name=is_scantok;
14748 k=mp->first+length(mp->cur_exp);
14749 if ( k>=mp->max_buf_stack ) {
14750 while ( k>=mp->buf_size ) {
14751 mp_reallocate_buffer(mp,(mp->buf_size+(mp->buf_size>>2)));
14753 mp->max_buf_stack=k+1;
14755 j=mp->str_start[mp->cur_exp]; limit=k;
14756 while ( mp->first<(size_t)limit ) {
14757 mp->buffer[mp->first]=mp->str_pool[j]; incr(j); incr(mp->first);
14759 mp->buffer[limit]='%'; mp->first=limit+1; loc=start;
14760 mp_flush_cur_exp(mp, 0);
14763 @ Here finally is |get_x_next|.
14765 The expression scanning routines to be considered later
14766 communicate via the global quantities |cur_type| and |cur_exp|;
14767 we must be very careful to save and restore these quantities while
14768 macros are being expanded.
14772 void mp_get_x_next (MP mp);
14774 @ @c void mp_get_x_next (MP mp) {
14775 pointer save_exp; /* a capsule to save |cur_type| and |cur_exp| */
14777 if ( mp->cur_cmd<min_command ) {
14778 save_exp=mp_stash_cur_exp(mp);
14780 if ( mp->cur_cmd==defined_macro )
14781 mp_macro_call(mp, mp->cur_mod,null,mp->cur_sym);
14785 } while (mp->cur_cmd<min_command);
14786 mp_unstash_cur_exp(mp, save_exp); /* that restores |cur_type| and |cur_exp| */
14790 @ Now let's consider the |macro_call| procedure, which is used to start up
14791 all user-defined macros. Since the arguments to a macro might be expressions,
14792 |macro_call| is recursive.
14795 The first parameter to |macro_call| points to the reference count of the
14796 token list that defines the macro. The second parameter contains any
14797 arguments that have already been parsed (see below). The third parameter
14798 points to the symbolic token that names the macro. If the third parameter
14799 is |null|, the macro was defined by \&{vardef}, so its name can be
14800 reconstructed from the prefix and ``at'' arguments found within the
14803 What is this second parameter? It's simply a linked list of one-word items,
14804 whose |info| fields point to the arguments. In other words, if |arg_list=null|,
14805 no arguments have been scanned yet; otherwise |info(arg_list)| points to
14806 the first scanned argument, and |link(arg_list)| points to the list of
14807 further arguments (if any).
14809 Arguments of type \&{expr} are so-called capsules, which we will
14810 discuss later when we concentrate on expressions; they can be
14811 recognized easily because their |link| field is |void|. Arguments of type
14812 \&{suffix} and \&{text} are token lists without reference counts.
14814 @ After argument scanning is complete, the arguments are moved to the
14815 |param_stack|. (They can't be put on that stack any sooner, because
14816 the stack is growing and shrinking in unpredictable ways as more arguments
14817 are being acquired.) Then the macro body is fed to the scanner; i.e.,
14818 the replacement text of the macro is placed at the top of the \MP's
14819 input stack, so that |get_t_next| will proceed to read it next.
14821 @<Declare the procedure called |macro_call|@>=
14822 @<Declare the procedure called |print_macro_name|@>
14823 @<Declare the procedure called |print_arg|@>
14824 @<Declare the procedure called |scan_text_arg|@>
14825 void mp_macro_call (MP mp,pointer def_ref, pointer arg_list,
14826 pointer macro_name) ;
14829 void mp_macro_call (MP mp,pointer def_ref, pointer arg_list,
14830 pointer macro_name) {
14831 /* invokes a user-defined control sequence */
14832 pointer r; /* current node in the macro's token list */
14833 pointer p,q; /* for list manipulation */
14834 integer n; /* the number of arguments */
14835 pointer tail = 0; /* tail of the argument list */
14836 pointer l_delim=0,r_delim=0; /* a delimiter pair */
14837 r=link(def_ref); add_mac_ref(def_ref);
14838 if ( arg_list==null ) {
14841 @<Determine the number |n| of arguments already supplied,
14842 and set |tail| to the tail of |arg_list|@>;
14844 if ( mp->internal[mp_tracing_macros]>0 ) {
14845 @<Show the text of the macro being expanded, and the existing arguments@>;
14847 @<Scan the remaining arguments, if any; set |r| to the first token
14848 of the replacement text@>;
14849 @<Feed the arguments and replacement text to the scanner@>;
14852 @ @<Show the text of the macro...@>=
14853 mp_begin_diagnostic(mp); mp_print_ln(mp);
14854 mp_print_macro_name(mp, arg_list,macro_name);
14855 if ( n==3 ) mp_print(mp, "@@#"); /* indicate a suffixed macro */
14856 mp_show_macro(mp, def_ref,null,100000);
14857 if ( arg_list!=null ) {
14861 mp_print_arg(mp, q,n,0);
14862 incr(n); p=link(p);
14865 mp_end_diagnostic(mp, false)
14868 @ @<Declare the procedure called |print_macro_name|@>=
14869 void mp_print_macro_name (MP mp,pointer a, pointer n);
14872 void mp_print_macro_name (MP mp,pointer a, pointer n) {
14873 pointer p,q; /* they traverse the first part of |a| */
14879 mp_print_text(info(info(link(a))));
14882 while ( link(q)!=null ) q=link(q);
14883 link(q)=info(link(a));
14884 mp_show_token_list(mp, p,null,1000,0);
14890 @ @<Declare the procedure called |print_arg|@>=
14891 void mp_print_arg (MP mp,pointer q, integer n, pointer b) ;
14894 void mp_print_arg (MP mp,pointer q, integer n, pointer b) {
14895 if ( link(q)==mp_void ) mp_print_nl(mp, "(EXPR");
14896 else if ( (b<text_base)&&(b!=text_macro) ) mp_print_nl(mp, "(SUFFIX");
14897 else mp_print_nl(mp, "(TEXT");
14898 mp_print_int(mp, n); mp_print(mp, ")<-");
14899 if ( link(q)==mp_void ) mp_print_exp(mp, q,1);
14900 else mp_show_token_list(mp, q,null,1000,0);
14903 @ @<Determine the number |n| of arguments already supplied...@>=
14905 n=1; tail=arg_list;
14906 while ( link(tail)!=null ) {
14907 incr(n); tail=link(tail);
14911 @ @<Scan the remaining arguments, if any; set |r|...@>=
14912 mp->cur_cmd=comma+1; /* anything |<>comma| will do */
14913 while ( info(r)>=expr_base ) {
14914 @<Scan the delimited argument represented by |info(r)|@>;
14917 if ( mp->cur_cmd==comma ) {
14918 print_err("Too many arguments to ");
14919 @.Too many arguments...@>
14920 mp_print_macro_name(mp, arg_list,macro_name); mp_print_char(mp, ';');
14921 mp_print_nl(mp, " Missing `"); mp_print_text(r_delim);
14923 mp_print(mp, "' has been inserted");
14924 help3("I'm going to assume that the comma I just read was a")
14925 ("right delimiter, and then I'll begin expanding the macro.")
14926 ("You might want to delete some tokens before continuing.");
14929 if ( info(r)!=general_macro ) {
14930 @<Scan undelimited argument(s)@>;
14934 @ At this point, the reader will find it advisable to review the explanation
14935 of token list format that was presented earlier, paying special attention to
14936 the conventions that apply only at the beginning of a macro's token list.
14938 On the other hand, the reader will have to take the expression-parsing
14939 aspects of the following program on faith; we will explain |cur_type|
14940 and |cur_exp| later. (Several things in this program depend on each other,
14941 and it's necessary to jump into the circle somewhere.)
14943 @<Scan the delimited argument represented by |info(r)|@>=
14944 if ( mp->cur_cmd!=comma ) {
14946 if ( mp->cur_cmd!=left_delimiter ) {
14947 print_err("Missing argument to ");
14948 @.Missing argument...@>
14949 mp_print_macro_name(mp, arg_list,macro_name);
14950 help3("That macro has more parameters than you thought.")
14951 ("I'll continue by pretending that each missing argument")
14952 ("is either zero or null.");
14953 if ( info(r)>=suffix_base ) {
14954 mp->cur_exp=null; mp->cur_type=mp_token_list;
14956 mp->cur_exp=0; mp->cur_type=mp_known;
14958 mp_back_error(mp); mp->cur_cmd=right_delimiter;
14961 l_delim=mp->cur_sym; r_delim=mp->cur_mod;
14963 @<Scan the argument represented by |info(r)|@>;
14964 if ( mp->cur_cmd!=comma )
14965 @<Check that the proper right delimiter was present@>;
14967 @<Append the current expression to |arg_list|@>
14969 @ @<Check that the proper right delim...@>=
14970 if ( (mp->cur_cmd!=right_delimiter)||(mp->cur_mod!=l_delim) ) {
14971 if ( info(link(r))>=expr_base ) {
14972 mp_missing_err(mp, ",");
14974 help3("I've finished reading a macro argument and am about to")
14975 ("read another; the arguments weren't delimited correctly.")
14976 ("You might want to delete some tokens before continuing.");
14977 mp_back_error(mp); mp->cur_cmd=comma;
14979 mp_missing_err(mp, str(text(r_delim)));
14981 help2("I've gotten to the end of the macro parameter list.")
14982 ("You might want to delete some tokens before continuing.");
14987 @ A \&{suffix} or \&{text} parameter will have been scanned as
14988 a token list pointed to by |cur_exp|, in which case we will have
14989 |cur_type=token_list|.
14991 @<Append the current expression to |arg_list|@>=
14993 p=mp_get_avail(mp);
14994 if ( mp->cur_type==mp_token_list ) info(p)=mp->cur_exp;
14995 else info(p)=mp_stash_cur_exp(mp);
14996 if ( mp->internal[mp_tracing_macros]>0 ) {
14997 mp_begin_diagnostic(mp); mp_print_arg(mp, info(p),n,info(r));
14998 mp_end_diagnostic(mp, false);
15000 if ( arg_list==null ) arg_list=p;
15005 @ @<Scan the argument represented by |info(r)|@>=
15006 if ( info(r)>=text_base ) {
15007 mp_scan_text_arg(mp, l_delim,r_delim);
15010 if ( info(r)>=suffix_base ) mp_scan_suffix(mp);
15011 else mp_scan_expression(mp);
15014 @ The parameters to |scan_text_arg| are either a pair of delimiters
15015 or zero; the latter case is for undelimited text arguments, which
15016 end with the first semicolon or \&{endgroup} or \&{end} that is not
15017 contained in a group.
15019 @<Declare the procedure called |scan_text_arg|@>=
15020 void mp_scan_text_arg (MP mp,pointer l_delim, pointer r_delim) ;
15023 void mp_scan_text_arg (MP mp,pointer l_delim, pointer r_delim) {
15024 integer balance; /* excess of |l_delim| over |r_delim| */
15025 pointer p; /* list tail */
15026 mp->warning_info=l_delim; mp->scanner_status=absorbing;
15027 p=hold_head; balance=1; link(hold_head)=null;
15030 if ( l_delim==0 ) {
15031 @<Adjust the balance for an undelimited argument; |break| if done@>;
15033 @<Adjust the balance for a delimited argument; |break| if done@>;
15035 link(p)=mp_cur_tok(mp); p=link(p);
15037 mp->cur_exp=link(hold_head); mp->cur_type=mp_token_list;
15038 mp->scanner_status=normal;
15041 @ @<Adjust the balance for a delimited argument...@>=
15042 if ( mp->cur_cmd==right_delimiter ) {
15043 if ( mp->cur_mod==l_delim ) {
15045 if ( balance==0 ) break;
15047 } else if ( mp->cur_cmd==left_delimiter ) {
15048 if ( mp->cur_mod==r_delim ) incr(balance);
15051 @ @<Adjust the balance for an undelimited...@>=
15052 if ( end_of_statement ) { /* |cur_cmd=semicolon|, |end_group|, or |stop| */
15053 if ( balance==1 ) { break; }
15054 else { if ( mp->cur_cmd==end_group ) decr(balance); }
15055 } else if ( mp->cur_cmd==begin_group ) {
15059 @ @<Scan undelimited argument(s)@>=
15061 if ( info(r)<text_macro ) {
15063 if ( info(r)!=suffix_macro ) {
15064 if ( (mp->cur_cmd==equals)||(mp->cur_cmd==assignment) ) mp_get_x_next(mp);
15068 case primary_macro:mp_scan_primary(mp); break;
15069 case secondary_macro:mp_scan_secondary(mp); break;
15070 case tertiary_macro:mp_scan_tertiary(mp); break;
15071 case expr_macro:mp_scan_expression(mp); break;
15073 @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>;
15076 @<Scan a suffix with optional delimiters@>;
15078 case text_macro:mp_scan_text_arg(mp, 0,0); break;
15079 } /* there are no other cases */
15081 @<Append the current expression to |arg_list|@>;
15084 @ @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>=
15086 mp_scan_expression(mp); p=mp_get_avail(mp); info(p)=mp_stash_cur_exp(mp);
15087 if ( mp->internal[mp_tracing_macros]>0 ) {
15088 mp_begin_diagnostic(mp); mp_print_arg(mp, info(p),n,0);
15089 mp_end_diagnostic(mp, false);
15091 if ( arg_list==null ) arg_list=p; else link(tail)=p;
15093 if ( mp->cur_cmd!=of_token ) {
15094 mp_missing_err(mp, "of"); mp_print(mp, " for ");
15096 mp_print_macro_name(mp, arg_list,macro_name);
15097 help1("I've got the first argument; will look now for the other.");
15100 mp_get_x_next(mp); mp_scan_primary(mp);
15103 @ @<Scan a suffix with optional delimiters@>=
15105 if ( mp->cur_cmd!=left_delimiter ) {
15108 l_delim=mp->cur_sym; r_delim=mp->cur_mod; mp_get_x_next(mp);
15110 mp_scan_suffix(mp);
15111 if ( l_delim!=null ) {
15112 if ((mp->cur_cmd!=right_delimiter)||(mp->cur_mod!=l_delim) ) {
15113 mp_missing_err(mp, str(text(r_delim)));
15115 help2("I've gotten to the end of the macro parameter list.")
15116 ("You might want to delete some tokens before continuing.");
15123 @ Before we put a new token list on the input stack, it is wise to clean off
15124 all token lists that have recently been depleted. Then a user macro that ends
15125 with a call to itself will not require unbounded stack space.
15127 @<Feed the arguments and replacement text to the scanner@>=
15128 while ( token_state &&(loc==null) ) mp_end_token_list(mp); /* conserve stack space */
15129 if ( mp->param_ptr+n>mp->max_param_stack ) {
15130 mp->max_param_stack=mp->param_ptr+n;
15131 if ( mp->max_param_stack>mp->param_size )
15132 mp_overflow(mp, "parameter stack size",mp->param_size);
15133 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
15135 mp_begin_token_list(mp, def_ref,macro); name=macro_name; loc=r;
15139 mp->param_stack[mp->param_ptr]=info(p); incr(mp->param_ptr); p=link(p);
15141 mp_flush_list(mp, arg_list);
15144 @ It's sometimes necessary to put a single argument onto |param_stack|.
15145 The |stack_argument| subroutine does this.
15147 @c void mp_stack_argument (MP mp,pointer p) {
15148 if ( mp->param_ptr==mp->max_param_stack ) {
15149 incr(mp->max_param_stack);
15150 if ( mp->max_param_stack>mp->param_size )
15151 mp_overflow(mp, "parameter stack size",mp->param_size);
15152 @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@>
15154 mp->param_stack[mp->param_ptr]=p; incr(mp->param_ptr);
15157 @* \[33] Conditional processing.
15158 Let's consider now the way \&{if} commands are handled.
15160 Conditions can be inside conditions, and this nesting has a stack
15161 that is independent of other stacks.
15162 Four global variables represent the top of the condition stack:
15163 |cond_ptr| points to pushed-down entries, if~any; |cur_if| tells whether
15164 we are processing \&{if} or \&{elseif}; |if_limit| specifies
15165 the largest code of a |fi_or_else| command that is syntactically legal;
15166 and |if_line| is the line number at which the current conditional began.
15168 If no conditions are currently in progress, the condition stack has the
15169 special state |cond_ptr=null|, |if_limit=normal|, |cur_if=0|, |if_line=0|.
15170 Otherwise |cond_ptr| points to a two-word node; the |type|, |name_type|, and
15171 |link| fields of the first word contain |if_limit|, |cur_if|, and
15172 |cond_ptr| at the next level, and the second word contains the
15173 corresponding |if_line|.
15175 @d if_node_size 2 /* number of words in stack entry for conditionals */
15176 @d if_line_field(A) mp->mem[(A)+1].cint
15177 @d if_code 1 /* code for \&{if} being evaluated */
15178 @d fi_code 2 /* code for \&{fi} */
15179 @d else_code 3 /* code for \&{else} */
15180 @d else_if_code 4 /* code for \&{elseif} */
15183 pointer cond_ptr; /* top of the condition stack */
15184 integer if_limit; /* upper bound on |fi_or_else| codes */
15185 small_number cur_if; /* type of conditional being worked on */
15186 integer if_line; /* line where that conditional began */
15189 mp->cond_ptr=null; mp->if_limit=normal; mp->cur_if=0; mp->if_line=0;
15192 mp_primitive(mp, "if",if_test,if_code);
15193 @:if_}{\&{if} primitive@>
15194 mp_primitive(mp, "fi",fi_or_else,fi_code); mp->eqtb[frozen_fi]=mp->eqtb[mp->cur_sym];
15195 @:fi_}{\&{fi} primitive@>
15196 mp_primitive(mp, "else",fi_or_else,else_code);
15197 @:else_}{\&{else} primitive@>
15198 mp_primitive(mp, "elseif",fi_or_else,else_if_code);
15199 @:else_if_}{\&{elseif} primitive@>
15201 @ @<Cases of |print_cmd_mod|...@>=
15205 case if_code:mp_print(mp, "if"); break;
15206 case fi_code:mp_print(mp, "fi"); break;
15207 case else_code:mp_print(mp, "else"); break;
15208 default: mp_print(mp, "elseif"); break;
15212 @ Here is a procedure that ignores text until coming to an \&{elseif},
15213 \&{else}, or \&{fi} at level zero of $\&{if}\ldots\&{fi}$
15214 nesting. After it has acted, |cur_mod| will indicate the token that
15217 \MP's smallest two command codes are |if_test| and |fi_or_else|; this
15218 makes the skipping process a bit simpler.
15221 void mp_pass_text (MP mp) {
15223 mp->scanner_status=skipping;
15224 mp->warning_info=mp_true_line(mp);
15227 if ( mp->cur_cmd<=fi_or_else ) {
15228 if ( mp->cur_cmd<fi_or_else ) {
15232 if ( mp->cur_mod==fi_code ) decr(l);
15235 @<Decrease the string reference count,
15236 if the current token is a string@>;
15239 mp->scanner_status=normal;
15242 @ @<Decrease the string reference count...@>=
15243 if ( mp->cur_cmd==string_token ) { delete_str_ref(mp->cur_mod); }
15245 @ When we begin to process a new \&{if}, we set |if_limit:=if_code|; then
15246 if \&{elseif} or \&{else} or \&{fi} occurs before the current \&{if}
15247 condition has been evaluated, a colon will be inserted.
15248 A construction like `\.{if fi}' would otherwise get \MP\ confused.
15250 @<Push the condition stack@>=
15251 { p=mp_get_node(mp, if_node_size); link(p)=mp->cond_ptr; type(p)=mp->if_limit;
15252 name_type(p)=mp->cur_if; if_line_field(p)=mp->if_line;
15253 mp->cond_ptr=p; mp->if_limit=if_code; mp->if_line=mp_true_line(mp);
15254 mp->cur_if=if_code;
15257 @ @<Pop the condition stack@>=
15258 { p=mp->cond_ptr; mp->if_line=if_line_field(p);
15259 mp->cur_if=name_type(p); mp->if_limit=type(p); mp->cond_ptr=link(p);
15260 mp_free_node(mp, p,if_node_size);
15263 @ Here's a procedure that changes the |if_limit| code corresponding to
15264 a given value of |cond_ptr|.
15266 @c void mp_change_if_limit (MP mp,small_number l, pointer p) {
15268 if ( p==mp->cond_ptr ) {
15269 mp->if_limit=l; /* that's the easy case */
15273 if ( q==null ) mp_confusion(mp, "if");
15274 @:this can't happen if}{\quad if@>
15275 if ( link(q)==p ) {
15283 @ The user is supposed to put colons into the proper parts of conditional
15284 statements. Therefore, \MP\ has to check for their presence.
15287 void mp_check_colon (MP mp) {
15288 if ( mp->cur_cmd!=colon ) {
15289 mp_missing_err(mp, ":");
15291 help2("There should've been a colon after the condition.")
15292 ("I shall pretend that one was there.");;
15297 @ A condition is started when the |get_x_next| procedure encounters
15298 an |if_test| command; in that case |get_x_next| calls |conditional|,
15299 which is a recursive procedure.
15302 @c void mp_conditional (MP mp) {
15303 pointer save_cond_ptr; /* |cond_ptr| corresponding to this conditional */
15304 int new_if_limit; /* future value of |if_limit| */
15305 pointer p; /* temporary register */
15306 @<Push the condition stack@>;
15307 save_cond_ptr=mp->cond_ptr;
15309 mp_get_boolean(mp); new_if_limit=else_if_code;
15310 if ( mp->internal[mp_tracing_commands]>unity ) {
15311 @<Display the boolean value of |cur_exp|@>;
15314 mp_check_colon(mp);
15315 if ( mp->cur_exp==true_code ) {
15316 mp_change_if_limit(mp, new_if_limit,save_cond_ptr);
15317 return; /* wait for \&{elseif}, \&{else}, or \&{fi} */
15319 @<Skip to \&{elseif} or \&{else} or \&{fi}, then |goto done|@>;
15321 mp->cur_if=mp->cur_mod; mp->if_line=mp_true_line(mp);
15322 if ( mp->cur_mod==fi_code ) {
15323 @<Pop the condition stack@>
15324 } else if ( mp->cur_mod==else_if_code ) {
15327 mp->cur_exp=true_code; new_if_limit=fi_code; mp_get_x_next(mp);
15332 @ In a construction like `\&{if} \&{if} \&{true}: $0=1$: \\{foo}
15333 \&{else}: \\{bar} \&{fi}', the first \&{else}
15334 that we come to after learning that the \&{if} is false is not the
15335 \&{else} we're looking for. Hence the following curious logic is needed.
15337 @<Skip to \&{elseif}...@>=
15340 if ( mp->cond_ptr==save_cond_ptr ) goto DONE;
15341 else if ( mp->cur_mod==fi_code ) @<Pop the condition stack@>;
15345 @ @<Display the boolean value...@>=
15346 { mp_begin_diagnostic(mp);
15347 if ( mp->cur_exp==true_code ) mp_print(mp, "{true}");
15348 else mp_print(mp, "{false}");
15349 mp_end_diagnostic(mp, false);
15352 @ The processing of conditionals is complete except for the following
15353 code, which is actually part of |get_x_next|. It comes into play when
15354 \&{elseif}, \&{else}, or \&{fi} is scanned.
15356 @<Terminate the current conditional and skip to \&{fi}@>=
15357 if ( mp->cur_mod>mp->if_limit ) {
15358 if ( mp->if_limit==if_code ) { /* condition not yet evaluated */
15359 mp_missing_err(mp, ":");
15361 mp_back_input(mp); mp->cur_sym=frozen_colon; mp_ins_error(mp);
15363 print_err("Extra "); mp_print_cmd_mod(mp, fi_or_else,mp->cur_mod);
15367 help1("I'm ignoring this; it doesn't match any if.");
15371 while ( mp->cur_mod!=fi_code ) mp_pass_text(mp); /* skip to \&{fi} */
15372 @<Pop the condition stack@>;
15375 @* \[34] Iterations.
15376 To bring our treatment of |get_x_next| to a close, we need to consider what
15377 \MP\ does when it sees \&{for}, \&{forsuffixes}, and \&{forever}.
15379 There's a global variable |loop_ptr| that keeps track of the \&{for} loops
15380 that are currently active. If |loop_ptr=null|, no loops are in progress;
15381 otherwise |info(loop_ptr)| points to the iterative text of the current
15382 (innermost) loop, and |link(loop_ptr)| points to the data for any other
15383 loops that enclose the current one.
15385 A loop-control node also has two other fields, called |loop_type| and
15386 |loop_list|, whose contents depend on the type of loop:
15388 \yskip\indent|loop_type(loop_ptr)=null| means that |loop_list(loop_ptr)|
15389 points to a list of one-word nodes whose |info| fields point to the
15390 remaining argument values of a suffix list and expression list.
15392 \yskip\indent|loop_type(loop_ptr)=mp_void| means that the current loop is
15395 \yskip\indent|loop_type(loop_ptr)=progression_flag| means that
15396 |p=loop_list(loop_ptr)| points to a ``progression node'' and |value(p)|,
15397 |step_size(p)|, and |final_value(p)| contain the data for an arithmetic
15400 \yskip\indent|loop_type(loop_ptr)=p>mp_void| means that |p| points to an edge
15401 header and |loop_list(loop_ptr)| points into the graphical object list for
15404 \yskip\noindent In the case of a progression node, the first word is not used
15405 because the link field of words in the dynamic memory area cannot be arbitrary.
15407 @d loop_list_loc(A) ((A)+1) /* where the |loop_list| field resides */
15408 @d loop_type(A) info(loop_list_loc((A))) /* the type of \&{for} loop */
15409 @d loop_list(A) link(loop_list_loc((A))) /* the remaining list elements */
15410 @d loop_node_size 2 /* the number of words in a loop control node */
15411 @d progression_node_size 4 /* the number of words in a progression node */
15412 @d step_size(A) mp->mem[(A)+2].sc /* the step size in an arithmetic progression */
15413 @d final_value(A) mp->mem[(A)+3].sc /* the final value in an arithmetic progression */
15414 @d progression_flag (null+2)
15415 /* |loop_type| value when |loop_list| points to a progression node */
15418 pointer loop_ptr; /* top of the loop-control-node stack */
15423 @ If the expressions that define an arithmetic progression in
15424 a \&{for} loop don't have known numeric values, the |bad_for|
15425 subroutine screams at the user.
15427 @c void mp_bad_for (MP mp, const char * s) {
15428 mp_disp_err(mp, null,"Improper "); /* show the bad expression above the message */
15429 @.Improper...replaced by 0@>
15430 mp_print(mp, s); mp_print(mp, " has been replaced by 0");
15431 help4("When you say `for x=a step b until c',")
15432 ("the initial value `a' and the step size `b'")
15433 ("and the final value `c' must have known numeric values.")
15434 ("I'm zeroing this one. Proceed, with fingers crossed.");
15435 mp_put_get_flush_error(mp, 0);
15438 @ Here's what \MP\ does when \&{for}, \&{forsuffixes}, or \&{forever}
15439 has just been scanned. (This code requires slight familiarity with
15440 expression-parsing routines that we have not yet discussed; but it seems
15441 to belong in the present part of the program, even though the original author
15442 didn't write it until later. The reader may wish to come back to it.)
15444 @c void mp_begin_iteration (MP mp) {
15445 halfword m; /* |expr_base| (\&{for}) or |suffix_base| (\&{forsuffixes}) */
15446 halfword n; /* hash address of the current symbol */
15447 pointer s; /* the new loop-control node */
15448 pointer p; /* substitution list for |scan_toks| */
15449 pointer q; /* link manipulation register */
15450 pointer pp; /* a new progression node */
15451 m=mp->cur_mod; n=mp->cur_sym; s=mp_get_node(mp, loop_node_size);
15452 if ( m==start_forever ){
15453 loop_type(s)=mp_void; p=null; mp_get_x_next(mp);
15455 mp_get_symbol(mp); p=mp_get_node(mp, token_node_size);
15456 info(p)=mp->cur_sym; value(p)=m;
15458 if ( mp->cur_cmd==within_token ) {
15459 @<Set up a picture iteration@>;
15461 @<Check for the |"="| or |":="| in a loop header@>;
15462 @<Scan the values to be used in the loop@>;
15465 @<Check for the presence of a colon@>;
15466 @<Scan the loop text and put it on the loop control stack@>;
15467 mp_resume_iteration(mp);
15470 @ @<Check for the |"="| or |":="| in a loop header@>=
15471 if ( (mp->cur_cmd!=equals)&&(mp->cur_cmd!=assignment) ) {
15472 mp_missing_err(mp, "=");
15474 help3("The next thing in this loop should have been `=' or `:='.")
15475 ("But don't worry; I'll pretend that an equals sign")
15476 ("was present, and I'll look for the values next.");
15480 @ @<Check for the presence of a colon@>=
15481 if ( mp->cur_cmd!=colon ) {
15482 mp_missing_err(mp, ":");
15484 help3("The next thing in this loop should have been a `:'.")
15485 ("So I'll pretend that a colon was present;")
15486 ("everything from here to `endfor' will be iterated.");
15490 @ We append a special |frozen_repeat_loop| token in place of the
15491 `\&{endfor}' at the end of the loop. This will come through \MP's scanner
15492 at the proper time to cause the loop to be repeated.
15494 (If the user tries some shenanigan like `\&{for} $\ldots$ \&{let} \&{endfor}',
15495 he will be foiled by the |get_symbol| routine, which keeps frozen
15496 tokens unchanged. Furthermore the |frozen_repeat_loop| is an \&{outer}
15497 token, so it won't be lost accidentally.)
15499 @ @<Scan the loop text...@>=
15500 q=mp_get_avail(mp); info(q)=frozen_repeat_loop;
15501 mp->scanner_status=loop_defining; mp->warning_info=n;
15502 info(s)=mp_scan_toks(mp, iteration,p,q,0); mp->scanner_status=normal;
15503 link(s)=mp->loop_ptr; mp->loop_ptr=s
15505 @ @<Initialize table...@>=
15506 eq_type(frozen_repeat_loop)=repeat_loop+outer_tag;
15507 text(frozen_repeat_loop)=intern(" ENDFOR");
15509 @ The loop text is inserted into \MP's scanning apparatus by the
15510 |resume_iteration| routine.
15512 @c void mp_resume_iteration (MP mp) {
15513 pointer p,q; /* link registers */
15514 p=loop_type(mp->loop_ptr);
15515 if ( p==progression_flag ) {
15516 p=loop_list(mp->loop_ptr); /* now |p| points to a progression node */
15517 mp->cur_exp=value(p);
15518 if ( @<The arithmetic progression has ended@> ) {
15519 mp_stop_iteration(mp);
15522 mp->cur_type=mp_known; q=mp_stash_cur_exp(mp); /* make |q| an \&{expr} argument */
15523 value(p)=mp->cur_exp+step_size(p); /* set |value(p)| for the next iteration */
15524 } else if ( p==null ) {
15525 p=loop_list(mp->loop_ptr);
15527 mp_stop_iteration(mp);
15530 loop_list(mp->loop_ptr)=link(p); q=info(p); free_avail(p);
15531 } else if ( p==mp_void ) {
15532 mp_begin_token_list(mp, info(mp->loop_ptr),forever_text); return;
15534 @<Make |q| a capsule containing the next picture component from
15535 |loop_list(loop_ptr)| or |goto not_found|@>;
15537 mp_begin_token_list(mp, info(mp->loop_ptr),loop_text);
15538 mp_stack_argument(mp, q);
15539 if ( mp->internal[mp_tracing_commands]>unity ) {
15540 @<Trace the start of a loop@>;
15544 mp_stop_iteration(mp);
15547 @ @<The arithmetic progression has ended@>=
15548 ((step_size(p)>0)&&(mp->cur_exp>final_value(p)))||
15549 ((step_size(p)<0)&&(mp->cur_exp<final_value(p)))
15551 @ @<Trace the start of a loop@>=
15553 mp_begin_diagnostic(mp); mp_print_nl(mp, "{loop value=");
15555 if ( (q!=null)&&(link(q)==mp_void) ) mp_print_exp(mp, q,1);
15556 else mp_show_token_list(mp, q,null,50,0);
15557 mp_print_char(mp, '}'); mp_end_diagnostic(mp, false);
15560 @ @<Make |q| a capsule containing the next picture component from...@>=
15561 { q=loop_list(mp->loop_ptr);
15562 if ( q==null ) goto NOT_FOUND;
15563 skip_component(q) goto NOT_FOUND;
15564 mp->cur_exp=mp_copy_objects(mp, loop_list(mp->loop_ptr),q);
15565 mp_init_bbox(mp, mp->cur_exp);
15566 mp->cur_type=mp_picture_type;
15567 loop_list(mp->loop_ptr)=q;
15568 q=mp_stash_cur_exp(mp);
15571 @ A level of loop control disappears when |resume_iteration| has decided
15572 not to resume, or when an \&{exitif} construction has removed the loop text
15573 from the input stack.
15575 @c void mp_stop_iteration (MP mp) {
15576 pointer p,q; /* the usual */
15577 p=loop_type(mp->loop_ptr);
15578 if ( p==progression_flag ) {
15579 mp_free_node(mp, loop_list(mp->loop_ptr),progression_node_size);
15580 } else if ( p==null ){
15581 q=loop_list(mp->loop_ptr);
15582 while ( q!=null ) {
15585 if ( link(p)==mp_void ) { /* it's an \&{expr} parameter */
15586 mp_recycle_value(mp, p); mp_free_node(mp, p,value_node_size);
15588 mp_flush_token_list(mp, p); /* it's a \&{suffix} or \&{text} parameter */
15591 p=q; q=link(q); free_avail(p);
15593 } else if ( p>progression_flag ) {
15594 delete_edge_ref(p);
15596 p=mp->loop_ptr; mp->loop_ptr=link(p); mp_flush_token_list(mp, info(p));
15597 mp_free_node(mp, p,loop_node_size);
15600 @ Now that we know all about loop control, we can finish up
15601 the missing portion of |begin_iteration| and we'll be done.
15603 The following code is performed after the `\.=' has been scanned in
15604 a \&{for} construction (if |m=expr_base|) or a \&{forsuffixes} construction
15605 (if |m=suffix_base|).
15607 @<Scan the values to be used in the loop@>=
15608 loop_type(s)=null; q=loop_list_loc(s); link(q)=null; /* |link(q)=loop_list(s)| */
15611 if ( m!=expr_base ) {
15612 mp_scan_suffix(mp);
15614 if ( mp->cur_cmd>=colon ) if ( mp->cur_cmd<=comma )
15616 mp_scan_expression(mp);
15617 if ( mp->cur_cmd==step_token ) if ( q==loop_list_loc(s) ) {
15618 @<Prepare for step-until construction and |break|@>;
15620 mp->cur_exp=mp_stash_cur_exp(mp);
15622 link(q)=mp_get_avail(mp); q=link(q);
15623 info(q)=mp->cur_exp; mp->cur_type=mp_vacuous;
15626 } while (mp->cur_cmd==comma)
15628 @ @<Prepare for step-until construction and |break|@>=
15630 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "initial value");
15631 pp=mp_get_node(mp, progression_node_size); value(pp)=mp->cur_exp;
15632 mp_get_x_next(mp); mp_scan_expression(mp);
15633 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "step size");
15634 step_size(pp)=mp->cur_exp;
15635 if ( mp->cur_cmd!=until_token ) {
15636 mp_missing_err(mp, "until");
15637 @.Missing `until'@>
15638 help2("I assume you meant to say `until' after `step'.")
15639 ("So I'll look for the final value and colon next.");
15642 mp_get_x_next(mp); mp_scan_expression(mp);
15643 if ( mp->cur_type!=mp_known ) mp_bad_for(mp, "final value");
15644 final_value(pp)=mp->cur_exp; loop_list(s)=pp;
15645 loop_type(s)=progression_flag;
15649 @ The last case is when we have just seen ``\&{within}'', and we need to
15650 parse a picture expression and prepare to iterate over it.
15652 @<Set up a picture iteration@>=
15653 { mp_get_x_next(mp);
15654 mp_scan_expression(mp);
15655 @<Make sure the current expression is a known picture@>;
15656 loop_type(s)=mp->cur_exp; mp->cur_type=mp_vacuous;
15657 q=link(dummy_loc(mp->cur_exp));
15659 if ( is_start_or_stop(q) )
15660 if ( mp_skip_1component(mp, q)==null ) q=link(q);
15664 @ @<Make sure the current expression is a known picture@>=
15665 if ( mp->cur_type!=mp_picture_type ) {
15666 mp_disp_err(mp, null,"Improper iteration spec has been replaced by nullpicture");
15667 help1("When you say `for x in p', p must be a known picture.");
15668 mp_put_get_flush_error(mp, mp_get_node(mp, edge_header_size));
15669 mp_init_edges(mp, mp->cur_exp); mp->cur_type=mp_picture_type;
15672 @* \[35] File names.
15673 It's time now to fret about file names. Besides the fact that different
15674 operating systems treat files in different ways, we must cope with the
15675 fact that completely different naming conventions are used by different
15676 groups of people. The following programs show what is required for one
15677 particular operating system; similar routines for other systems are not
15678 difficult to devise.
15679 @^system dependencies@>
15681 \MP\ assumes that a file name has three parts: the name proper; its
15682 ``extension''; and a ``file area'' where it is found in an external file
15683 system. The extension of an input file is assumed to be
15684 `\.{.mp}' unless otherwise specified; it is `\.{.log}' on the
15685 transcript file that records each run of \MP; it is `\.{.tfm}' on the font
15686 metric files that describe characters in any fonts created by \MP; it is
15687 `\.{.ps}' or `.{\it nnn}' for some number {\it nnn} on the \ps\ output files;
15688 and it is `\.{.mem}' on the mem files written by \.{INIMP} to initialize \MP.
15689 The file area can be arbitrary on input files, but files are usually
15690 output to the user's current area. If an input file cannot be
15691 found on the specified area, \MP\ will look for it on a special system
15692 area; this special area is intended for commonly used input files.
15694 Simple uses of \MP\ refer only to file names that have no explicit
15695 extension or area. For example, a person usually says `\.{input} \.{cmr10}'
15696 instead of `\.{input} \.{cmr10.new}'. Simple file
15697 names are best, because they make the \MP\ source files portable;
15698 whenever a file name consists entirely of letters and digits, it should be
15699 treated in the same way by all implementations of \MP. However, users
15700 need the ability to refer to other files in their environment, especially
15701 when responding to error messages concerning unopenable files; therefore
15702 we want to let them use the syntax that appears in their favorite
15705 @ \MP\ uses the same conventions that have proved to be satisfactory for
15706 \TeX\ and \MF. In order to isolate the system-dependent aspects of file names,
15707 @^system dependencies@>
15708 the system-independent parts of \MP\ are expressed in terms
15709 of three system-dependent
15710 procedures called |begin_name|, |more_name|, and |end_name|. In
15711 essence, if the user-specified characters of the file name are $c_1\ldots c_n$,
15712 the system-independent driver program does the operations
15713 $$|begin_name|;\,|more_name|(c_1);\,\ldots\,;\,|more_name|(c_n);
15715 These three procedures communicate with each other via global variables.
15716 Afterwards the file name will appear in the string pool as three strings
15717 called |cur_name|\penalty10000\hskip-.05em,
15718 |cur_area|, and |cur_ext|; the latter two are null (i.e.,
15719 |""|), unless they were explicitly specified by the user.
15721 Actually the situation is slightly more complicated, because \MP\ needs
15722 to know when the file name ends. The |more_name| routine is a function
15723 (with side effects) that returns |true| on the calls |more_name|$(c_1)$,
15724 \dots, |more_name|$(c_{n-1})$. The final call |more_name|$(c_n)$
15725 returns |false|; or, it returns |true| and $c_n$ is the last character
15726 on the current input line. In other words,
15727 |more_name| is supposed to return |true| unless it is sure that the
15728 file name has been completely scanned; and |end_name| is supposed to be able
15729 to finish the assembly of |cur_name|, |cur_area|, and |cur_ext| regardless of
15730 whether $|more_name|(c_n)$ returned |true| or |false|.
15733 char * cur_name; /* name of file just scanned */
15734 char * cur_area; /* file area just scanned, or \.{""} */
15735 char * cur_ext; /* file extension just scanned, or \.{""} */
15737 @ It is easier to maintain reference counts if we assign initial values.
15740 mp->cur_name=xstrdup("");
15741 mp->cur_area=xstrdup("");
15742 mp->cur_ext=xstrdup("");
15744 @ @<Dealloc variables@>=
15745 xfree(mp->cur_area);
15746 xfree(mp->cur_name);
15747 xfree(mp->cur_ext);
15749 @ The file names we shall deal with for illustrative purposes have the
15750 following structure: If the name contains `\.>' or `\.:', the file area
15751 consists of all characters up to and including the final such character;
15752 otherwise the file area is null. If the remaining file name contains
15753 `\..', the file extension consists of all such characters from the first
15754 remaining `\..' to the end, otherwise the file extension is null.
15755 @^system dependencies@>
15757 We can scan such file names easily by using two global variables that keep track
15758 of the occurrences of area and extension delimiters. Note that these variables
15759 cannot be of type |pool_pointer| because a string pool compaction could occur
15760 while scanning a file name.
15763 integer area_delimiter;
15764 /* most recent `\.>' or `\.:' relative to |str_start[str_ptr]| */
15765 integer ext_delimiter; /* the relevant `\..', if any */
15767 @ Here now is the first of the system-dependent routines for file name scanning.
15768 @^system dependencies@>
15770 The file name length is limited to |file_name_size|. That is good, because
15771 in the current configuration we cannot call |mp_do_compaction| while a name
15772 is being scanned, |mp->area_delimiter| and |mp->ext_delimiter| are direct
15773 offsets into |mp->str_pool|. I am not in a great hurry to fix this, because
15774 calling |str_room()| just once is more efficient anyway. TODO.
15776 @<Declare subroutines for parsing file names@>=
15777 void mp_begin_name (MP mp) {
15778 xfree(mp->cur_name);
15779 xfree(mp->cur_area);
15780 xfree(mp->cur_ext);
15781 mp->area_delimiter=-1;
15782 mp->ext_delimiter=-1;
15783 str_room(file_name_size);
15786 @ And here's the second.
15787 @^system dependencies@>
15789 @<Declare subroutines for parsing file names@>=
15790 boolean mp_more_name (MP mp, ASCII_code c) {
15794 if ( (c=='>')||(c==':') ) {
15795 mp->area_delimiter=mp->pool_ptr;
15796 mp->ext_delimiter=-1;
15797 } else if ( (c=='.')&&(mp->ext_delimiter<0) ) {
15798 mp->ext_delimiter=mp->pool_ptr;
15800 append_char(c); /* contribute |c| to the current string */
15806 @^system dependencies@>
15808 @d copy_pool_segment(A,B,C) {
15809 A = xmalloc(C+1,sizeof(char));
15810 strncpy(A,(char *)(mp->str_pool+B),C);
15813 @<Declare subroutines for parsing file names@>=
15814 void mp_end_name (MP mp) {
15815 pool_pointer s; /* length of area, name, and extension */
15818 s = mp->str_start[mp->str_ptr];
15819 if ( mp->area_delimiter<0 ) {
15820 mp->cur_area=xstrdup("");
15822 len = mp->area_delimiter-s;
15823 copy_pool_segment(mp->cur_area,s,len);
15826 if ( mp->ext_delimiter<0 ) {
15827 mp->cur_ext=xstrdup("");
15828 len = mp->pool_ptr-s;
15830 copy_pool_segment(mp->cur_ext,mp->ext_delimiter,(mp->pool_ptr-mp->ext_delimiter));
15831 len = mp->ext_delimiter-s;
15833 copy_pool_segment(mp->cur_name,s,len);
15834 mp->pool_ptr=s; /* don't need this partial string */
15837 @ Conversely, here is a routine that takes three strings and prints a file
15838 name that might have produced them. (The routine is system dependent, because
15839 some operating systems put the file area last instead of first.)
15840 @^system dependencies@>
15842 @<Basic printing...@>=
15843 void mp_print_file_name (MP mp, char * n, char * a, char * e) {
15844 mp_print(mp, a); mp_print(mp, n); mp_print(mp, e);
15847 @ Another system-dependent routine is needed to convert three internal
15849 to the |name_of_file| value that is used to open files. The present code
15850 allows both lowercase and uppercase letters in the file name.
15851 @^system dependencies@>
15853 @d append_to_name(A) { c=(A);
15854 if ( k<file_name_size ) {
15855 mp->name_of_file[k]=xchr(c);
15860 @<Declare subroutines for parsing file names@>=
15861 void mp_pack_file_name (MP mp, const char *n, const char *a, const char *e) {
15862 integer k; /* number of positions filled in |name_of_file| */
15863 ASCII_code c; /* character being packed */
15864 const char *j; /* a character index */
15868 for (j=a;*j;j++) { append_to_name(*j); }
15870 for (j=n;*j;j++) { append_to_name(*j); }
15872 for (j=e;*j;j++) { append_to_name(*j); }
15874 mp->name_of_file[k]=0;
15878 @ @<Internal library declarations@>=
15879 void mp_pack_file_name (MP mp, const char *n, const char *a, const char *e) ;
15881 @ @<Option variables@>=
15882 char *mem_name; /* for commandline */
15884 @ @<Find constant sizes@>=
15885 mp->mem_name = xstrdup(opt->mem_name);
15886 if (mp->mem_name) {
15887 int l = strlen(mp->mem_name);
15889 char *test = strstr(mp->mem_name,".mem");
15890 if (test == mp->mem_name+l-4) {
15897 @ @<Dealloc variables@>=
15898 xfree(mp->mem_name);
15900 @ This part of the program becomes active when a ``virgin'' \MP\ is
15901 trying to get going, just after the preliminary initialization, or
15902 when the user is substituting another mem file by typing `\.\&' after
15903 the initial `\.{**}' prompt. The buffer contains the first line of
15904 input in |buffer[loc..(last-1)]|, where |loc<last| and |buffer[loc]<>""|.
15907 boolean mp_open_mem_name (MP mp) ;
15908 boolean mp_open_mem_file (MP mp) ;
15911 boolean mp_open_mem_name (MP mp) {
15912 if (mp->mem_name!=NULL) {
15913 int l = strlen(mp->mem_name);
15914 char *s = xstrdup (mp->mem_name);
15916 char *test = strstr(s,".mem");
15917 if (test == NULL || test != s+l-4) {
15918 s = xrealloc (s, l+5, 1);
15919 strcat (s, ".mem");
15922 s = xrealloc (s, l+5, 1);
15923 strcat (s, ".mem");
15925 mp->mem_file = (mp->open_file)(mp,s, "r", mp_filetype_memfile);
15927 if ( mp->mem_file ) return true;
15931 boolean mp_open_mem_file (MP mp) {
15932 if (mp->mem_file != NULL)
15934 if (mp_open_mem_name(mp))
15936 if (mp_xstrcmp(mp->mem_name, "plain")) {
15938 wterm_ln("Sorry, I can\'t find that mem file; will try PLAIN.");
15939 @.Sorry, I can't find...@>
15941 /* now pull out all the stops: try for the system \.{plain} file */
15942 xfree(mp->mem_name);
15943 mp->mem_name = xstrdup("plain");
15944 if (mp_open_mem_name(mp))
15948 wterm_ln("I can\'t find the PLAIN mem file!");
15949 @.I can't find PLAIN...@>
15954 @ Operating systems often make it possible to determine the exact name (and
15955 possible version number) of a file that has been opened. The following routine,
15956 which simply makes a \MP\ string from the value of |name_of_file|, should
15957 ideally be changed to deduce the full name of file~|f|, which is the file
15958 most recently opened, if it is possible to do this.
15959 @^system dependencies@>
15962 #define mp_a_make_name_string(A,B) mp_make_name_string(A)
15963 #define mp_b_make_name_string(A,B) mp_make_name_string(A)
15964 #define mp_w_make_name_string(A,B) mp_make_name_string(A)
15967 str_number mp_make_name_string (MP mp) {
15968 int k; /* index into |name_of_file| */
15969 str_room(mp->name_length);
15970 for (k=0;k<mp->name_length;k++) {
15971 append_char(xord((int)mp->name_of_file[k]));
15973 return mp_make_string(mp);
15976 @ Now let's consider the ``driver''
15977 routines by which \MP\ deals with file names
15978 in a system-independent manner. First comes a procedure that looks for a
15979 file name in the input by taking the information from the input buffer.
15980 (We can't use |get_next|, because the conversion to tokens would
15981 destroy necessary information.)
15983 This procedure doesn't allow semicolons or percent signs to be part of
15984 file names, because of other conventions of \MP.
15985 {\sl The {\logos METAFONT\/}book} doesn't
15986 use semicolons or percents immediately after file names, but some users
15987 no doubt will find it natural to do so; therefore system-dependent
15988 changes to allow such characters in file names should probably
15989 be made with reluctance, and only when an entire file name that
15990 includes special characters is ``quoted'' somehow.
15991 @^system dependencies@>
15993 @c void mp_scan_file_name (MP mp) {
15995 while ( mp->buffer[loc]==' ' ) incr(loc);
15997 if ( (mp->buffer[loc]==';')||(mp->buffer[loc]=='%') ) break;
15998 if ( ! mp_more_name(mp, mp->buffer[loc]) ) break;
16004 @ Here is another version that takes its input from a string.
16006 @<Declare subroutines for parsing file names@>=
16007 void mp_str_scan_file (MP mp, str_number s) {
16008 pool_pointer p,q; /* current position and stopping point */
16010 p=mp->str_start[s]; q=str_stop(s);
16012 if ( ! mp_more_name(mp, mp->str_pool[p]) ) break;
16018 @ And one that reads from a |char*|.
16020 @<Declare subroutines for parsing file names@>=
16021 void mp_ptr_scan_file (MP mp, char *s) {
16022 char *p, *q; /* current position and stopping point */
16024 p=s; q=p+strlen(s);
16026 if ( ! mp_more_name(mp, *p)) break;
16033 @ The global variable |job_name| contains the file name that was first
16034 \&{input} by the user. This name is extended by `\.{.log}' and `\.{ps}' and
16035 `\.{.mem}' and `\.{.tfm}' in order to make the names of \MP's output files.
16038 boolean log_opened; /* has the transcript file been opened? */
16039 char *log_name; /* full name of the log file */
16041 @ @<Option variables@>=
16042 char *job_name; /* principal file name */
16044 @ Initially |job_name=NULL|; it becomes nonzero as soon as the true name is known.
16045 We have |job_name=NULL| if and only if the `\.{log}' file has not been opened,
16046 except of course for a short time just after |job_name| has become nonzero.
16048 @<Allocate or ...@>=
16049 mp->job_name=mp_xstrdup(mp, opt->job_name);
16050 if (opt->noninteractive && opt->ini_version) {
16051 if (mp->job_name == NULL)
16052 mp->job_name=mp_xstrdup(mp,mp->mem_name);
16053 if (mp->job_name != NULL) {
16054 int l = strlen(mp->job_name);
16056 char *test = strstr(mp->job_name,".mem");
16057 if (test == mp->job_name+l-4)
16062 mp->log_opened=false;
16064 @ @<Dealloc variables@>=
16065 xfree(mp->job_name);
16067 @ Here is a routine that manufactures the output file names, assuming that
16068 |job_name<>0|. It ignores and changes the current settings of |cur_area|
16071 @d pack_cur_name mp_pack_file_name(mp, mp->cur_name,mp->cur_area,mp->cur_ext)
16074 void mp_pack_job_name (MP mp, const char *s) ;
16077 void mp_pack_job_name (MP mp, const char *s) { /* |s = ".log"|, |".mem"|, |".ps"|, or .\\{nnn} */
16078 xfree(mp->cur_name); mp->cur_name=xstrdup(mp->job_name);
16079 xfree(mp->cur_area); mp->cur_area=xstrdup("");
16080 xfree(mp->cur_ext); mp->cur_ext=xstrdup(s);
16084 @ If some trouble arises when \MP\ tries to open a file, the following
16085 routine calls upon the user to supply another file name. Parameter~|s|
16086 is used in the error message to identify the type of file; parameter~|e|
16087 is the default extension if none is given. Upon exit from the routine,
16088 variables |cur_name|, |cur_area|, |cur_ext|, and |name_of_file| are
16089 ready for another attempt at file opening.
16092 void mp_prompt_file_name (MP mp, const char * s, const char * e) ;
16094 @ @c void mp_prompt_file_name (MP mp, const char * s, const char * e) {
16095 size_t k; /* index into |buffer| */
16096 char * saved_cur_name;
16097 if ( mp->interaction==mp_scroll_mode )
16099 if (strcmp(s,"input file name")==0) {
16100 print_err("I can\'t find file `");
16101 @.I can't find file x@>
16103 print_err("I can\'t write on file `");
16104 @.I can't write on file x@>
16106 mp_print_file_name(mp, mp->cur_name,mp->cur_area,mp->cur_ext);
16107 mp_print(mp, "'.");
16108 if (strcmp(e,"")==0)
16109 mp_show_context(mp);
16110 mp_print_nl(mp, "Please type another "); mp_print(mp, s);
16112 if (mp->noninteractive || mp->interaction<mp_scroll_mode )
16113 mp_fatal_error(mp, "*** (job aborted, file error in nonstop mode)");
16114 @.job aborted, file error...@>
16115 saved_cur_name = xstrdup(mp->cur_name);
16116 clear_terminal; prompt_input(": "); @<Scan file name in the buffer@>;
16117 if (strcmp(mp->cur_ext,"")==0)
16118 mp->cur_ext=xstrdup(e);
16119 if (strlen(mp->cur_name)==0) {
16120 mp->cur_name=saved_cur_name;
16122 xfree(saved_cur_name);
16127 @ @<Scan file name in the buffer@>=
16129 mp_begin_name(mp); k=mp->first;
16130 while ( (mp->buffer[k]==' ')&&(k<mp->last) ) incr(k);
16132 if ( k==mp->last ) break;
16133 if ( ! mp_more_name(mp, mp->buffer[k]) ) break;
16139 @ The |open_log_file| routine is used to open the transcript file and to help
16140 it catch up to what has previously been printed on the terminal.
16142 @c void mp_open_log_file (MP mp) {
16143 int old_setting; /* previous |selector| setting */
16144 int k; /* index into |months| and |buffer| */
16145 int l; /* end of first input line */
16146 integer m; /* the current month */
16147 const char *months="JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC";
16148 /* abbreviations of month names */
16149 old_setting=mp->selector;
16150 if ( mp->job_name==NULL ) {
16151 mp->job_name=xstrdup("mpout");
16153 mp_pack_job_name(mp,".log");
16154 while ( ! mp_a_open_out(mp, &mp->log_file, mp_filetype_log) ) {
16155 @<Try to get a different log file name@>;
16157 mp->log_name=xstrdup(mp->name_of_file);
16158 mp->selector=log_only; mp->log_opened=true;
16159 @<Print the banner line, including the date and time@>;
16160 mp->input_stack[mp->input_ptr]=mp->cur_input;
16161 /* make sure bottom level is in memory */
16162 if (!mp->noninteractive) {
16163 mp_print_nl(mp, "**");
16165 l=mp->input_stack[0].limit_field-1; /* last position of first line */
16166 for (k=0;k<=l;k++) mp_print_str(mp, mp->buffer[k]);
16167 mp_print_ln(mp); /* now the transcript file contains the first line of input */
16169 mp->selector=old_setting+2; /* |log_only| or |term_and_log| */
16172 @ @<Dealloc variables@>=
16173 xfree(mp->log_name);
16175 @ Sometimes |open_log_file| is called at awkward moments when \MP\ is
16176 unable to print error messages or even to |show_context|.
16177 The |prompt_file_name| routine can result in a |fatal_error|, but the |error|
16178 routine will not be invoked because |log_opened| will be false.
16180 The normal idea of |mp_batch_mode| is that nothing at all should be written
16181 on the terminal. However, in the unusual case that
16182 no log file could be opened, we make an exception and allow
16183 an explanatory message to be seen.
16185 Incidentally, the program always refers to the log file as a `\.{transcript
16186 file}', because some systems cannot use the extension `\.{.log}' for
16189 @<Try to get a different log file name@>=
16191 mp->selector=term_only;
16192 mp_prompt_file_name(mp, "transcript file name",".log");
16195 @ @<Print the banner...@>=
16198 mp_print(mp, mp->mem_ident); mp_print(mp, " ");
16199 mp_print_int(mp, mp_round_unscaled(mp, mp->internal[mp_day]));
16200 mp_print_char(mp, ' ');
16201 m=mp_round_unscaled(mp, mp->internal[mp_month]);
16202 for (k=3*m-3;k<3*m;k++) { wlog_chr(months[k]); }
16203 mp_print_char(mp, ' ');
16204 mp_print_int(mp, mp_round_unscaled(mp, mp->internal[mp_year]));
16205 mp_print_char(mp, ' ');
16206 m=mp_round_unscaled(mp, mp->internal[mp_time]);
16207 mp_print_dd(mp, m / 60); mp_print_char(mp, ':'); mp_print_dd(mp, m % 60);
16210 @ The |try_extension| function tries to open an input file determined by
16211 |cur_name|, |cur_area|, and the argument |ext|. It returns |false| if it
16212 can't find the file in |cur_area| or the appropriate system area.
16214 @c boolean mp_try_extension (MP mp, const char *ext) {
16215 mp_pack_file_name(mp, mp->cur_name,mp->cur_area, ext);
16216 in_name=xstrdup(mp->cur_name);
16217 in_area=xstrdup(mp->cur_area);
16218 if ( mp_a_open_in(mp, &cur_file, mp_filetype_program) ) {
16221 mp_pack_file_name(mp, mp->cur_name,NULL,ext);
16222 return mp_a_open_in(mp, &cur_file, mp_filetype_program);
16226 @ Let's turn now to the procedure that is used to initiate file reading
16227 when an `\.{input}' command is being processed.
16229 @c void mp_start_input (MP mp) { /* \MP\ will \.{input} something */
16230 char *fname = NULL;
16231 @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>;
16233 mp_begin_file_reading(mp); /* set up |cur_file| and new level of input */
16234 if ( strlen(mp->cur_ext)==0 ) {
16235 if ( mp_try_extension(mp, ".mp") ) break;
16236 else if ( mp_try_extension(mp, "") ) break;
16237 else if ( mp_try_extension(mp, ".mf") ) break;
16238 /* |else do_nothing; | */
16239 } else if ( mp_try_extension(mp, mp->cur_ext) ) {
16242 mp_end_file_reading(mp); /* remove the level that didn't work */
16243 mp_prompt_file_name(mp, "input file name","");
16245 name=mp_a_make_name_string(mp, cur_file);
16246 fname = xstrdup(mp->name_of_file);
16247 if ( mp->job_name==NULL ) {
16248 mp->job_name=xstrdup(mp->cur_name);
16249 mp_open_log_file(mp);
16250 } /* |open_log_file| doesn't |show_context|, so |limit|
16251 and |loc| needn't be set to meaningful values yet */
16252 if ( ((int)mp->term_offset+(int)strlen(fname)) > (mp->max_print_line-2)) mp_print_ln(mp);
16253 else if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_char(mp, ' ');
16254 mp_print_char(mp, '('); incr(mp->open_parens); mp_print(mp, fname);
16257 @<Flush |name| and replace it with |cur_name| if it won't be needed@>;
16258 @<Read the first line of the new file@>;
16261 @ This code should be omitted if |a_make_name_string| returns something other
16262 than just a copy of its argument and the full file name is needed for opening
16263 \.{MPX} files or implementing the switch-to-editor option.
16264 @^system dependencies@>
16266 @<Flush |name| and replace it with |cur_name| if it won't be needed@>=
16267 mp_flush_string(mp, name); name=rts(mp->cur_name); xfree(mp->cur_name)
16269 @ If the file is empty, it is considered to contain a single blank line,
16270 so there is no need to test the return value.
16272 @<Read the first line...@>=
16275 (void)mp_input_ln(mp, cur_file );
16276 mp_firm_up_the_line(mp);
16277 mp->buffer[limit]='%'; mp->first=limit+1; loc=start;
16280 @ @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>=
16281 while ( token_state &&(loc==null) ) mp_end_token_list(mp);
16282 if ( token_state ) {
16283 print_err("File names can't appear within macros");
16284 @.File names can't...@>
16285 help3("Sorry...I've converted what follows to tokens,")
16286 ("possibly garbaging the name you gave.")
16287 ("Please delete the tokens and insert the name again.");
16290 if ( file_state ) {
16291 mp_scan_file_name(mp);
16293 xfree(mp->cur_name); mp->cur_name=xstrdup("");
16294 xfree(mp->cur_ext); mp->cur_ext =xstrdup("");
16295 xfree(mp->cur_area); mp->cur_area=xstrdup("");
16298 @ The following simple routine starts reading the \.{MPX} file associated
16299 with the current input file.
16301 @c void mp_start_mpx_input (MP mp) {
16302 char *origname = NULL; /* a copy of nameoffile */
16303 mp_pack_file_name(mp, in_name, in_area, ".mpx");
16304 @<Try to make sure |name_of_file| refers to a valid \.{MPX} file and
16305 |goto not_found| if there is a problem@>;
16306 mp_begin_file_reading(mp);
16307 if ( ! mp_a_open_in(mp, &cur_file, mp_filetype_program) ) {
16308 mp_end_file_reading(mp);
16311 name=mp_a_make_name_string(mp, cur_file);
16312 mp->mpx_name[iindex]=name; add_str_ref(name);
16313 @<Read the first line of the new file@>;
16317 @<Explain that the \.{MPX} file can't be read and |succumb|@>;
16321 @ This should ideally be changed to do whatever is necessary to create the
16322 \.{MPX} file given by |name_of_file| if it does not exist or if it is out
16323 of date. This requires invoking \.{MPtoTeX} on the |origname| and passing
16324 the results through \TeX\ and \.{DVItoMP}. (It is possible to use a
16325 completely different typesetting program if suitable postprocessor is
16326 available to perform the function of \.{DVItoMP}.)
16327 @^system dependencies@>
16329 @ @<Exported types@>=
16330 typedef int (*mp_run_make_mpx_command)(MP mp, char *origname, char *mtxname);
16332 @ @<Option variables@>=
16333 mp_run_make_mpx_command run_make_mpx;
16335 @ @<Allocate or initialize ...@>=
16336 set_callback_option(run_make_mpx);
16338 @ @<Internal library declarations@>=
16339 int mp_run_make_mpx (MP mp, char *origname, char *mtxname);
16341 @ The default does nothing.
16343 int mp_run_make_mpx (MP mp, char *origname, char *mtxname) {
16350 @ @<Try to make sure |name_of_file| refers to a valid \.{MPX} file and
16351 |goto not_found| if there is a problem@>=
16352 origname = mp_xstrdup(mp,mp->name_of_file);
16353 *(origname+strlen(origname)-1)=0; /* drop the x */
16354 if (!(mp->run_make_mpx)(mp, origname, mp->name_of_file))
16357 @ @<Explain that the \.{MPX} file can't be read and |succumb|@>=
16358 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
16359 mp_print_nl(mp, ">> ");
16360 mp_print(mp, origname);
16361 mp_print_nl(mp, ">> ");
16362 mp_print(mp, mp->name_of_file);
16363 mp_print_nl(mp, "! Unable to make mpx file");
16364 help4("The two files given above are one of your source files")
16365 ("and an auxiliary file I need to read to find out what your")
16366 ("btex..etex blocks mean. If you don't know why I had trouble,")
16367 ("try running it manually through MPtoTeX, TeX, and DVItoMP");
16370 @ The last file-opening commands are for files accessed via the \&{readfrom}
16371 @:read_from_}{\&{readfrom} primitive@>
16372 operator and the \&{write} command. Such files are stored in separate arrays.
16373 @:write_}{\&{write} primitive@>
16375 @<Types in the outer block@>=
16376 typedef unsigned int readf_index; /* |0..max_read_files| */
16377 typedef unsigned int write_index; /* |0..max_write_files| */
16380 readf_index max_read_files; /* maximum number of simultaneously open \&{readfrom} files */
16381 void ** rd_file; /* \&{readfrom} files */
16382 char ** rd_fname; /* corresponding file name or 0 if file not open */
16383 readf_index read_files; /* number of valid entries in the above arrays */
16384 write_index max_write_files; /* maximum number of simultaneously open \&{write} */
16385 void ** wr_file; /* \&{write} files */
16386 char ** wr_fname; /* corresponding file name or 0 if file not open */
16387 write_index write_files; /* number of valid entries in the above arrays */
16389 @ @<Allocate or initialize ...@>=
16390 mp->max_read_files=8;
16391 mp->rd_file = xmalloc((mp->max_read_files+1),sizeof(void *));
16392 mp->rd_fname = xmalloc((mp->max_read_files+1),sizeof(char *));
16393 memset(mp->rd_fname, 0, sizeof(char *)*(mp->max_read_files+1));
16394 mp->max_write_files=8;
16395 mp->wr_file = xmalloc((mp->max_write_files+1),sizeof(void *));
16396 mp->wr_fname = xmalloc((mp->max_write_files+1),sizeof(char *));
16397 memset(mp->wr_fname, 0, sizeof(char *)*(mp->max_write_files+1));
16400 @ This routine starts reading the file named by string~|s| without setting
16401 |loc|, |limit|, or |name|. It returns |false| if the file is empty or cannot
16402 be opened. Otherwise it updates |rd_file[n]| and |rd_fname[n]|.
16404 @c boolean mp_start_read_input (MP mp,char *s, readf_index n) {
16405 mp_ptr_scan_file(mp, s);
16407 mp_begin_file_reading(mp);
16408 if ( ! mp_a_open_in(mp, &mp->rd_file[n], (mp_filetype_text+n)) )
16410 if ( ! mp_input_ln(mp, mp->rd_file[n] ) ) {
16411 (mp->close_file)(mp,mp->rd_file[n]);
16414 mp->rd_fname[n]=xstrdup(mp->name_of_file);
16417 mp_end_file_reading(mp);
16421 @ Open |wr_file[n]| using file name~|s| and update |wr_fname[n]|.
16424 void mp_open_write_file (MP mp, char *s, readf_index n) ;
16426 @ @c void mp_open_write_file (MP mp,char *s, readf_index n) {
16427 mp_ptr_scan_file(mp, s);
16429 while ( ! mp_a_open_out(mp, &mp->wr_file[n], (mp_filetype_text+n)) )
16430 mp_prompt_file_name(mp, "file name for write output","");
16431 mp->wr_fname[n]=xstrdup(mp->name_of_file);
16435 @* \[36] Introduction to the parsing routines.
16436 We come now to the central nervous system that sparks many of \MP's activities.
16437 By evaluating expressions, from their primary constituents to ever larger
16438 subexpressions, \MP\ builds the structures that ultimately define complete
16439 pictures or fonts of type.
16441 Four mutually recursive subroutines are involved in this process: We call them
16442 $$\hbox{|scan_primary|, |scan_secondary|, |scan_tertiary|,
16443 and |scan_expression|.}$$
16445 Each of them is parameterless and begins with the first token to be scanned
16446 already represented in |cur_cmd|, |cur_mod|, and |cur_sym|. After execution,
16447 the value of the primary or secondary or tertiary or expression that was
16448 found will appear in the global variables |cur_type| and |cur_exp|. The
16449 token following the expression will be represented in |cur_cmd|, |cur_mod|,
16452 Technically speaking, the parsing algorithms are ``LL(1),'' more or less;
16453 backup mechanisms have been added in order to provide reasonable error
16457 small_number cur_type; /* the type of the expression just found */
16458 integer cur_exp; /* the value of the expression just found */
16463 @ Many different kinds of expressions are possible, so it is wise to have
16464 precise descriptions of what |cur_type| and |cur_exp| mean in all cases:
16467 |cur_type=mp_vacuous| means that this expression didn't turn out to have a
16468 value at all, because it arose from a \&{begingroup}$\,\ldots\,$\&{endgroup}
16469 construction in which there was no expression before the \&{endgroup}.
16470 In this case |cur_exp| has some irrelevant value.
16473 |cur_type=mp_boolean_type| means that |cur_exp| is either |true_code|
16477 |cur_type=mp_unknown_boolean| means that |cur_exp| points to a capsule
16479 a ring of equivalent booleans whose value has not yet been defined.
16482 |cur_type=mp_string_type| means that |cur_exp| is a string number (i.e., an
16483 integer in the range |0<=cur_exp<str_ptr|). That string's reference count
16484 includes this particular reference.
16487 |cur_type=mp_unknown_string| means that |cur_exp| points to a capsule
16489 a ring of equivalent strings whose value has not yet been defined.
16492 |cur_type=mp_pen_type| means that |cur_exp| points to a node in a pen. Nobody
16493 else points to any of the nodes in this pen. The pen may be polygonal or
16497 |cur_type=mp_unknown_pen| means that |cur_exp| points to a capsule
16499 a ring of equivalent pens whose value has not yet been defined.
16502 |cur_type=mp_path_type| means that |cur_exp| points to a the first node of
16503 a path; nobody else points to this particular path. The control points of
16504 the path will have been chosen.
16507 |cur_type=mp_unknown_path| means that |cur_exp| points to a capsule
16509 a ring of equivalent paths whose value has not yet been defined.
16512 |cur_type=mp_picture_type| means that |cur_exp| points to an edge header node.
16513 There may be other pointers to this particular set of edges. The header node
16514 contains a reference count that includes this particular reference.
16517 |cur_type=mp_unknown_picture| means that |cur_exp| points to a capsule
16519 a ring of equivalent pictures whose value has not yet been defined.
16522 |cur_type=mp_transform_type| means that |cur_exp| points to a |mp_transform_type|
16523 capsule node. The |value| part of this capsule
16524 points to a transform node that contains six numeric values,
16525 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16528 |cur_type=mp_color_type| means that |cur_exp| points to a |color_type|
16529 capsule node. The |value| part of this capsule
16530 points to a color node that contains three numeric values,
16531 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16534 |cur_type=mp_cmykcolor_type| means that |cur_exp| points to a |mp_cmykcolor_type|
16535 capsule node. The |value| part of this capsule
16536 points to a color node that contains four numeric values,
16537 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16540 |cur_type=mp_pair_type| means that |cur_exp| points to a capsule
16541 node whose type is |mp_pair_type|. The |value| part of this capsule
16542 points to a pair node that contains two numeric values,
16543 each of which is |independent|, |dependent|, |mp_proto_dependent|, or |known|.
16546 |cur_type=mp_known| means that |cur_exp| is a |scaled| value.
16549 |cur_type=mp_dependent| means that |cur_exp| points to a capsule node whose type
16550 is |dependent|. The |dep_list| field in this capsule points to the associated
16554 |cur_type=mp_proto_dependent| means that |cur_exp| points to a |mp_proto_dependent|
16555 capsule node. The |dep_list| field in this capsule
16556 points to the associated dependency list.
16559 |cur_type=independent| means that |cur_exp| points to a capsule node
16560 whose type is |independent|. This somewhat unusual case can arise, for
16561 example, in the expression
16562 `$x+\&{begingroup}\penalty0\,\&{string}\,x; 0\,\&{endgroup}$'.
16565 |cur_type=mp_token_list| means that |cur_exp| points to a linked list of
16568 \smallskip\noindent
16569 The possible settings of |cur_type| have been listed here in increasing
16570 numerical order. Notice that |cur_type| will never be |mp_numeric_type| or
16571 |suffixed_macro| or |mp_unsuffixed_macro|, although variables of those types
16572 are allowed. Conversely, \MP\ has no variables of type |mp_vacuous| or
16575 @ Capsules are two-word nodes that have a similar meaning
16576 to |cur_type| and |cur_exp|. Such nodes have |name_type=capsule|,
16577 and their |type| field is one of the possibilities for |cur_type| listed above.
16578 Also |link<=void| in capsules that aren't part of a token list.
16580 The |value| field of a capsule is, in most cases, the value that
16581 corresponds to its |type|, as |cur_exp| corresponds to |cur_type|.
16582 However, when |cur_exp| would point to a capsule,
16583 no extra layer of indirection is present; the |value|
16584 field is what would have been called |value(cur_exp)| if it had not been
16585 encapsulated. Furthermore, if the type is |dependent| or
16586 |mp_proto_dependent|, the |value| field of a capsule is replaced by
16587 |dep_list| and |prev_dep| fields, since dependency lists in capsules are
16588 always part of the general |dep_list| structure.
16590 The |get_x_next| routine is careful not to change the values of |cur_type|
16591 and |cur_exp| when it gets an expanded token. However, |get_x_next| might
16592 call a macro, which might parse an expression, which might execute lots of
16593 commands in a group; hence it's possible that |cur_type| might change
16594 from, say, |mp_unknown_boolean| to |mp_boolean_type|, or from |dependent| to
16595 |known| or |independent|, during the time |get_x_next| is called. The
16596 programs below are careful to stash sensitive intermediate results in
16597 capsules, so that \MP's generality doesn't cause trouble.
16599 Here's a procedure that illustrates these conventions. It takes
16600 the contents of $(|cur_type|\kern-.3pt,|cur_exp|\kern-.3pt)$
16601 and stashes them away in a
16602 capsule. It is not used when |cur_type=mp_token_list|.
16603 After the operation, |cur_type=mp_vacuous|; hence there is no need to
16604 copy path lists or to update reference counts, etc.
16606 The special link |mp_void| is put on the capsule returned by
16607 |stash_cur_exp|, because this procedure is used to store macro parameters
16608 that must be easily distinguishable from token lists.
16610 @<Declare the stashing/unstashing routines@>=
16611 pointer mp_stash_cur_exp (MP mp) {
16612 pointer p; /* the capsule that will be returned */
16613 switch (mp->cur_type) {
16614 case unknown_types:
16615 case mp_transform_type:
16616 case mp_color_type:
16619 case mp_proto_dependent:
16620 case mp_independent:
16621 case mp_cmykcolor_type:
16625 p=mp_get_node(mp, value_node_size); name_type(p)=mp_capsule;
16626 type(p)=mp->cur_type; value(p)=mp->cur_exp;
16629 mp->cur_type=mp_vacuous; link(p)=mp_void;
16633 @ The inverse of |stash_cur_exp| is the following procedure, which
16634 deletes an unnecessary capsule and puts its contents into |cur_type|
16637 The program steps of \MP\ can be divided into two categories: those in
16638 which |cur_type| and |cur_exp| are ``alive'' and those in which they are
16639 ``dead,'' in the sense that |cur_type| and |cur_exp| contain relevant
16640 information or not. It's important not to ignore them when they're alive,
16641 and it's important not to pay attention to them when they're dead.
16643 There's also an intermediate category: If |cur_type=mp_vacuous|, then
16644 |cur_exp| is irrelevant, hence we can proceed without caring if |cur_type|
16645 and |cur_exp| are alive or dead. In such cases we say that |cur_type|
16646 and |cur_exp| are {\sl dormant}. It is permissible to call |get_x_next|
16647 only when they are alive or dormant.
16649 The \\{stash} procedure above assumes that |cur_type| and |cur_exp|
16650 are alive or dormant. The \\{unstash} procedure assumes that they are
16651 dead or dormant; it resuscitates them.
16653 @<Declare the stashing/unstashing...@>=
16654 void mp_unstash_cur_exp (MP mp,pointer p) ;
16657 void mp_unstash_cur_exp (MP mp,pointer p) {
16658 mp->cur_type=type(p);
16659 switch (mp->cur_type) {
16660 case unknown_types:
16661 case mp_transform_type:
16662 case mp_color_type:
16665 case mp_proto_dependent:
16666 case mp_independent:
16667 case mp_cmykcolor_type:
16671 mp->cur_exp=value(p);
16672 mp_free_node(mp, p,value_node_size);
16677 @ The following procedure prints the values of expressions in an
16678 abbreviated format. If its first parameter |p| is null, the value of
16679 |(cur_type,cur_exp)| is displayed; otherwise |p| should be a capsule
16680 containing the desired value. The second parameter controls the amount of
16681 output. If it is~0, dependency lists will be abbreviated to
16682 `\.{linearform}' unless they consist of a single term. If it is greater
16683 than~1, complicated structures (pens, pictures, and paths) will be displayed
16687 @<Declare subroutines for printing expressions@>=
16688 @<Declare the procedure called |print_dp|@>
16689 @<Declare the stashing/unstashing routines@>
16690 void mp_print_exp (MP mp,pointer p, small_number verbosity) {
16691 boolean restore_cur_exp; /* should |cur_exp| be restored? */
16692 small_number t; /* the type of the expression */
16693 pointer q; /* a big node being displayed */
16694 integer v=0; /* the value of the expression */
16696 restore_cur_exp=false;
16698 p=mp_stash_cur_exp(mp); restore_cur_exp=true;
16701 if ( t<mp_dependent ) v=value(p); else if ( t<mp_independent ) v=dep_list(p);
16702 @<Print an abbreviated value of |v| with format depending on |t|@>;
16703 if ( restore_cur_exp ) mp_unstash_cur_exp(mp, p);
16706 @ @<Print an abbreviated value of |v| with format depending on |t|@>=
16708 case mp_vacuous:mp_print(mp, "mp_vacuous"); break;
16709 case mp_boolean_type:
16710 if ( v==true_code ) mp_print(mp, "true"); else mp_print(mp, "false");
16712 case unknown_types: case mp_numeric_type:
16713 @<Display a variable that's been declared but not defined@>;
16715 case mp_string_type:
16716 mp_print_char(mp, '"'); mp_print_str(mp, v); mp_print_char(mp, '"');
16718 case mp_pen_type: case mp_path_type: case mp_picture_type:
16719 @<Display a complex type@>;
16721 case mp_transform_type: case mp_color_type: case mp_pair_type: case mp_cmykcolor_type:
16722 if ( v==null ) mp_print_type(mp, t);
16723 else @<Display a big node@>;
16725 case mp_known:mp_print_scaled(mp, v); break;
16726 case mp_dependent: case mp_proto_dependent:
16727 mp_print_dp(mp, t,v,verbosity);
16729 case mp_independent:mp_print_variable_name(mp, p); break;
16730 default: mp_confusion(mp, "exp"); break;
16731 @:this can't happen exp}{\quad exp@>
16734 @ @<Display a big node@>=
16736 mp_print_char(mp, '('); q=v+mp->big_node_size[t];
16738 if ( type(v)==mp_known ) mp_print_scaled(mp, value(v));
16739 else if ( type(v)==mp_independent ) mp_print_variable_name(mp, v);
16740 else mp_print_dp(mp, type(v),dep_list(v),verbosity);
16742 if ( v!=q ) mp_print_char(mp, ',');
16744 mp_print_char(mp, ')');
16747 @ Values of type \&{picture}, \&{path}, and \&{pen} are displayed verbosely
16748 in the log file only, unless the user has given a positive value to
16751 @<Display a complex type@>=
16752 if ( verbosity<=1 ) {
16753 mp_print_type(mp, t);
16755 if ( mp->selector==term_and_log )
16756 if ( mp->internal[mp_tracing_online]<=0 ) {
16757 mp->selector=term_only;
16758 mp_print_type(mp, t); mp_print(mp, " (see the transcript file)");
16759 mp->selector=term_and_log;
16762 case mp_pen_type:mp_print_pen(mp, v,"",false); break;
16763 case mp_path_type:mp_print_path(mp, v,"",false); break;
16764 case mp_picture_type:mp_print_edges(mp, v,"",false); break;
16765 } /* there are no other cases */
16768 @ @<Declare the procedure called |print_dp|@>=
16769 void mp_print_dp (MP mp,small_number t, pointer p,
16770 small_number verbosity) {
16771 pointer q; /* the node following |p| */
16773 if ( (info(q)==null) || (verbosity>0) ) mp_print_dependency(mp, p,t);
16774 else mp_print(mp, "linearform");
16777 @ The displayed name of a variable in a ring will not be a capsule unless
16778 the ring consists entirely of capsules.
16780 @<Display a variable that's been declared but not defined@>=
16781 { mp_print_type(mp, t);
16783 { mp_print_char(mp, ' ');
16784 while ( (name_type(v)==mp_capsule) && (v!=p) ) v=value(v);
16785 mp_print_variable_name(mp, v);
16789 @ When errors are detected during parsing, it is often helpful to
16790 display an expression just above the error message, using |exp_err|
16791 or |disp_err| instead of |print_err|.
16793 @d exp_err(A) mp_disp_err(mp, null,(A)) /* displays the current expression */
16795 @<Declare subroutines for printing expressions@>=
16796 void mp_disp_err (MP mp,pointer p, const char *s) {
16797 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
16798 mp_print_nl(mp, ">> ");
16800 mp_print_exp(mp, p,1); /* ``medium verbose'' printing of the expression */
16802 mp_print_nl(mp, "! "); mp_print(mp, s);
16807 @ If |cur_type| and |cur_exp| contain relevant information that should
16808 be recycled, we will use the following procedure, which changes |cur_type|
16809 to |known| and stores a given value in |cur_exp|. We can think of |cur_type|
16810 and |cur_exp| as either alive or dormant after this has been done,
16811 because |cur_exp| will not contain a pointer value.
16813 @ @c void mp_flush_cur_exp (MP mp,scaled v) {
16814 switch (mp->cur_type) {
16815 case unknown_types: case mp_transform_type: case mp_color_type: case mp_pair_type:
16816 case mp_dependent: case mp_proto_dependent: case mp_independent: case mp_cmykcolor_type:
16817 mp_recycle_value(mp, mp->cur_exp);
16818 mp_free_node(mp, mp->cur_exp,value_node_size);
16820 case mp_string_type:
16821 delete_str_ref(mp->cur_exp); break;
16822 case mp_pen_type: case mp_path_type:
16823 mp_toss_knot_list(mp, mp->cur_exp); break;
16824 case mp_picture_type:
16825 delete_edge_ref(mp->cur_exp); break;
16829 mp->cur_type=mp_known; mp->cur_exp=v;
16832 @ There's a much more general procedure that is capable of releasing
16833 the storage associated with any two-word value packet.
16835 @<Declare the recycling subroutines@>=
16836 void mp_recycle_value (MP mp,pointer p) ;
16838 @ @c void mp_recycle_value (MP mp,pointer p) {
16839 small_number t; /* a type code */
16840 integer vv; /* another value */
16841 pointer q,r,s,pp; /* link manipulation registers */
16842 integer v=0; /* a value */
16844 if ( t<mp_dependent ) v=value(p);
16846 case undefined: case mp_vacuous: case mp_boolean_type: case mp_known:
16847 case mp_numeric_type:
16849 case unknown_types:
16850 mp_ring_delete(mp, p); break;
16851 case mp_string_type:
16852 delete_str_ref(v); break;
16853 case mp_path_type: case mp_pen_type:
16854 mp_toss_knot_list(mp, v); break;
16855 case mp_picture_type:
16856 delete_edge_ref(v); break;
16857 case mp_cmykcolor_type: case mp_pair_type: case mp_color_type:
16858 case mp_transform_type:
16859 @<Recycle a big node@>; break;
16860 case mp_dependent: case mp_proto_dependent:
16861 @<Recycle a dependency list@>; break;
16862 case mp_independent:
16863 @<Recycle an independent variable@>; break;
16864 case mp_token_list: case mp_structured:
16865 mp_confusion(mp, "recycle"); break;
16866 @:this can't happen recycle}{\quad recycle@>
16867 case mp_unsuffixed_macro: case mp_suffixed_macro:
16868 mp_delete_mac_ref(mp, value(p)); break;
16869 } /* there are no other cases */
16873 @ @<Recycle a big node@>=
16875 q=v+mp->big_node_size[t];
16877 q=q-2; mp_recycle_value(mp, q);
16879 mp_free_node(mp, v,mp->big_node_size[t]);
16882 @ @<Recycle a dependency list@>=
16885 while ( info(q)!=null ) q=link(q);
16886 link(prev_dep(p))=link(q);
16887 prev_dep(link(q))=prev_dep(p);
16888 link(q)=null; mp_flush_node_list(mp, dep_list(p));
16891 @ When an independent variable disappears, it simply fades away, unless
16892 something depends on it. In the latter case, a dependent variable whose
16893 coefficient of dependence is maximal will take its place.
16894 The relevant algorithm is due to Ignacio~A. Zabala, who implemented it
16895 as part of his Ph.D. thesis (Stanford University, December 1982).
16896 @^Zabala Salelles, Ignacio Andr\'es@>
16898 For example, suppose that variable $x$ is being recycled, and that the
16899 only variables depending on~$x$ are $y=2x+a$ and $z=x+b$. In this case
16900 we want to make $y$ independent and $z=.5y-.5a+b$; no other variables
16901 will depend on~$y$. If $\\{tracingequations}>0$ in this situation,
16902 we will print `\.{\#\#\# -2x=-y+a}'.
16904 There's a slight complication, however: An independent variable $x$
16905 can occur both in dependency lists and in proto-dependency lists.
16906 This makes it necessary to be careful when deciding which coefficient
16909 Furthermore, this complication is not so slight when
16910 a proto-dependent variable is chosen to become independent. For example,
16911 suppose that $y=2x+100a$ is proto-dependent while $z=x+b$ is dependent;
16912 then we must change $z=.5y-50a+b$ to a proto-dependency, because of the
16913 large coefficient `50'.
16915 In order to deal with these complications without wasting too much time,
16916 we shall link together the occurrences of~$x$ among all the linear
16917 dependencies, maintaining separate lists for the dependent and
16918 proto-dependent cases.
16920 @<Recycle an independent variable@>=
16922 mp->max_c[mp_dependent]=0; mp->max_c[mp_proto_dependent]=0;
16923 mp->max_link[mp_dependent]=null; mp->max_link[mp_proto_dependent]=null;
16925 while ( q!=dep_head ) {
16926 s=value_loc(q); /* now |link(s)=dep_list(q)| */
16929 if ( info(r)==null ) break;
16930 if ( info(r)!=p ) {
16933 t=type(q); link(s)=link(r); info(r)=q;
16934 if ( abs(value(r))>mp->max_c[t] ) {
16935 @<Record a new maximum coefficient of type |t|@>;
16937 link(r)=mp->max_link[t]; mp->max_link[t]=r;
16943 if ( (mp->max_c[mp_dependent]>0)||(mp->max_c[mp_proto_dependent]>0) ) {
16944 @<Choose a dependent variable to take the place of the disappearing
16945 independent variable, and change all remaining dependencies
16950 @ The code for independency removal makes use of three two-word arrays.
16953 integer max_c[mp_proto_dependent+1]; /* max coefficient magnitude */
16954 pointer max_ptr[mp_proto_dependent+1]; /* where |p| occurs with |max_c| */
16955 pointer max_link[mp_proto_dependent+1]; /* other occurrences of |p| */
16957 @ @<Record a new maximum coefficient...@>=
16959 if ( mp->max_c[t]>0 ) {
16960 link(mp->max_ptr[t])=mp->max_link[t]; mp->max_link[t]=mp->max_ptr[t];
16962 mp->max_c[t]=abs(value(r)); mp->max_ptr[t]=r;
16965 @ @<Choose a dependent...@>=
16967 if ( (mp->max_c[mp_dependent] / 010000) >= mp->max_c[mp_proto_dependent] )
16970 t=mp_proto_dependent;
16971 @<Determine the dependency list |s| to substitute for the independent
16973 t=mp_dependent+mp_proto_dependent-t; /* complement |t| */
16974 if ( mp->max_c[t]>0 ) { /* we need to pick up an unchosen dependency */
16975 link(mp->max_ptr[t])=mp->max_link[t]; mp->max_link[t]=mp->max_ptr[t];
16977 if ( t!=mp_dependent ) { @<Substitute new dependencies in place of |p|@>; }
16978 else { @<Substitute new proto-dependencies in place of |p|@>;}
16979 mp_flush_node_list(mp, s);
16980 if ( mp->fix_needed ) mp_fix_dependencies(mp);
16984 @ Let |s=max_ptr[t]|. At this point we have $|value|(s)=\pm|max_c|[t]$,
16985 and |info(s)| points to the dependent variable~|pp| of type~|t| from
16986 whose dependency list we have removed node~|s|. We must reinsert
16987 node~|s| into the dependency list, with coefficient $-1.0$, and with
16988 |pp| as the new independent variable. Since |pp| will have a larger serial
16989 number than any other variable, we can put node |s| at the head of the
16992 @<Determine the dep...@>=
16993 s=mp->max_ptr[t]; pp=info(s); v=value(s);
16994 if ( t==mp_dependent ) value(s)=-fraction_one; else value(s)=-unity;
16995 r=dep_list(pp); link(s)=r;
16996 while ( info(r)!=null ) r=link(r);
16997 q=link(r); link(r)=null;
16998 prev_dep(q)=prev_dep(pp); link(prev_dep(pp))=q;
17000 if ( mp->cur_exp==pp ) if ( mp->cur_type==t ) mp->cur_type=mp_independent;
17001 if ( mp->internal[mp_tracing_equations]>0 ) {
17002 @<Show the transformed dependency@>;
17005 @ Now $(-v)$ times the formerly independent variable~|p| is being replaced
17006 by the dependency list~|s|.
17008 @<Show the transformed...@>=
17009 if ( mp_interesting(mp, p) ) {
17010 mp_begin_diagnostic(mp); mp_print_nl(mp, "### ");
17011 @:]]]\#\#\#_}{\.{\#\#\#}@>
17012 if ( v>0 ) mp_print_char(mp, '-');
17013 if ( t==mp_dependent ) vv=mp_round_fraction(mp, mp->max_c[mp_dependent]);
17014 else vv=mp->max_c[mp_proto_dependent];
17015 if ( vv!=unity ) mp_print_scaled(mp, vv);
17016 mp_print_variable_name(mp, p);
17017 while ( value(p) % s_scale>0 ) {
17018 mp_print(mp, "*4"); value(p)=value(p)-2;
17020 if ( t==mp_dependent ) mp_print_char(mp, '='); else mp_print(mp, " = ");
17021 mp_print_dependency(mp, s,t);
17022 mp_end_diagnostic(mp, false);
17025 @ Finally, there are dependent and proto-dependent variables whose
17026 dependency lists must be brought up to date.
17028 @<Substitute new dependencies...@>=
17029 for (t=mp_dependent;t<=mp_proto_dependent;t++){
17031 while ( r!=null ) {
17033 dep_list(q)=mp_p_plus_fq(mp, dep_list(q),
17034 mp_make_fraction(mp, value(r),-v),s,t,mp_dependent);
17035 if ( dep_list(q)==mp->dep_final ) mp_make_known(mp, q,mp->dep_final);
17036 q=r; r=link(r); mp_free_node(mp, q,dep_node_size);
17040 @ @<Substitute new proto...@>=
17041 for (t=mp_dependent;t<=mp_proto_dependent;t++) {
17043 while ( r!=null ) {
17045 if ( t==mp_dependent ) { /* for safety's sake, we change |q| to |mp_proto_dependent| */
17046 if ( mp->cur_exp==q ) if ( mp->cur_type==mp_dependent )
17047 mp->cur_type=mp_proto_dependent;
17048 dep_list(q)=mp_p_over_v(mp, dep_list(q),unity,
17049 mp_dependent,mp_proto_dependent);
17050 type(q)=mp_proto_dependent;
17051 value(r)=mp_round_fraction(mp, value(r));
17053 dep_list(q)=mp_p_plus_fq(mp, dep_list(q),
17054 mp_make_scaled(mp, value(r),-v),s,
17055 mp_proto_dependent,mp_proto_dependent);
17056 if ( dep_list(q)==mp->dep_final )
17057 mp_make_known(mp, q,mp->dep_final);
17058 q=r; r=link(r); mp_free_node(mp, q,dep_node_size);
17062 @ Here are some routines that provide handy combinations of actions
17063 that are often needed during error recovery. For example,
17064 `|flush_error|' flushes the current expression, replaces it by
17065 a given value, and calls |error|.
17067 Errors often are detected after an extra token has already been scanned.
17068 The `\\{put\_get}' routines put that token back before calling |error|;
17069 then they get it back again. (Or perhaps they get another token, if
17070 the user has changed things.)
17073 void mp_flush_error (MP mp,scaled v);
17074 void mp_put_get_error (MP mp);
17075 void mp_put_get_flush_error (MP mp,scaled v) ;
17078 void mp_flush_error (MP mp,scaled v) {
17079 mp_error(mp); mp_flush_cur_exp(mp, v);
17081 void mp_put_get_error (MP mp) {
17082 mp_back_error(mp); mp_get_x_next(mp);
17084 void mp_put_get_flush_error (MP mp,scaled v) {
17085 mp_put_get_error(mp);
17086 mp_flush_cur_exp(mp, v);
17089 @ A global variable |var_flag| is set to a special command code
17090 just before \MP\ calls |scan_expression|, if the expression should be
17091 treated as a variable when this command code immediately follows. For
17092 example, |var_flag| is set to |assignment| at the beginning of a
17093 statement, because we want to know the {\sl location\/} of a variable at
17094 the left of `\.{:=}', not the {\sl value\/} of that variable.
17096 The |scan_expression| subroutine calls |scan_tertiary|,
17097 which calls |scan_secondary|, which calls |scan_primary|, which sets
17098 |var_flag:=0|. In this way each of the scanning routines ``knows''
17099 when it has been called with a special |var_flag|, but |var_flag| is
17102 A variable preceding a command that equals |var_flag| is converted to a
17103 token list rather than a value. Furthermore, an `\.{=}' sign following an
17104 expression with |var_flag=assignment| is not considered to be a relation
17105 that produces boolean expressions.
17109 int var_flag; /* command that wants a variable */
17114 @* \[37] Parsing primary expressions.
17115 The first parsing routine, |scan_primary|, is also the most complicated one,
17116 since it involves so many different cases. But each case---with one
17117 exception---is fairly simple by itself.
17119 When |scan_primary| begins, the first token of the primary to be scanned
17120 should already appear in |cur_cmd|, |cur_mod|, and |cur_sym|. The values
17121 of |cur_type| and |cur_exp| should be either dead or dormant, as explained
17122 earlier. If |cur_cmd| is not between |min_primary_command| and
17123 |max_primary_command|, inclusive, a syntax error will be signaled.
17125 @<Declare the basic parsing subroutines@>=
17126 void mp_scan_primary (MP mp) {
17127 pointer p,q,r; /* for list manipulation */
17128 quarterword c; /* a primitive operation code */
17129 int my_var_flag; /* initial value of |my_var_flag| */
17130 pointer l_delim,r_delim; /* hash addresses of a delimiter pair */
17131 @<Other local variables for |scan_primary|@>;
17132 my_var_flag=mp->var_flag; mp->var_flag=0;
17135 @<Supply diagnostic information, if requested@>;
17136 switch (mp->cur_cmd) {
17137 case left_delimiter:
17138 @<Scan a delimited primary@>; break;
17140 @<Scan a grouped primary@>; break;
17142 @<Scan a string constant@>; break;
17143 case numeric_token:
17144 @<Scan a primary that starts with a numeric token@>; break;
17146 @<Scan a nullary operation@>; break;
17147 case unary: case type_name: case cycle: case plus_or_minus:
17148 @<Scan a unary operation@>; break;
17149 case primary_binary:
17150 @<Scan a binary operation with `\&{of}' between its operands@>; break;
17152 @<Convert a suffix to a string@>; break;
17153 case internal_quantity:
17154 @<Scan an internal numeric quantity@>; break;
17155 case capsule_token:
17156 mp_make_exp_copy(mp, mp->cur_mod); break;
17158 @<Scan a variable primary; |goto restart| if it turns out to be a macro@>; break;
17160 mp_bad_exp(mp, "A primary"); goto RESTART; break;
17161 @.A primary expression...@>
17163 mp_get_x_next(mp); /* the routines |goto done| if they don't want this */
17165 if ( mp->cur_cmd==left_bracket ) {
17166 if ( mp->cur_type>=mp_known ) {
17167 @<Scan a mediation construction@>;
17174 @ Errors at the beginning of expressions are flagged by |bad_exp|.
17176 @c void mp_bad_exp (MP mp, const char * s) {
17178 print_err(s); mp_print(mp, " expression can't begin with `");
17179 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod);
17180 mp_print_char(mp, '\'');
17181 help4("I'm afraid I need some sort of value in order to continue,")
17182 ("so I've tentatively inserted `0'. You may want to")
17183 ("delete this zero and insert something else;")
17184 ("see Chapter 27 of The METAFONTbook for an example.");
17185 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
17186 mp_back_input(mp); mp->cur_sym=0; mp->cur_cmd=numeric_token;
17187 mp->cur_mod=0; mp_ins_error(mp);
17188 save_flag=mp->var_flag; mp->var_flag=0; mp_get_x_next(mp);
17189 mp->var_flag=save_flag;
17192 @ @<Supply diagnostic information, if requested@>=
17194 if ( mp->panicking ) mp_check_mem(mp, false);
17196 if ( mp->interrupt!=0 ) if ( mp->OK_to_interrupt ) {
17197 mp_back_input(mp); check_interrupt; mp_get_x_next(mp);
17200 @ @<Scan a delimited primary@>=
17202 l_delim=mp->cur_sym; r_delim=mp->cur_mod;
17203 mp_get_x_next(mp); mp_scan_expression(mp);
17204 if ( (mp->cur_cmd==comma) && (mp->cur_type>=mp_known) ) {
17205 @<Scan the rest of a delimited set of numerics@>;
17207 mp_check_delimiter(mp, l_delim,r_delim);
17211 @ The |stash_in| subroutine puts the current (numeric) expression into a field
17212 within a ``big node.''
17214 @c void mp_stash_in (MP mp,pointer p) {
17215 pointer q; /* temporary register */
17216 type(p)=mp->cur_type;
17217 if ( mp->cur_type==mp_known ) {
17218 value(p)=mp->cur_exp;
17220 if ( mp->cur_type==mp_independent ) {
17221 @<Stash an independent |cur_exp| into a big node@>;
17223 mp->mem[value_loc(p)]=mp->mem[value_loc(mp->cur_exp)];
17224 /* |dep_list(p):=dep_list(cur_exp)| and |prev_dep(p):=prev_dep(cur_exp)| */
17225 link(prev_dep(p))=p;
17227 mp_free_node(mp, mp->cur_exp,value_node_size);
17229 mp->cur_type=mp_vacuous;
17232 @ In rare cases the current expression can become |independent|. There
17233 may be many dependency lists pointing to such an independent capsule,
17234 so we can't simply move it into place within a big node. Instead,
17235 we copy it, then recycle it.
17237 @ @<Stash an independent |cur_exp|...@>=
17239 q=mp_single_dependency(mp, mp->cur_exp);
17240 if ( q==mp->dep_final ){
17241 type(p)=mp_known; value(p)=0; mp_free_node(mp, q,dep_node_size);
17243 type(p)=mp_dependent; mp_new_dep(mp, p,q);
17245 mp_recycle_value(mp, mp->cur_exp);
17248 @ This code uses the fact that |red_part_loc| and |green_part_loc|
17249 are synonymous with |x_part_loc| and |y_part_loc|.
17251 @<Scan the rest of a delimited set of numerics@>=
17253 p=mp_stash_cur_exp(mp);
17254 mp_get_x_next(mp); mp_scan_expression(mp);
17255 @<Make sure the second part of a pair or color has a numeric type@>;
17256 q=mp_get_node(mp, value_node_size); name_type(q)=mp_capsule;
17257 if ( mp->cur_cmd==comma ) type(q)=mp_color_type;
17258 else type(q)=mp_pair_type;
17259 mp_init_big_node(mp, q); r=value(q);
17260 mp_stash_in(mp, y_part_loc(r));
17261 mp_unstash_cur_exp(mp, p);
17262 mp_stash_in(mp, x_part_loc(r));
17263 if ( mp->cur_cmd==comma ) {
17264 @<Scan the last of a triplet of numerics@>;
17266 if ( mp->cur_cmd==comma ) {
17267 type(q)=mp_cmykcolor_type;
17268 mp_init_big_node(mp, q); t=value(q);
17269 mp->mem[cyan_part_loc(t)]=mp->mem[red_part_loc(r)];
17270 value(cyan_part_loc(t))=value(red_part_loc(r));
17271 mp->mem[magenta_part_loc(t)]=mp->mem[green_part_loc(r)];
17272 value(magenta_part_loc(t))=value(green_part_loc(r));
17273 mp->mem[yellow_part_loc(t)]=mp->mem[blue_part_loc(r)];
17274 value(yellow_part_loc(t))=value(blue_part_loc(r));
17275 mp_recycle_value(mp, r);
17277 @<Scan the last of a quartet of numerics@>;
17279 mp_check_delimiter(mp, l_delim,r_delim);
17280 mp->cur_type=type(q);
17284 @ @<Make sure the second part of a pair or color has a numeric type@>=
17285 if ( mp->cur_type<mp_known ) {
17286 exp_err("Nonnumeric ypart has been replaced by 0");
17287 @.Nonnumeric...replaced by 0@>
17288 help4("I've started to scan a pair `(a,b)' or a color `(a,b,c)';")
17289 ("but after finding a nice `a' I found a `b' that isn't")
17290 ("of numeric type. So I've changed that part to zero.")
17291 ("(The b that I didn't like appears above the error message.)");
17292 mp_put_get_flush_error(mp, 0);
17295 @ @<Scan the last of a triplet of numerics@>=
17297 mp_get_x_next(mp); mp_scan_expression(mp);
17298 if ( mp->cur_type<mp_known ) {
17299 exp_err("Nonnumeric third part has been replaced by 0");
17300 @.Nonnumeric...replaced by 0@>
17301 help3("I've just scanned a color `(a,b,c)' or cmykcolor(a,b,c,d); but the `c'")
17302 ("isn't of numeric type. So I've changed that part to zero.")
17303 ("(The c that I didn't like appears above the error message.)");
17304 mp_put_get_flush_error(mp, 0);
17306 mp_stash_in(mp, blue_part_loc(r));
17309 @ @<Scan the last of a quartet of numerics@>=
17311 mp_get_x_next(mp); mp_scan_expression(mp);
17312 if ( mp->cur_type<mp_known ) {
17313 exp_err("Nonnumeric blackpart has been replaced by 0");
17314 @.Nonnumeric...replaced by 0@>
17315 help3("I've just scanned a cmykcolor `(c,m,y,k)'; but the `k' isn't")
17316 ("of numeric type. So I've changed that part to zero.")
17317 ("(The k that I didn't like appears above the error message.)");
17318 mp_put_get_flush_error(mp, 0);
17320 mp_stash_in(mp, black_part_loc(r));
17323 @ The local variable |group_line| keeps track of the line
17324 where a \&{begingroup} command occurred; this will be useful
17325 in an error message if the group doesn't actually end.
17327 @<Other local variables for |scan_primary|@>=
17328 integer group_line; /* where a group began */
17330 @ @<Scan a grouped primary@>=
17332 group_line=mp_true_line(mp);
17333 if ( mp->internal[mp_tracing_commands]>0 ) show_cur_cmd_mod;
17334 save_boundary_item(p);
17336 mp_do_statement(mp); /* ends with |cur_cmd>=semicolon| */
17337 } while (mp->cur_cmd==semicolon);
17338 if ( mp->cur_cmd!=end_group ) {
17339 print_err("A group begun on line ");
17340 @.A group...never ended@>
17341 mp_print_int(mp, group_line);
17342 mp_print(mp, " never ended");
17343 help2("I saw a `begingroup' back there that hasn't been matched")
17344 ("by `endgroup'. So I've inserted `endgroup' now.");
17345 mp_back_error(mp); mp->cur_cmd=end_group;
17348 /* this might change |cur_type|, if independent variables are recycled */
17349 if ( mp->internal[mp_tracing_commands]>0 ) show_cur_cmd_mod;
17352 @ @<Scan a string constant@>=
17354 mp->cur_type=mp_string_type; mp->cur_exp=mp->cur_mod;
17357 @ Later we'll come to procedures that perform actual operations like
17358 addition, square root, and so on; our purpose now is to do the parsing.
17359 But we might as well mention those future procedures now, so that the
17360 suspense won't be too bad:
17363 |do_nullary(c)| does primitive operations that have no operands (e.g.,
17364 `\&{true}' or `\&{pencircle}');
17367 |do_unary(c)| applies a primitive operation to the current expression;
17370 |do_binary(p,c)| applies a primitive operation to the capsule~|p|
17371 and the current expression.
17373 @<Scan a nullary operation@>=mp_do_nullary(mp, mp->cur_mod)
17375 @ @<Scan a unary operation@>=
17377 c=mp->cur_mod; mp_get_x_next(mp); mp_scan_primary(mp);
17378 mp_do_unary(mp, c); goto DONE;
17381 @ A numeric token might be a primary by itself, or it might be the
17382 numerator of a fraction composed solely of numeric tokens, or it might
17383 multiply the primary that follows (provided that the primary doesn't begin
17384 with a plus sign or a minus sign). The code here uses the facts that
17385 |max_primary_command=plus_or_minus| and
17386 |max_primary_command-1=numeric_token|. If a fraction is found that is less
17387 than unity, we try to retain higher precision when we use it in scalar
17390 @<Other local variables for |scan_primary|@>=
17391 scaled num,denom; /* for primaries that are fractions, like `1/2' */
17393 @ @<Scan a primary that starts with a numeric token@>=
17395 mp->cur_exp=mp->cur_mod; mp->cur_type=mp_known; mp_get_x_next(mp);
17396 if ( mp->cur_cmd!=slash ) {
17400 if ( mp->cur_cmd!=numeric_token ) {
17402 mp->cur_cmd=slash; mp->cur_mod=over; mp->cur_sym=frozen_slash;
17405 num=mp->cur_exp; denom=mp->cur_mod;
17406 if ( denom==0 ) { @<Protest division by zero@>; }
17407 else { mp->cur_exp=mp_make_scaled(mp, num,denom); }
17408 check_arith; mp_get_x_next(mp);
17410 if ( mp->cur_cmd>=min_primary_command ) {
17411 if ( mp->cur_cmd<numeric_token ) { /* in particular, |cur_cmd<>plus_or_minus| */
17412 p=mp_stash_cur_exp(mp); mp_scan_primary(mp);
17413 if ( (abs(num)>=abs(denom))||(mp->cur_type<mp_color_type) ) {
17414 mp_do_binary(mp, p,times);
17416 mp_frac_mult(mp, num,denom);
17417 mp_free_node(mp, p,value_node_size);
17424 @ @<Protest division...@>=
17426 print_err("Division by zero");
17427 @.Division by zero@>
17428 help1("I'll pretend that you meant to divide by 1."); mp_error(mp);
17431 @ @<Scan a binary operation with `\&{of}' between its operands@>=
17433 c=mp->cur_mod; mp_get_x_next(mp); mp_scan_expression(mp);
17434 if ( mp->cur_cmd!=of_token ) {
17435 mp_missing_err(mp, "of"); mp_print(mp, " for ");
17436 mp_print_cmd_mod(mp, primary_binary,c);
17438 help1("I've got the first argument; will look now for the other.");
17441 p=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_primary(mp);
17442 mp_do_binary(mp, p,c); goto DONE;
17445 @ @<Convert a suffix to a string@>=
17447 mp_get_x_next(mp); mp_scan_suffix(mp);
17448 mp->old_setting=mp->selector; mp->selector=new_string;
17449 mp_show_token_list(mp, mp->cur_exp,null,100000,0);
17450 mp_flush_token_list(mp, mp->cur_exp);
17451 mp->cur_exp=mp_make_string(mp); mp->selector=mp->old_setting;
17452 mp->cur_type=mp_string_type;
17456 @ If an internal quantity appears all by itself on the left of an
17457 assignment, we return a token list of length one, containing the address
17458 of the internal quantity plus |hash_end|. (This accords with the conventions
17459 of the save stack, as described earlier.)
17461 @<Scan an internal...@>=
17464 if ( my_var_flag==assignment ) {
17466 if ( mp->cur_cmd==assignment ) {
17467 mp->cur_exp=mp_get_avail(mp);
17468 info(mp->cur_exp)=q+hash_end; mp->cur_type=mp_token_list;
17473 mp->cur_type=mp_known; mp->cur_exp=mp->internal[q];
17476 @ The most difficult part of |scan_primary| has been saved for last, since
17477 it was necessary to build up some confidence first. We can now face the task
17478 of scanning a variable.
17480 As we scan a variable, we build a token list containing the relevant
17481 names and subscript values, simultaneously following along in the
17482 ``collective'' structure to see if we are actually dealing with a macro
17483 instead of a value.
17485 The local variables |pre_head| and |post_head| will point to the beginning
17486 of the prefix and suffix lists; |tail| will point to the end of the list
17487 that is currently growing.
17489 Another local variable, |tt|, contains partial information about the
17490 declared type of the variable-so-far. If |tt>=mp_unsuffixed_macro|, the
17491 relation |tt=type(q)| will always hold. If |tt=undefined|, the routine
17492 doesn't bother to update its information about type. And if
17493 |undefined<tt<mp_unsuffixed_macro|, the precise value of |tt| isn't critical.
17495 @ @<Other local variables for |scan_primary|@>=
17496 pointer pre_head,post_head,tail;
17497 /* prefix and suffix list variables */
17498 small_number tt; /* approximation to the type of the variable-so-far */
17499 pointer t; /* a token */
17500 pointer macro_ref = 0; /* reference count for a suffixed macro */
17502 @ @<Scan a variable primary...@>=
17504 fast_get_avail(pre_head); tail=pre_head; post_head=null; tt=mp_vacuous;
17506 t=mp_cur_tok(mp); link(tail)=t;
17507 if ( tt!=undefined ) {
17508 @<Find the approximate type |tt| and corresponding~|q|@>;
17509 if ( tt>=mp_unsuffixed_macro ) {
17510 @<Either begin an unsuffixed macro call or
17511 prepare for a suffixed one@>;
17514 mp_get_x_next(mp); tail=t;
17515 if ( mp->cur_cmd==left_bracket ) {
17516 @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>;
17518 if ( mp->cur_cmd>max_suffix_token ) break;
17519 if ( mp->cur_cmd<min_suffix_token ) break;
17520 } /* now |cur_cmd| is |internal_quantity|, |tag_token|, or |numeric_token| */
17521 @<Handle unusual cases that masquerade as variables, and |goto restart|
17522 or |goto done| if appropriate;
17523 otherwise make a copy of the variable and |goto done|@>;
17526 @ @<Either begin an unsuffixed macro call or...@>=
17529 if ( tt>mp_unsuffixed_macro ) { /* |tt=mp_suffixed_macro| */
17530 post_head=mp_get_avail(mp); tail=post_head; link(tail)=t;
17531 tt=undefined; macro_ref=value(q); add_mac_ref(macro_ref);
17533 @<Set up unsuffixed macro call and |goto restart|@>;
17537 @ @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>=
17539 mp_get_x_next(mp); mp_scan_expression(mp);
17540 if ( mp->cur_cmd!=right_bracket ) {
17541 @<Put the left bracket and the expression back to be rescanned@>;
17543 if ( mp->cur_type!=mp_known ) mp_bad_subscript(mp);
17544 mp->cur_cmd=numeric_token; mp->cur_mod=mp->cur_exp; mp->cur_sym=0;
17548 @ The left bracket that we thought was introducing a subscript might have
17549 actually been the left bracket in a mediation construction like `\.{x[a,b]}'.
17550 So we don't issue an error message at this point; but we do want to back up
17551 so as to avoid any embarrassment about our incorrect assumption.
17553 @<Put the left bracket and the expression back to be rescanned@>=
17555 mp_back_input(mp); /* that was the token following the current expression */
17556 mp_back_expr(mp); mp->cur_cmd=left_bracket;
17557 mp->cur_mod=0; mp->cur_sym=frozen_left_bracket;
17560 @ Here's a routine that puts the current expression back to be read again.
17562 @c void mp_back_expr (MP mp) {
17563 pointer p; /* capsule token */
17564 p=mp_stash_cur_exp(mp); link(p)=null; back_list(p);
17567 @ Unknown subscripts lead to the following error message.
17569 @c void mp_bad_subscript (MP mp) {
17570 exp_err("Improper subscript has been replaced by zero");
17571 @.Improper subscript...@>
17572 help3("A bracketed subscript must have a known numeric value;")
17573 ("unfortunately, what I found was the value that appears just")
17574 ("above this error message. So I'll try a zero subscript.");
17575 mp_flush_error(mp, 0);
17578 @ Every time we call |get_x_next|, there's a chance that the variable we've
17579 been looking at will disappear. Thus, we cannot safely keep |q| pointing
17580 into the variable structure; we need to start searching from the root each time.
17582 @<Find the approximate type |tt| and corresponding~|q|@>=
17585 p=link(pre_head); q=info(p); tt=undefined;
17586 if ( eq_type(q) % outer_tag==tag_token ) {
17588 if ( q==null ) goto DONE2;
17592 tt=type(q); goto DONE2;
17594 if ( type(q)!=mp_structured ) goto DONE2;
17595 q=link(attr_head(q)); /* the |collective_subscript| attribute */
17596 if ( p>=mp->hi_mem_min ) { /* it's not a subscript */
17597 do { q=link(q); } while (! (attr_loc(q)>=info(p)));
17598 if ( attr_loc(q)>info(p) ) goto DONE2;
17606 @ How do things stand now? Well, we have scanned an entire variable name,
17607 including possible subscripts and/or attributes; |cur_cmd|, |cur_mod|, and
17608 |cur_sym| represent the token that follows. If |post_head=null|, a
17609 token list for this variable name starts at |link(pre_head)|, with all
17610 subscripts evaluated. But if |post_head<>null|, the variable turned out
17611 to be a suffixed macro; |pre_head| is the head of the prefix list, while
17612 |post_head| is the head of a token list containing both `\.{\AT!}' and
17615 Our immediate problem is to see if this variable still exists. (Variable
17616 structures can change drastically whenever we call |get_x_next|; users
17617 aren't supposed to do this, but the fact that it is possible means that
17618 we must be cautious.)
17620 The following procedure prints an error message when a variable
17621 unexpectedly disappears. Its help message isn't quite right for
17622 our present purposes, but we'll be able to fix that up.
17625 void mp_obliterated (MP mp,pointer q) {
17626 print_err("Variable "); mp_show_token_list(mp, q,null,1000,0);
17627 mp_print(mp, " has been obliterated");
17628 @.Variable...obliterated@>
17629 help5("It seems you did a nasty thing---probably by accident,")
17630 ("but nevertheless you nearly hornswoggled me...")
17631 ("While I was evaluating the right-hand side of this")
17632 ("command, something happened, and the left-hand side")
17633 ("is no longer a variable! So I won't change anything.");
17636 @ If the variable does exist, we also need to check
17637 for a few other special cases before deciding that a plain old ordinary
17638 variable has, indeed, been scanned.
17640 @<Handle unusual cases that masquerade as variables...@>=
17641 if ( post_head!=null ) {
17642 @<Set up suffixed macro call and |goto restart|@>;
17644 q=link(pre_head); free_avail(pre_head);
17645 if ( mp->cur_cmd==my_var_flag ) {
17646 mp->cur_type=mp_token_list; mp->cur_exp=q; goto DONE;
17648 p=mp_find_variable(mp, q);
17650 mp_make_exp_copy(mp, p);
17652 mp_obliterated(mp, q);
17653 mp->help_line[2]="While I was evaluating the suffix of this variable,";
17654 mp->help_line[1]="something was redefined, and it's no longer a variable!";
17655 mp->help_line[0]="In order to get back on my feet, I've inserted `0' instead.";
17656 mp_put_get_flush_error(mp, 0);
17658 mp_flush_node_list(mp, q);
17661 @ The only complication associated with macro calling is that the prefix
17662 and ``at'' parameters must be packaged in an appropriate list of lists.
17664 @<Set up unsuffixed macro call and |goto restart|@>=
17666 p=mp_get_avail(mp); info(pre_head)=link(pre_head); link(pre_head)=p;
17667 info(p)=t; mp_macro_call(mp, value(q),pre_head,null);
17672 @ If the ``variable'' that turned out to be a suffixed macro no longer exists,
17673 we don't care, because we have reserved a pointer (|macro_ref|) to its
17676 @<Set up suffixed macro call and |goto restart|@>=
17678 mp_back_input(mp); p=mp_get_avail(mp); q=link(post_head);
17679 info(pre_head)=link(pre_head); link(pre_head)=post_head;
17680 info(post_head)=q; link(post_head)=p; info(p)=link(q); link(q)=null;
17681 mp_macro_call(mp, macro_ref,pre_head,null); decr(ref_count(macro_ref));
17682 mp_get_x_next(mp); goto RESTART;
17685 @ Our remaining job is simply to make a copy of the value that has been
17686 found. Some cases are harder than others, but complexity arises solely
17687 because of the multiplicity of possible cases.
17689 @<Declare the procedure called |make_exp_copy|@>=
17690 @<Declare subroutines needed by |make_exp_copy|@>
17691 void mp_make_exp_copy (MP mp,pointer p) {
17692 pointer q,r,t; /* registers for list manipulation */
17694 mp->cur_type=type(p);
17695 switch (mp->cur_type) {
17696 case mp_vacuous: case mp_boolean_type: case mp_known:
17697 mp->cur_exp=value(p); break;
17698 case unknown_types:
17699 mp->cur_exp=mp_new_ring_entry(mp, p);
17701 case mp_string_type:
17702 mp->cur_exp=value(p); add_str_ref(mp->cur_exp);
17704 case mp_picture_type:
17705 mp->cur_exp=value(p);add_edge_ref(mp->cur_exp);
17708 mp->cur_exp=copy_pen(value(p));
17711 mp->cur_exp=mp_copy_path(mp, value(p));
17713 case mp_transform_type: case mp_color_type:
17714 case mp_cmykcolor_type: case mp_pair_type:
17715 @<Copy the big node |p|@>;
17717 case mp_dependent: case mp_proto_dependent:
17718 mp_encapsulate(mp, mp_copy_dep_list(mp, dep_list(p)));
17720 case mp_numeric_type:
17721 new_indep(p); goto RESTART;
17723 case mp_independent:
17724 q=mp_single_dependency(mp, p);
17725 if ( q==mp->dep_final ){
17726 mp->cur_type=mp_known; mp->cur_exp=0; mp_free_node(mp, q,dep_node_size);
17728 mp->cur_type=mp_dependent; mp_encapsulate(mp, q);
17732 mp_confusion(mp, "copy");
17733 @:this can't happen copy}{\quad copy@>
17738 @ The |encapsulate| subroutine assumes that |dep_final| is the
17739 tail of dependency list~|p|.
17741 @<Declare subroutines needed by |make_exp_copy|@>=
17742 void mp_encapsulate (MP mp,pointer p) {
17743 mp->cur_exp=mp_get_node(mp, value_node_size); type(mp->cur_exp)=mp->cur_type;
17744 name_type(mp->cur_exp)=mp_capsule; mp_new_dep(mp, mp->cur_exp,p);
17747 @ The most tedious case arises when the user refers to a
17748 \&{pair}, \&{color}, or \&{transform} variable; we must copy several fields,
17749 each of which can be |independent|, |dependent|, |mp_proto_dependent|,
17752 @<Copy the big node |p|@>=
17754 if ( value(p)==null )
17755 mp_init_big_node(mp, p);
17756 t=mp_get_node(mp, value_node_size); name_type(t)=mp_capsule; type(t)=mp->cur_type;
17757 mp_init_big_node(mp, t);
17758 q=value(p)+mp->big_node_size[mp->cur_type];
17759 r=value(t)+mp->big_node_size[mp->cur_type];
17761 q=q-2; r=r-2; mp_install(mp, r,q);
17762 } while (q!=value(p));
17766 @ The |install| procedure copies a numeric field~|q| into field~|r| of
17767 a big node that will be part of a capsule.
17769 @<Declare subroutines needed by |make_exp_copy|@>=
17770 void mp_install (MP mp,pointer r, pointer q) {
17771 pointer p; /* temporary register */
17772 if ( type(q)==mp_known ){
17773 value(r)=value(q); type(r)=mp_known;
17774 } else if ( type(q)==mp_independent ) {
17775 p=mp_single_dependency(mp, q);
17776 if ( p==mp->dep_final ) {
17777 type(r)=mp_known; value(r)=0; mp_free_node(mp, p,dep_node_size);
17779 type(r)=mp_dependent; mp_new_dep(mp, r,p);
17782 type(r)=type(q); mp_new_dep(mp, r,mp_copy_dep_list(mp, dep_list(q)));
17786 @ Expressions of the form `\.{a[b,c]}' are converted into
17787 `\.{b+a*(c-b)}', without checking the types of \.b~or~\.c,
17788 provided that \.a is numeric.
17790 @<Scan a mediation...@>=
17792 p=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_expression(mp);
17793 if ( mp->cur_cmd!=comma ) {
17794 @<Put the left bracket and the expression back...@>;
17795 mp_unstash_cur_exp(mp, p);
17797 q=mp_stash_cur_exp(mp); mp_get_x_next(mp); mp_scan_expression(mp);
17798 if ( mp->cur_cmd!=right_bracket ) {
17799 mp_missing_err(mp, "]");
17801 help3("I've scanned an expression of the form `a[b,c',")
17802 ("so a right bracket should have come next.")
17803 ("I shall pretend that one was there.");
17806 r=mp_stash_cur_exp(mp); mp_make_exp_copy(mp, q);
17807 mp_do_binary(mp, r,minus); mp_do_binary(mp, p,times);
17808 mp_do_binary(mp, q,plus); mp_get_x_next(mp);
17812 @ Here is a comparatively simple routine that is used to scan the
17813 \&{suffix} parameters of a macro.
17815 @<Declare the basic parsing subroutines@>=
17816 void mp_scan_suffix (MP mp) {
17817 pointer h,t; /* head and tail of the list being built */
17818 pointer p; /* temporary register */
17819 h=mp_get_avail(mp); t=h;
17821 if ( mp->cur_cmd==left_bracket ) {
17822 @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>;
17824 if ( mp->cur_cmd==numeric_token ) {
17825 p=mp_new_num_tok(mp, mp->cur_mod);
17826 } else if ((mp->cur_cmd==tag_token)||(mp->cur_cmd==internal_quantity) ) {
17827 p=mp_get_avail(mp); info(p)=mp->cur_sym;
17831 link(t)=p; t=p; mp_get_x_next(mp);
17833 mp->cur_exp=link(h); free_avail(h); mp->cur_type=mp_token_list;
17836 @ @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>=
17838 mp_get_x_next(mp); mp_scan_expression(mp);
17839 if ( mp->cur_type!=mp_known ) mp_bad_subscript(mp);
17840 if ( mp->cur_cmd!=right_bracket ) {
17841 mp_missing_err(mp, "]");
17843 help3("I've seen a `[' and a subscript value, in a suffix,")
17844 ("so a right bracket should have come next.")
17845 ("I shall pretend that one was there.");
17848 mp->cur_cmd=numeric_token; mp->cur_mod=mp->cur_exp;
17851 @* \[38] Parsing secondary and higher expressions.
17853 After the intricacies of |scan_primary|\kern-1pt,
17854 the |scan_secondary| routine is
17855 refreshingly simple. It's not trivial, but the operations are relatively
17856 straightforward; the main difficulty is, again, that expressions and data
17857 structures might change drastically every time we call |get_x_next|, so a
17858 cautious approach is mandatory. For example, a macro defined by
17859 \&{primarydef} might have disappeared by the time its second argument has
17860 been scanned; we solve this by increasing the reference count of its token
17861 list, so that the macro can be called even after it has been clobbered.
17863 @<Declare the basic parsing subroutines@>=
17864 void mp_scan_secondary (MP mp) {
17865 pointer p; /* for list manipulation */
17866 halfword c,d; /* operation codes or modifiers */
17867 pointer mac_name; /* token defined with \&{primarydef} */
17869 if ((mp->cur_cmd<min_primary_command)||
17870 (mp->cur_cmd>max_primary_command) )
17871 mp_bad_exp(mp, "A secondary");
17872 @.A secondary expression...@>
17873 mp_scan_primary(mp);
17875 if ( mp->cur_cmd<=max_secondary_command &&
17876 mp->cur_cmd>=min_secondary_command ) {
17877 p=mp_stash_cur_exp(mp);
17878 c=mp->cur_mod; d=mp->cur_cmd;
17879 if ( d==secondary_primary_macro ) {
17880 mac_name=mp->cur_sym;
17884 mp_scan_primary(mp);
17885 if ( d!=secondary_primary_macro ) {
17886 mp_do_binary(mp, p,c);
17889 mp_binary_mac(mp, p,c,mac_name);
17890 decr(ref_count(c));
17898 @ The following procedure calls a macro that has two parameters,
17901 @c void mp_binary_mac (MP mp,pointer p, pointer c, pointer n) {
17902 pointer q,r; /* nodes in the parameter list */
17903 q=mp_get_avail(mp); r=mp_get_avail(mp); link(q)=r;
17904 info(q)=p; info(r)=mp_stash_cur_exp(mp);
17905 mp_macro_call(mp, c,q,n);
17908 @ The next procedure, |scan_tertiary|, is pretty much the same deal.
17910 @<Declare the basic parsing subroutines@>=
17911 void mp_scan_tertiary (MP mp) {
17912 pointer p; /* for list manipulation */
17913 halfword c,d; /* operation codes or modifiers */
17914 pointer mac_name; /* token defined with \&{secondarydef} */
17916 if ((mp->cur_cmd<min_primary_command)||
17917 (mp->cur_cmd>max_primary_command) )
17918 mp_bad_exp(mp, "A tertiary");
17919 @.A tertiary expression...@>
17920 mp_scan_secondary(mp);
17922 if ( mp->cur_cmd<=max_tertiary_command ) {
17923 if ( mp->cur_cmd>=min_tertiary_command ) {
17924 p=mp_stash_cur_exp(mp); c=mp->cur_mod; d=mp->cur_cmd;
17925 if ( d==tertiary_secondary_macro ) {
17926 mac_name=mp->cur_sym; add_mac_ref(c);
17928 mp_get_x_next(mp); mp_scan_secondary(mp);
17929 if ( d!=tertiary_secondary_macro ) {
17930 mp_do_binary(mp, p,c);
17932 mp_back_input(mp); mp_binary_mac(mp, p,c,mac_name);
17933 decr(ref_count(c)); mp_get_x_next(mp);
17941 @ Finally we reach the deepest level in our quartet of parsing routines.
17942 This one is much like the others; but it has an extra complication from
17943 paths, which materialize here.
17945 @d continue_path 25 /* a label inside of |scan_expression| */
17946 @d finish_path 26 /* another */
17948 @<Declare the basic parsing subroutines@>=
17949 void mp_scan_expression (MP mp) {
17950 pointer p,q,r,pp,qq; /* for list manipulation */
17951 halfword c,d; /* operation codes or modifiers */
17952 int my_var_flag; /* initial value of |var_flag| */
17953 pointer mac_name; /* token defined with \&{tertiarydef} */
17954 boolean cycle_hit; /* did a path expression just end with `\&{cycle}'? */
17955 scaled x,y; /* explicit coordinates or tension at a path join */
17956 int t; /* knot type following a path join */
17958 my_var_flag=mp->var_flag; mac_name=null;
17960 if ((mp->cur_cmd<min_primary_command)||
17961 (mp->cur_cmd>max_primary_command) )
17962 mp_bad_exp(mp, "An");
17963 @.An expression...@>
17964 mp_scan_tertiary(mp);
17966 if ( mp->cur_cmd<=max_expression_command )
17967 if ( mp->cur_cmd>=min_expression_command ) {
17968 if ( (mp->cur_cmd!=equals)||(my_var_flag!=assignment) ) {
17969 p=mp_stash_cur_exp(mp); c=mp->cur_mod; d=mp->cur_cmd;
17970 if ( d==expression_tertiary_macro ) {
17971 mac_name=mp->cur_sym; add_mac_ref(c);
17973 if ( (d<ampersand)||((d==ampersand)&&
17974 ((type(p)==mp_pair_type)||(type(p)==mp_path_type))) ) {
17975 @<Scan a path construction operation;
17976 but |return| if |p| has the wrong type@>;
17978 mp_get_x_next(mp); mp_scan_tertiary(mp);
17979 if ( d!=expression_tertiary_macro ) {
17980 mp_do_binary(mp, p,c);
17982 mp_back_input(mp); mp_binary_mac(mp, p,c,mac_name);
17983 decr(ref_count(c)); mp_get_x_next(mp);
17992 @ The reader should review the data structure conventions for paths before
17993 hoping to understand the next part of this code.
17995 @<Scan a path construction operation...@>=
17998 @<Convert the left operand, |p|, into a partial path ending at~|q|;
17999 but |return| if |p| doesn't have a suitable type@>;
18001 @<Determine the path join parameters;
18002 but |goto finish_path| if there's only a direction specifier@>;
18003 if ( mp->cur_cmd==cycle ) {
18004 @<Get ready to close a cycle@>;
18006 mp_scan_tertiary(mp);
18007 @<Convert the right operand, |cur_exp|,
18008 into a partial path from |pp| to~|qq|@>;
18010 @<Join the partial paths and reset |p| and |q| to the head and tail
18012 if ( mp->cur_cmd>=min_expression_command )
18013 if ( mp->cur_cmd<=ampersand ) if ( ! cycle_hit ) goto CONTINUE_PATH;
18015 @<Choose control points for the path and put the result into |cur_exp|@>;
18018 @ @<Convert the left operand, |p|, into a partial path ending at~|q|...@>=
18020 mp_unstash_cur_exp(mp, p);
18021 if ( mp->cur_type==mp_pair_type ) p=mp_new_knot(mp);
18022 else if ( mp->cur_type==mp_path_type ) p=mp->cur_exp;
18025 while ( link(q)!=p ) q=link(q);
18026 if ( left_type(p)!=mp_endpoint ) { /* open up a cycle */
18027 r=mp_copy_knot(mp, p); link(q)=r; q=r;
18029 left_type(p)=mp_open; right_type(q)=mp_open;
18032 @ A pair of numeric values is changed into a knot node for a one-point path
18033 when \MP\ discovers that the pair is part of a path.
18035 @c @<Declare the procedure called |known_pair|@>
18036 pointer mp_new_knot (MP mp) { /* convert a pair to a knot with two endpoints */
18037 pointer q; /* the new node */
18038 q=mp_get_node(mp, knot_node_size); left_type(q)=mp_endpoint;
18039 right_type(q)=mp_endpoint; originator(q)=mp_metapost_user; link(q)=q;
18040 mp_known_pair(mp); x_coord(q)=mp->cur_x; y_coord(q)=mp->cur_y;
18044 @ The |known_pair| subroutine sets |cur_x| and |cur_y| to the components
18045 of the current expression, assuming that the current expression is a
18046 pair of known numerics. Unknown components are zeroed, and the
18047 current expression is flushed.
18049 @<Declare the procedure called |known_pair|@>=
18050 void mp_known_pair (MP mp) {
18051 pointer p; /* the pair node */
18052 if ( mp->cur_type!=mp_pair_type ) {
18053 exp_err("Undefined coordinates have been replaced by (0,0)");
18054 @.Undefined coordinates...@>
18055 help5("I need x and y numbers for this part of the path.")
18056 ("The value I found (see above) was no good;")
18057 ("so I'll try to keep going by using zero instead.")
18058 ("(Chapter 27 of The METAFONTbook explains that")
18059 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18060 ("you might want to type `I ??" "?' now.)");
18061 mp_put_get_flush_error(mp, 0); mp->cur_x=0; mp->cur_y=0;
18063 p=value(mp->cur_exp);
18064 @<Make sure that both |x| and |y| parts of |p| are known;
18065 copy them into |cur_x| and |cur_y|@>;
18066 mp_flush_cur_exp(mp, 0);
18070 @ @<Make sure that both |x| and |y| parts of |p| are known...@>=
18071 if ( type(x_part_loc(p))==mp_known ) {
18072 mp->cur_x=value(x_part_loc(p));
18074 mp_disp_err(mp, x_part_loc(p),
18075 "Undefined x coordinate has been replaced by 0");
18076 @.Undefined coordinates...@>
18077 help5("I need a `known' x value for this part of the path.")
18078 ("The value I found (see above) was no good;")
18079 ("so I'll try to keep going by using zero instead.")
18080 ("(Chapter 27 of The METAFONTbook explains that")
18081 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18082 ("you might want to type `I ??" "?' now.)");
18083 mp_put_get_error(mp); mp_recycle_value(mp, x_part_loc(p)); mp->cur_x=0;
18085 if ( type(y_part_loc(p))==mp_known ) {
18086 mp->cur_y=value(y_part_loc(p));
18088 mp_disp_err(mp, y_part_loc(p),
18089 "Undefined y coordinate has been replaced by 0");
18090 help5("I need a `known' y value for this part of the path.")
18091 ("The value I found (see above) was no good;")
18092 ("so I'll try to keep going by using zero instead.")
18093 ("(Chapter 27 of The METAFONTbook explains that")
18094 ("you might want to type `I ??" "?' now.)");
18095 mp_put_get_error(mp); mp_recycle_value(mp, y_part_loc(p)); mp->cur_y=0;
18098 @ At this point |cur_cmd| is either |ampersand|, |left_brace|, or |path_join|.
18100 @<Determine the path join parameters...@>=
18101 if ( mp->cur_cmd==left_brace ) {
18102 @<Put the pre-join direction information into node |q|@>;
18105 if ( d==path_join ) {
18106 @<Determine the tension and/or control points@>;
18107 } else if ( d!=ampersand ) {
18111 if ( mp->cur_cmd==left_brace ) {
18112 @<Put the post-join direction information into |x| and |t|@>;
18113 } else if ( right_type(q)!=mp_explicit ) {
18117 @ The |scan_direction| subroutine looks at the directional information
18118 that is enclosed in braces, and also scans ahead to the following character.
18119 A type code is returned, either |open| (if the direction was $(0,0)$),
18120 or |curl| (if the direction was a curl of known value |cur_exp|), or
18121 |given| (if the direction is given by the |angle| value that now
18122 appears in |cur_exp|).
18124 There's nothing difficult about this subroutine, but the program is rather
18125 lengthy because a variety of potential errors need to be nipped in the bud.
18127 @c small_number mp_scan_direction (MP mp) {
18128 int t; /* the type of information found */
18129 scaled x; /* an |x| coordinate */
18131 if ( mp->cur_cmd==curl_command ) {
18132 @<Scan a curl specification@>;
18134 @<Scan a given direction@>;
18136 if ( mp->cur_cmd!=right_brace ) {
18137 mp_missing_err(mp, "}");
18138 @.Missing `\char`\}'@>
18139 help3("I've scanned a direction spec for part of a path,")
18140 ("so a right brace should have come next.")
18141 ("I shall pretend that one was there.");
18148 @ @<Scan a curl specification@>=
18149 { mp_get_x_next(mp); mp_scan_expression(mp);
18150 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<0) ){
18151 exp_err("Improper curl has been replaced by 1");
18153 help1("A curl must be a known, nonnegative number.");
18154 mp_put_get_flush_error(mp, unity);
18159 @ @<Scan a given direction@>=
18160 { mp_scan_expression(mp);
18161 if ( mp->cur_type>mp_pair_type ) {
18162 @<Get given directions separated by commas@>;
18166 if ( (mp->cur_x==0)&&(mp->cur_y==0) ) t=mp_open;
18167 else { t=mp_given; mp->cur_exp=mp_n_arg(mp, mp->cur_x,mp->cur_y);}
18170 @ @<Get given directions separated by commas@>=
18172 if ( mp->cur_type!=mp_known ) {
18173 exp_err("Undefined x coordinate has been replaced by 0");
18174 @.Undefined coordinates...@>
18175 help5("I need a `known' x value for this part of the path.")
18176 ("The value I found (see above) was no good;")
18177 ("so I'll try to keep going by using zero instead.")
18178 ("(Chapter 27 of The METAFONTbook explains that")
18179 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
18180 ("you might want to type `I ??" "?' now.)");
18181 mp_put_get_flush_error(mp, 0);
18184 if ( mp->cur_cmd!=comma ) {
18185 mp_missing_err(mp, ",");
18187 help2("I've got the x coordinate of a path direction;")
18188 ("will look for the y coordinate next.");
18191 mp_get_x_next(mp); mp_scan_expression(mp);
18192 if ( mp->cur_type!=mp_known ) {
18193 exp_err("Undefined y coordinate has been replaced by 0");
18194 help5("I need a `known' y value for this part of the path.")
18195 ("The value I found (see above) was no good;")
18196 ("so I'll try to keep going by using zero instead.")
18197 ("(Chapter 27 of The METAFONTbook explains that")
18198 ("you might want to type `I ??" "?' now.)");
18199 mp_put_get_flush_error(mp, 0);
18201 mp->cur_y=mp->cur_exp; mp->cur_x=x;
18204 @ At this point |right_type(q)| is usually |open|, but it may have been
18205 set to some other value by a previous operation. We must maintain
18206 the value of |right_type(q)| in cases such as
18207 `\.{..\{curl2\}z\{0,0\}..}'.
18209 @<Put the pre-join...@>=
18211 t=mp_scan_direction(mp);
18212 if ( t!=mp_open ) {
18213 right_type(q)=t; right_given(q)=mp->cur_exp;
18214 if ( left_type(q)==mp_open ) {
18215 left_type(q)=t; left_given(q)=mp->cur_exp;
18216 } /* note that |left_given(q)=left_curl(q)| */
18220 @ Since |left_tension| and |left_y| share the same position in knot nodes,
18221 and since |left_given| is similarly equivalent to |left_x|, we use
18222 |x| and |y| to hold the given direction and tension information when
18223 there are no explicit control points.
18225 @<Put the post-join...@>=
18227 t=mp_scan_direction(mp);
18228 if ( right_type(q)!=mp_explicit ) x=mp->cur_exp;
18229 else t=mp_explicit; /* the direction information is superfluous */
18232 @ @<Determine the tension and/or...@>=
18235 if ( mp->cur_cmd==tension ) {
18236 @<Set explicit tensions@>;
18237 } else if ( mp->cur_cmd==controls ) {
18238 @<Set explicit control points@>;
18240 right_tension(q)=unity; y=unity; mp_back_input(mp); /* default tension */
18243 if ( mp->cur_cmd!=path_join ) {
18244 mp_missing_err(mp, "..");
18246 help1("A path join command should end with two dots.");
18253 @ @<Set explicit tensions@>=
18255 mp_get_x_next(mp); y=mp->cur_cmd;
18256 if ( mp->cur_cmd==at_least ) mp_get_x_next(mp);
18257 mp_scan_primary(mp);
18258 @<Make sure that the current expression is a valid tension setting@>;
18259 if ( y==at_least ) negate(mp->cur_exp);
18260 right_tension(q)=mp->cur_exp;
18261 if ( mp->cur_cmd==and_command ) {
18262 mp_get_x_next(mp); y=mp->cur_cmd;
18263 if ( mp->cur_cmd==at_least ) mp_get_x_next(mp);
18264 mp_scan_primary(mp);
18265 @<Make sure that the current expression is a valid tension setting@>;
18266 if ( y==at_least ) negate(mp->cur_exp);
18271 @ @d min_tension three_quarter_unit
18273 @<Make sure that the current expression is a valid tension setting@>=
18274 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<min_tension) ) {
18275 exp_err("Improper tension has been set to 1");
18276 @.Improper tension@>
18277 help1("The expression above should have been a number >=3/4.");
18278 mp_put_get_flush_error(mp, unity);
18281 @ @<Set explicit control points@>=
18283 right_type(q)=mp_explicit; t=mp_explicit; mp_get_x_next(mp); mp_scan_primary(mp);
18284 mp_known_pair(mp); right_x(q)=mp->cur_x; right_y(q)=mp->cur_y;
18285 if ( mp->cur_cmd!=and_command ) {
18286 x=right_x(q); y=right_y(q);
18288 mp_get_x_next(mp); mp_scan_primary(mp);
18289 mp_known_pair(mp); x=mp->cur_x; y=mp->cur_y;
18293 @ @<Convert the right operand, |cur_exp|, into a partial path...@>=
18295 if ( mp->cur_type!=mp_path_type ) pp=mp_new_knot(mp);
18296 else pp=mp->cur_exp;
18298 while ( link(qq)!=pp ) qq=link(qq);
18299 if ( left_type(pp)!=mp_endpoint ) { /* open up a cycle */
18300 r=mp_copy_knot(mp, pp); link(qq)=r; qq=r;
18302 left_type(pp)=mp_open; right_type(qq)=mp_open;
18305 @ If a person tries to define an entire path by saying `\.{(x,y)\&cycle}',
18306 we silently change the specification to `\.{(x,y)..cycle}', since a cycle
18307 shouldn't have length zero.
18309 @<Get ready to close a cycle@>=
18311 cycle_hit=true; mp_get_x_next(mp); pp=p; qq=p;
18312 if ( d==ampersand ) if ( p==q ) {
18313 d=path_join; right_tension(q)=unity; y=unity;
18317 @ @<Join the partial paths and reset |p| and |q|...@>=
18319 if ( d==ampersand ) {
18320 if ( (x_coord(q)!=x_coord(pp))||(y_coord(q)!=y_coord(pp)) ) {
18321 print_err("Paths don't touch; `&' will be changed to `..'");
18322 @.Paths don't touch@>
18323 help3("When you join paths `p&q', the ending point of p")
18324 ("must be exactly equal to the starting point of q.")
18325 ("So I'm going to pretend that you said `p..q' instead.");
18326 mp_put_get_error(mp); d=path_join; right_tension(q)=unity; y=unity;
18329 @<Plug an opening in |right_type(pp)|, if possible@>;
18330 if ( d==ampersand ) {
18331 @<Splice independent paths together@>;
18333 @<Plug an opening in |right_type(q)|, if possible@>;
18334 link(q)=pp; left_y(pp)=y;
18335 if ( t!=mp_open ) { left_x(pp)=x; left_type(pp)=t; };
18340 @ @<Plug an opening in |right_type(q)|...@>=
18341 if ( right_type(q)==mp_open ) {
18342 if ( (left_type(q)==mp_curl)||(left_type(q)==mp_given) ) {
18343 right_type(q)=left_type(q); right_given(q)=left_given(q);
18347 @ @<Plug an opening in |right_type(pp)|...@>=
18348 if ( right_type(pp)==mp_open ) {
18349 if ( (t==mp_curl)||(t==mp_given) ) {
18350 right_type(pp)=t; right_given(pp)=x;
18354 @ @<Splice independent paths together@>=
18356 if ( left_type(q)==mp_open ) if ( right_type(q)==mp_open ) {
18357 left_type(q)=mp_curl; left_curl(q)=unity;
18359 if ( right_type(pp)==mp_open ) if ( t==mp_open ) {
18360 right_type(pp)=mp_curl; right_curl(pp)=unity;
18362 right_type(q)=right_type(pp); link(q)=link(pp);
18363 right_x(q)=right_x(pp); right_y(q)=right_y(pp);
18364 mp_free_node(mp, pp,knot_node_size);
18365 if ( qq==pp ) qq=q;
18368 @ @<Choose control points for the path...@>=
18370 if ( d==ampersand ) p=q;
18372 left_type(p)=mp_endpoint;
18373 if ( right_type(p)==mp_open ) {
18374 right_type(p)=mp_curl; right_curl(p)=unity;
18376 right_type(q)=mp_endpoint;
18377 if ( left_type(q)==mp_open ) {
18378 left_type(q)=mp_curl; left_curl(q)=unity;
18382 mp_make_choices(mp, p);
18383 mp->cur_type=mp_path_type; mp->cur_exp=p
18385 @ Finally, we sometimes need to scan an expression whose value is
18386 supposed to be either |true_code| or |false_code|.
18388 @<Declare the basic parsing subroutines@>=
18389 void mp_get_boolean (MP mp) {
18390 mp_get_x_next(mp); mp_scan_expression(mp);
18391 if ( mp->cur_type!=mp_boolean_type ) {
18392 exp_err("Undefined condition will be treated as `false'");
18393 @.Undefined condition...@>
18394 help2("The expression shown above should have had a definite")
18395 ("true-or-false value. I'm changing it to `false'.");
18396 mp_put_get_flush_error(mp, false_code); mp->cur_type=mp_boolean_type;
18400 @* \[39] Doing the operations.
18401 The purpose of parsing is primarily to permit people to avoid piles of
18402 parentheses. But the real work is done after the structure of an expression
18403 has been recognized; that's when new expressions are generated. We
18404 turn now to the guts of \MP, which handles individual operators that
18405 have come through the parsing mechanism.
18407 We'll start with the easy ones that take no operands, then work our way
18408 up to operators with one and ultimately two arguments. In other words,
18409 we will write the three procedures |do_nullary|, |do_unary|, and |do_binary|
18410 that are invoked periodically by the expression scanners.
18412 First let's make sure that all of the primitive operators are in the
18413 hash table. Although |scan_primary| and its relatives made use of the
18414 \\{cmd} code for these operators, the \\{do} routines base everything
18415 on the \\{mod} code. For example, |do_binary| doesn't care whether the
18416 operation it performs is a |primary_binary| or |secondary_binary|, etc.
18419 mp_primitive(mp, "true",nullary,true_code);
18420 @:true_}{\&{true} primitive@>
18421 mp_primitive(mp, "false",nullary,false_code);
18422 @:false_}{\&{false} primitive@>
18423 mp_primitive(mp, "nullpicture",nullary,null_picture_code);
18424 @:null_picture_}{\&{nullpicture} primitive@>
18425 mp_primitive(mp, "nullpen",nullary,null_pen_code);
18426 @:null_pen_}{\&{nullpen} primitive@>
18427 mp_primitive(mp, "jobname",nullary,job_name_op);
18428 @:job_name_}{\&{jobname} primitive@>
18429 mp_primitive(mp, "readstring",nullary,read_string_op);
18430 @:read_string_}{\&{readstring} primitive@>
18431 mp_primitive(mp, "pencircle",nullary,pen_circle);
18432 @:pen_circle_}{\&{pencircle} primitive@>
18433 mp_primitive(mp, "normaldeviate",nullary,normal_deviate);
18434 @:normal_deviate_}{\&{normaldeviate} primitive@>
18435 mp_primitive(mp, "readfrom",unary,read_from_op);
18436 @:read_from_}{\&{readfrom} primitive@>
18437 mp_primitive(mp, "closefrom",unary,close_from_op);
18438 @:close_from_}{\&{closefrom} primitive@>
18439 mp_primitive(mp, "odd",unary,odd_op);
18440 @:odd_}{\&{odd} primitive@>
18441 mp_primitive(mp, "known",unary,known_op);
18442 @:known_}{\&{known} primitive@>
18443 mp_primitive(mp, "unknown",unary,unknown_op);
18444 @:unknown_}{\&{unknown} primitive@>
18445 mp_primitive(mp, "not",unary,not_op);
18446 @:not_}{\&{not} primitive@>
18447 mp_primitive(mp, "decimal",unary,decimal);
18448 @:decimal_}{\&{decimal} primitive@>
18449 mp_primitive(mp, "reverse",unary,reverse);
18450 @:reverse_}{\&{reverse} primitive@>
18451 mp_primitive(mp, "makepath",unary,make_path_op);
18452 @:make_path_}{\&{makepath} primitive@>
18453 mp_primitive(mp, "makepen",unary,make_pen_op);
18454 @:make_pen_}{\&{makepen} primitive@>
18455 mp_primitive(mp, "oct",unary,oct_op);
18456 @:oct_}{\&{oct} primitive@>
18457 mp_primitive(mp, "hex",unary,hex_op);
18458 @:hex_}{\&{hex} primitive@>
18459 mp_primitive(mp, "ASCII",unary,ASCII_op);
18460 @:ASCII_}{\&{ASCII} primitive@>
18461 mp_primitive(mp, "char",unary,char_op);
18462 @:char_}{\&{char} primitive@>
18463 mp_primitive(mp, "length",unary,length_op);
18464 @:length_}{\&{length} primitive@>
18465 mp_primitive(mp, "turningnumber",unary,turning_op);
18466 @:turning_number_}{\&{turningnumber} primitive@>
18467 mp_primitive(mp, "xpart",unary,x_part);
18468 @:x_part_}{\&{xpart} primitive@>
18469 mp_primitive(mp, "ypart",unary,y_part);
18470 @:y_part_}{\&{ypart} primitive@>
18471 mp_primitive(mp, "xxpart",unary,xx_part);
18472 @:xx_part_}{\&{xxpart} primitive@>
18473 mp_primitive(mp, "xypart",unary,xy_part);
18474 @:xy_part_}{\&{xypart} primitive@>
18475 mp_primitive(mp, "yxpart",unary,yx_part);
18476 @:yx_part_}{\&{yxpart} primitive@>
18477 mp_primitive(mp, "yypart",unary,yy_part);
18478 @:yy_part_}{\&{yypart} primitive@>
18479 mp_primitive(mp, "redpart",unary,red_part);
18480 @:red_part_}{\&{redpart} primitive@>
18481 mp_primitive(mp, "greenpart",unary,green_part);
18482 @:green_part_}{\&{greenpart} primitive@>
18483 mp_primitive(mp, "bluepart",unary,blue_part);
18484 @:blue_part_}{\&{bluepart} primitive@>
18485 mp_primitive(mp, "cyanpart",unary,cyan_part);
18486 @:cyan_part_}{\&{cyanpart} primitive@>
18487 mp_primitive(mp, "magentapart",unary,magenta_part);
18488 @:magenta_part_}{\&{magentapart} primitive@>
18489 mp_primitive(mp, "yellowpart",unary,yellow_part);
18490 @:yellow_part_}{\&{yellowpart} primitive@>
18491 mp_primitive(mp, "blackpart",unary,black_part);
18492 @:black_part_}{\&{blackpart} primitive@>
18493 mp_primitive(mp, "greypart",unary,grey_part);
18494 @:grey_part_}{\&{greypart} primitive@>
18495 mp_primitive(mp, "colormodel",unary,color_model_part);
18496 @:color_model_part_}{\&{colormodel} primitive@>
18497 mp_primitive(mp, "fontpart",unary,font_part);
18498 @:font_part_}{\&{fontpart} primitive@>
18499 mp_primitive(mp, "textpart",unary,text_part);
18500 @:text_part_}{\&{textpart} primitive@>
18501 mp_primitive(mp, "pathpart",unary,path_part);
18502 @:path_part_}{\&{pathpart} primitive@>
18503 mp_primitive(mp, "penpart",unary,pen_part);
18504 @:pen_part_}{\&{penpart} primitive@>
18505 mp_primitive(mp, "dashpart",unary,dash_part);
18506 @:dash_part_}{\&{dashpart} primitive@>
18507 mp_primitive(mp, "sqrt",unary,sqrt_op);
18508 @:sqrt_}{\&{sqrt} primitive@>
18509 mp_primitive(mp, "mexp",unary,m_exp_op);
18510 @:m_exp_}{\&{mexp} primitive@>
18511 mp_primitive(mp, "mlog",unary,m_log_op);
18512 @:m_log_}{\&{mlog} primitive@>
18513 mp_primitive(mp, "sind",unary,sin_d_op);
18514 @:sin_d_}{\&{sind} primitive@>
18515 mp_primitive(mp, "cosd",unary,cos_d_op);
18516 @:cos_d_}{\&{cosd} primitive@>
18517 mp_primitive(mp, "floor",unary,floor_op);
18518 @:floor_}{\&{floor} primitive@>
18519 mp_primitive(mp, "uniformdeviate",unary,uniform_deviate);
18520 @:uniform_deviate_}{\&{uniformdeviate} primitive@>
18521 mp_primitive(mp, "charexists",unary,char_exists_op);
18522 @:char_exists_}{\&{charexists} primitive@>
18523 mp_primitive(mp, "fontsize",unary,font_size);
18524 @:font_size_}{\&{fontsize} primitive@>
18525 mp_primitive(mp, "llcorner",unary,ll_corner_op);
18526 @:ll_corner_}{\&{llcorner} primitive@>
18527 mp_primitive(mp, "lrcorner",unary,lr_corner_op);
18528 @:lr_corner_}{\&{lrcorner} primitive@>
18529 mp_primitive(mp, "ulcorner",unary,ul_corner_op);
18530 @:ul_corner_}{\&{ulcorner} primitive@>
18531 mp_primitive(mp, "urcorner",unary,ur_corner_op);
18532 @:ur_corner_}{\&{urcorner} primitive@>
18533 mp_primitive(mp, "arclength",unary,arc_length);
18534 @:arc_length_}{\&{arclength} primitive@>
18535 mp_primitive(mp, "angle",unary,angle_op);
18536 @:angle_}{\&{angle} primitive@>
18537 mp_primitive(mp, "cycle",cycle,cycle_op);
18538 @:cycle_}{\&{cycle} primitive@>
18539 mp_primitive(mp, "stroked",unary,stroked_op);
18540 @:stroked_}{\&{stroked} primitive@>
18541 mp_primitive(mp, "filled",unary,filled_op);
18542 @:filled_}{\&{filled} primitive@>
18543 mp_primitive(mp, "textual",unary,textual_op);
18544 @:textual_}{\&{textual} primitive@>
18545 mp_primitive(mp, "clipped",unary,clipped_op);
18546 @:clipped_}{\&{clipped} primitive@>
18547 mp_primitive(mp, "bounded",unary,bounded_op);
18548 @:bounded_}{\&{bounded} primitive@>
18549 mp_primitive(mp, "+",plus_or_minus,plus);
18550 @:+ }{\.{+} primitive@>
18551 mp_primitive(mp, "-",plus_or_minus,minus);
18552 @:- }{\.{-} primitive@>
18553 mp_primitive(mp, "*",secondary_binary,times);
18554 @:* }{\.{*} primitive@>
18555 mp_primitive(mp, "/",slash,over); mp->eqtb[frozen_slash]=mp->eqtb[mp->cur_sym];
18556 @:/ }{\.{/} primitive@>
18557 mp_primitive(mp, "++",tertiary_binary,pythag_add);
18558 @:++_}{\.{++} primitive@>
18559 mp_primitive(mp, "+-+",tertiary_binary,pythag_sub);
18560 @:+-+_}{\.{+-+} primitive@>
18561 mp_primitive(mp, "or",tertiary_binary,or_op);
18562 @:or_}{\&{or} primitive@>
18563 mp_primitive(mp, "and",and_command,and_op);
18564 @:and_}{\&{and} primitive@>
18565 mp_primitive(mp, "<",expression_binary,less_than);
18566 @:< }{\.{<} primitive@>
18567 mp_primitive(mp, "<=",expression_binary,less_or_equal);
18568 @:<=_}{\.{<=} primitive@>
18569 mp_primitive(mp, ">",expression_binary,greater_than);
18570 @:> }{\.{>} primitive@>
18571 mp_primitive(mp, ">=",expression_binary,greater_or_equal);
18572 @:>=_}{\.{>=} primitive@>
18573 mp_primitive(mp, "=",equals,equal_to);
18574 @:= }{\.{=} primitive@>
18575 mp_primitive(mp, "<>",expression_binary,unequal_to);
18576 @:<>_}{\.{<>} primitive@>
18577 mp_primitive(mp, "substring",primary_binary,substring_of);
18578 @:substring_}{\&{substring} primitive@>
18579 mp_primitive(mp, "subpath",primary_binary,subpath_of);
18580 @:subpath_}{\&{subpath} primitive@>
18581 mp_primitive(mp, "directiontime",primary_binary,direction_time_of);
18582 @:direction_time_}{\&{directiontime} primitive@>
18583 mp_primitive(mp, "point",primary_binary,point_of);
18584 @:point_}{\&{point} primitive@>
18585 mp_primitive(mp, "precontrol",primary_binary,precontrol_of);
18586 @:precontrol_}{\&{precontrol} primitive@>
18587 mp_primitive(mp, "postcontrol",primary_binary,postcontrol_of);
18588 @:postcontrol_}{\&{postcontrol} primitive@>
18589 mp_primitive(mp, "penoffset",primary_binary,pen_offset_of);
18590 @:pen_offset_}{\&{penoffset} primitive@>
18591 mp_primitive(mp, "arctime",primary_binary,arc_time_of);
18592 @:arc_time_of_}{\&{arctime} primitive@>
18593 mp_primitive(mp, "mpversion",nullary,mp_version);
18594 @:mp_verison_}{\&{mpversion} primitive@>
18595 mp_primitive(mp, "&",ampersand,concatenate);
18596 @:!!!}{\.{\&} primitive@>
18597 mp_primitive(mp, "rotated",secondary_binary,rotated_by);
18598 @:rotated_}{\&{rotated} primitive@>
18599 mp_primitive(mp, "slanted",secondary_binary,slanted_by);
18600 @:slanted_}{\&{slanted} primitive@>
18601 mp_primitive(mp, "scaled",secondary_binary,scaled_by);
18602 @:scaled_}{\&{scaled} primitive@>
18603 mp_primitive(mp, "shifted",secondary_binary,shifted_by);
18604 @:shifted_}{\&{shifted} primitive@>
18605 mp_primitive(mp, "transformed",secondary_binary,transformed_by);
18606 @:transformed_}{\&{transformed} primitive@>
18607 mp_primitive(mp, "xscaled",secondary_binary,x_scaled);
18608 @:x_scaled_}{\&{xscaled} primitive@>
18609 mp_primitive(mp, "yscaled",secondary_binary,y_scaled);
18610 @:y_scaled_}{\&{yscaled} primitive@>
18611 mp_primitive(mp, "zscaled",secondary_binary,z_scaled);
18612 @:z_scaled_}{\&{zscaled} primitive@>
18613 mp_primitive(mp, "infont",secondary_binary,in_font);
18614 @:in_font_}{\&{infont} primitive@>
18615 mp_primitive(mp, "intersectiontimes",tertiary_binary,intersect);
18616 @:intersection_times_}{\&{intersectiontimes} primitive@>
18617 mp_primitive(mp, "envelope",primary_binary,envelope_of);
18618 @:envelope_}{\&{envelope} primitive@>
18620 @ @<Cases of |print_cmd...@>=
18623 case primary_binary:
18624 case secondary_binary:
18625 case tertiary_binary:
18626 case expression_binary:
18628 case plus_or_minus:
18633 mp_print_op(mp, m);
18636 @ OK, let's look at the simplest \\{do} procedure first.
18638 @c @<Declare nullary action procedure@>
18639 void mp_do_nullary (MP mp,quarterword c) {
18641 if ( mp->internal[mp_tracing_commands]>two )
18642 mp_show_cmd_mod(mp, nullary,c);
18644 case true_code: case false_code:
18645 mp->cur_type=mp_boolean_type; mp->cur_exp=c;
18647 case null_picture_code:
18648 mp->cur_type=mp_picture_type;
18649 mp->cur_exp=mp_get_node(mp, edge_header_size);
18650 mp_init_edges(mp, mp->cur_exp);
18652 case null_pen_code:
18653 mp->cur_type=mp_pen_type; mp->cur_exp=mp_get_pen_circle(mp, 0);
18655 case normal_deviate:
18656 mp->cur_type=mp_known; mp->cur_exp=mp_norm_rand(mp);
18659 mp->cur_type=mp_pen_type; mp->cur_exp=mp_get_pen_circle(mp, unity);
18662 if ( mp->job_name==NULL ) mp_open_log_file(mp);
18663 mp->cur_type=mp_string_type; mp->cur_exp=rts(mp->job_name);
18666 mp->cur_type=mp_string_type;
18667 mp->cur_exp=intern(metapost_version) ;
18669 case read_string_op:
18670 @<Read a string from the terminal@>;
18672 } /* there are no other cases */
18676 @ @<Read a string...@>=
18678 if (mp->noninteractive || mp->interaction<=mp_nonstop_mode )
18679 mp_fatal_error(mp, "*** (cannot readstring in nonstop modes)");
18680 mp_begin_file_reading(mp); name=is_read;
18681 limit=start; prompt_input("");
18682 mp_finish_read(mp);
18685 @ @<Declare nullary action procedure@>=
18686 void mp_finish_read (MP mp) { /* copy |buffer| line to |cur_exp| */
18688 str_room((int)mp->last-start);
18689 for (k=start;k<=mp->last-1;k++) {
18690 append_char(mp->buffer[k]);
18692 mp_end_file_reading(mp); mp->cur_type=mp_string_type;
18693 mp->cur_exp=mp_make_string(mp);
18696 @ Things get a bit more interesting when there's an operand. The
18697 operand to |do_unary| appears in |cur_type| and |cur_exp|.
18699 @c @<Declare unary action procedures@>
18700 void mp_do_unary (MP mp,quarterword c) {
18701 pointer p,q,r; /* for list manipulation */
18702 integer x; /* a temporary register */
18704 if ( mp->internal[mp_tracing_commands]>two )
18705 @<Trace the current unary operation@>;
18708 if ( mp->cur_type<mp_color_type ) mp_bad_unary(mp, plus);
18711 @<Negate the current expression@>;
18713 @<Additional cases of unary operators@>;
18714 } /* there are no other cases */
18718 @ The |nice_pair| function returns |true| if both components of a pair
18721 @<Declare unary action procedures@>=
18722 boolean mp_nice_pair (MP mp,integer p, quarterword t) {
18723 if ( t==mp_pair_type ) {
18725 if ( type(x_part_loc(p))==mp_known )
18726 if ( type(y_part_loc(p))==mp_known )
18732 @ The |nice_color_or_pair| function is analogous except that it also accepts
18733 fully known colors.
18735 @<Declare unary action procedures@>=
18736 boolean mp_nice_color_or_pair (MP mp,integer p, quarterword t) {
18737 pointer q,r; /* for scanning the big node */
18738 if ( (t!=mp_pair_type)&&(t!=mp_color_type)&&(t!=mp_cmykcolor_type) ) {
18742 r=q+mp->big_node_size[type(p)];
18745 if ( type(r)!=mp_known )
18752 @ @<Declare unary action...@>=
18753 void mp_print_known_or_unknown_type (MP mp,small_number t, integer v) {
18754 mp_print_char(mp, '(');
18755 if ( t>mp_known ) mp_print(mp, "unknown numeric");
18756 else { if ( (t==mp_pair_type)||(t==mp_color_type)||(t==mp_cmykcolor_type) )
18757 if ( ! mp_nice_color_or_pair(mp, v,t) ) mp_print(mp, "unknown ");
18758 mp_print_type(mp, t);
18760 mp_print_char(mp, ')');
18763 @ @<Declare unary action...@>=
18764 void mp_bad_unary (MP mp,quarterword c) {
18765 exp_err("Not implemented: "); mp_print_op(mp, c);
18766 @.Not implemented...@>
18767 mp_print_known_or_unknown_type(mp, mp->cur_type,mp->cur_exp);
18768 help3("I'm afraid I don't know how to apply that operation to that")
18769 ("particular type. Continue, and I'll simply return the")
18770 ("argument (shown above) as the result of the operation.");
18771 mp_put_get_error(mp);
18774 @ @<Trace the current unary operation@>=
18776 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
18777 mp_print_op(mp, c); mp_print_char(mp, '(');
18778 mp_print_exp(mp, null,0); /* show the operand, but not verbosely */
18779 mp_print(mp, ")}"); mp_end_diagnostic(mp, false);
18782 @ Negation is easy except when the current expression
18783 is of type |independent|, or when it is a pair with one or more
18784 |independent| components.
18786 It is tempting to argue that the negative of an independent variable
18787 is an independent variable, hence we don't have to do anything when
18788 negating it. The fallacy is that other dependent variables pointing
18789 to the current expression must change the sign of their
18790 coefficients if we make no change to the current expression.
18792 Instead, we work around the problem by copying the current expression
18793 and recycling it afterwards (cf.~the |stash_in| routine).
18795 @<Negate the current expression@>=
18796 switch (mp->cur_type) {
18797 case mp_color_type:
18798 case mp_cmykcolor_type:
18800 case mp_independent:
18801 q=mp->cur_exp; mp_make_exp_copy(mp, q);
18802 if ( mp->cur_type==mp_dependent ) {
18803 mp_negate_dep_list(mp, dep_list(mp->cur_exp));
18804 } else if ( mp->cur_type<=mp_pair_type ) { /* |mp_color_type| or |mp_pair_type| */
18805 p=value(mp->cur_exp);
18806 r=p+mp->big_node_size[mp->cur_type];
18809 if ( type(r)==mp_known ) negate(value(r));
18810 else mp_negate_dep_list(mp, dep_list(r));
18812 } /* if |cur_type=mp_known| then |cur_exp=0| */
18813 mp_recycle_value(mp, q); mp_free_node(mp, q,value_node_size);
18816 case mp_proto_dependent:
18817 mp_negate_dep_list(mp, dep_list(mp->cur_exp));
18820 negate(mp->cur_exp);
18823 mp_bad_unary(mp, minus);
18827 @ @<Declare unary action...@>=
18828 void mp_negate_dep_list (MP mp,pointer p) {
18831 if ( info(p)==null ) return;
18836 @ @<Additional cases of unary operators@>=
18838 if ( mp->cur_type!=mp_boolean_type ) mp_bad_unary(mp, not_op);
18839 else mp->cur_exp=true_code+false_code-mp->cur_exp;
18842 @ @d three_sixty_units 23592960 /* that's |360*unity| */
18843 @d boolean_reset(A) if ( (A) ) mp->cur_exp=true_code; else mp->cur_exp=false_code
18845 @<Additional cases of unary operators@>=
18852 case uniform_deviate:
18854 case char_exists_op:
18855 if ( mp->cur_type!=mp_known ) {
18856 mp_bad_unary(mp, c);
18859 case sqrt_op:mp->cur_exp=mp_square_rt(mp, mp->cur_exp);break;
18860 case m_exp_op:mp->cur_exp=mp_m_exp(mp, mp->cur_exp);break;
18861 case m_log_op:mp->cur_exp=mp_m_log(mp, mp->cur_exp);break;
18864 mp_n_sin_cos(mp, (mp->cur_exp % three_sixty_units)*16);
18865 if ( c==sin_d_op ) mp->cur_exp=mp_round_fraction(mp, mp->n_sin);
18866 else mp->cur_exp=mp_round_fraction(mp, mp->n_cos);
18868 case floor_op:mp->cur_exp=mp_floor_scaled(mp, mp->cur_exp);break;
18869 case uniform_deviate:mp->cur_exp=mp_unif_rand(mp, mp->cur_exp);break;
18871 boolean_reset(odd(mp_round_unscaled(mp, mp->cur_exp)));
18872 mp->cur_type=mp_boolean_type;
18874 case char_exists_op:
18875 @<Determine if a character has been shipped out@>;
18877 } /* there are no other cases */
18881 @ @<Additional cases of unary operators@>=
18883 if ( mp_nice_pair(mp, mp->cur_exp,mp->cur_type) ) {
18884 p=value(mp->cur_exp);
18885 x=mp_n_arg(mp, value(x_part_loc(p)),value(y_part_loc(p)));
18886 if ( x>=0 ) mp_flush_cur_exp(mp, (x+8)/ 16);
18887 else mp_flush_cur_exp(mp, -((-x+8)/ 16));
18889 mp_bad_unary(mp, angle_op);
18893 @ If the current expression is a pair, but the context wants it to
18894 be a path, we call |pair_to_path|.
18896 @<Declare unary action...@>=
18897 void mp_pair_to_path (MP mp) {
18898 mp->cur_exp=mp_new_knot(mp);
18899 mp->cur_type=mp_path_type;
18903 @d pict_color_type(A) ((link(dummy_loc(mp->cur_exp))!=null) &&
18904 (has_color(link(dummy_loc(mp->cur_exp)))) &&
18905 ((color_model(link(dummy_loc(mp->cur_exp)))==A)
18907 ((color_model(link(dummy_loc(mp->cur_exp)))==mp_uninitialized_model) &&
18908 (mp->internal[mp_default_color_model]/unity)==(A))))
18910 @<Additional cases of unary operators@>=
18913 if ( (mp->cur_type==mp_pair_type)||(mp->cur_type==mp_transform_type) )
18914 mp_take_part(mp, c);
18915 else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
18916 else mp_bad_unary(mp, c);
18922 if ( mp->cur_type==mp_transform_type ) mp_take_part(mp, c);
18923 else if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
18924 else mp_bad_unary(mp, c);
18929 if ( mp->cur_type==mp_color_type ) mp_take_part(mp, c);
18930 else if ( mp->cur_type==mp_picture_type ) {
18931 if pict_color_type(mp_rgb_model) mp_take_pict_part(mp, c);
18932 else mp_bad_color_part(mp, c);
18934 else mp_bad_unary(mp, c);
18940 if ( mp->cur_type==mp_cmykcolor_type) mp_take_part(mp, c);
18941 else if ( mp->cur_type==mp_picture_type ) {
18942 if pict_color_type(mp_cmyk_model) mp_take_pict_part(mp, c);
18943 else mp_bad_color_part(mp, c);
18945 else mp_bad_unary(mp, c);
18948 if ( mp->cur_type==mp_known ) mp->cur_exp=value(c);
18949 else if ( mp->cur_type==mp_picture_type ) {
18950 if pict_color_type(mp_grey_model) mp_take_pict_part(mp, c);
18951 else mp_bad_color_part(mp, c);
18953 else mp_bad_unary(mp, c);
18955 case color_model_part:
18956 if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
18957 else mp_bad_unary(mp, c);
18960 @ @<Declarations@>=
18961 void mp_bad_color_part(MP mp, quarterword c);
18964 void mp_bad_color_part(MP mp, quarterword c) {
18965 pointer p; /* the big node */
18966 p=link(dummy_loc(mp->cur_exp));
18967 exp_err("Wrong picture color model: "); mp_print_op(mp, c);
18968 @.Wrong picture color model...@>
18969 if (color_model(p)==mp_grey_model)
18970 mp_print(mp, " of grey object");
18971 else if (color_model(p)==mp_cmyk_model)
18972 mp_print(mp, " of cmyk object");
18973 else if (color_model(p)==mp_rgb_model)
18974 mp_print(mp, " of rgb object");
18975 else if (color_model(p)==mp_no_model)
18976 mp_print(mp, " of marking object");
18978 mp_print(mp," of defaulted object");
18979 help3("You can only ask for the redpart, greenpart, bluepart of a rgb object,")
18980 ("the cyanpart, magentapart, yellowpart or blackpart of a cmyk object, ")
18981 ("or the greypart of a grey object. No mixing and matching, please.");
18984 mp_flush_cur_exp(mp,unity);
18986 mp_flush_cur_exp(mp,0);
18989 @ In the following procedure, |cur_exp| points to a capsule, which points to
18990 a big node. We want to delete all but one part of the big node.
18992 @<Declare unary action...@>=
18993 void mp_take_part (MP mp,quarterword c) {
18994 pointer p; /* the big node */
18995 p=value(mp->cur_exp); value(temp_val)=p; type(temp_val)=mp->cur_type;
18996 link(p)=temp_val; mp_free_node(mp, mp->cur_exp,value_node_size);
18997 mp_make_exp_copy(mp, p+mp->sector_offset[c+mp_x_part_sector-x_part]);
18998 mp_recycle_value(mp, temp_val);
19001 @ @<Initialize table entries...@>=
19002 name_type(temp_val)=mp_capsule;
19004 @ @<Additional cases of unary operators@>=
19010 if ( mp->cur_type==mp_picture_type ) mp_take_pict_part(mp, c);
19011 else mp_bad_unary(mp, c);
19014 @ @<Declarations@>=
19015 void mp_scale_edges (MP mp);
19017 @ @<Declare unary action...@>=
19018 void mp_take_pict_part (MP mp,quarterword c) {
19019 pointer p; /* first graphical object in |cur_exp| */
19020 p=link(dummy_loc(mp->cur_exp));
19023 case x_part: case y_part: case xx_part:
19024 case xy_part: case yx_part: case yy_part:
19025 if ( type(p)==mp_text_code ) mp_flush_cur_exp(mp, text_trans_part(p+c));
19026 else goto NOT_FOUND;
19028 case red_part: case green_part: case blue_part:
19029 if ( has_color(p) ) mp_flush_cur_exp(mp, obj_color_part(p+c));
19030 else goto NOT_FOUND;
19032 case cyan_part: case magenta_part: case yellow_part:
19034 if ( has_color(p) ) {
19035 if ( color_model(p)==mp_uninitialized_model && c==black_part)
19036 mp_flush_cur_exp(mp, unity);
19038 mp_flush_cur_exp(mp, obj_color_part(p+c+(red_part-cyan_part)));
19039 } else goto NOT_FOUND;
19042 if ( has_color(p) )
19043 mp_flush_cur_exp(mp, obj_color_part(p+c+(red_part-grey_part)));
19044 else goto NOT_FOUND;
19046 case color_model_part:
19047 if ( has_color(p) ) {
19048 if ( color_model(p)==mp_uninitialized_model )
19049 mp_flush_cur_exp(mp, mp->internal[mp_default_color_model]);
19051 mp_flush_cur_exp(mp, color_model(p)*unity);
19052 } else goto NOT_FOUND;
19054 @<Handle other cases in |take_pict_part| or |goto not_found|@>;
19055 } /* all cases have been enumerated */
19059 @<Convert the current expression to a null value appropriate
19063 @ @<Handle other cases in |take_pict_part| or |goto not_found|@>=
19065 if ( type(p)!=mp_text_code ) goto NOT_FOUND;
19067 mp_flush_cur_exp(mp, text_p(p));
19068 add_str_ref(mp->cur_exp);
19069 mp->cur_type=mp_string_type;
19073 if ( type(p)!=mp_text_code ) goto NOT_FOUND;
19075 mp_flush_cur_exp(mp, rts(mp->font_name[font_n(p)]));
19076 add_str_ref(mp->cur_exp);
19077 mp->cur_type=mp_string_type;
19081 if ( type(p)==mp_text_code ) goto NOT_FOUND;
19082 else if ( is_stop(p) ) mp_confusion(mp, "pict");
19083 @:this can't happen pict}{\quad pict@>
19085 mp_flush_cur_exp(mp, mp_copy_path(mp, path_p(p)));
19086 mp->cur_type=mp_path_type;
19090 if ( ! has_pen(p) ) goto NOT_FOUND;
19092 if ( pen_p(p)==null ) goto NOT_FOUND;
19093 else { mp_flush_cur_exp(mp, copy_pen(pen_p(p)));
19094 mp->cur_type=mp_pen_type;
19099 if ( type(p)!=mp_stroked_code ) goto NOT_FOUND;
19100 else { if ( dash_p(p)==null ) goto NOT_FOUND;
19101 else { add_edge_ref(dash_p(p));
19102 mp->se_sf=dash_scale(p);
19103 mp->se_pic=dash_p(p);
19104 mp_scale_edges(mp);
19105 mp_flush_cur_exp(mp, mp->se_pic);
19106 mp->cur_type=mp_picture_type;
19111 @ Since |scale_edges| had to be declared |forward|, it had to be declared as a
19112 parameterless procedure even though it really takes two arguments and updates
19113 one of them. Hence the following globals are needed.
19116 pointer se_pic; /* edge header used and updated by |scale_edges| */
19117 scaled se_sf; /* the scale factor argument to |scale_edges| */
19119 @ @<Convert the current expression to a null value appropriate...@>=
19121 case text_part: case font_part:
19122 mp_flush_cur_exp(mp, rts(""));
19123 mp->cur_type=mp_string_type;
19126 mp_flush_cur_exp(mp, mp_get_node(mp, knot_node_size));
19127 left_type(mp->cur_exp)=mp_endpoint;
19128 right_type(mp->cur_exp)=mp_endpoint;
19129 link(mp->cur_exp)=mp->cur_exp;
19130 x_coord(mp->cur_exp)=0;
19131 y_coord(mp->cur_exp)=0;
19132 originator(mp->cur_exp)=mp_metapost_user;
19133 mp->cur_type=mp_path_type;
19136 mp_flush_cur_exp(mp, mp_get_pen_circle(mp, 0));
19137 mp->cur_type=mp_pen_type;
19140 mp_flush_cur_exp(mp, mp_get_node(mp, edge_header_size));
19141 mp_init_edges(mp, mp->cur_exp);
19142 mp->cur_type=mp_picture_type;
19145 mp_flush_cur_exp(mp, 0);
19149 @ @<Additional cases of unary...@>=
19151 if ( mp->cur_type!=mp_known ) {
19152 mp_bad_unary(mp, char_op);
19154 mp->cur_exp=mp_round_unscaled(mp, mp->cur_exp) % 256;
19155 mp->cur_type=mp_string_type;
19156 if ( mp->cur_exp<0 ) mp->cur_exp=mp->cur_exp+256;
19160 if ( mp->cur_type!=mp_known ) {
19161 mp_bad_unary(mp, decimal);
19163 mp->old_setting=mp->selector; mp->selector=new_string;
19164 mp_print_scaled(mp, mp->cur_exp); mp->cur_exp=mp_make_string(mp);
19165 mp->selector=mp->old_setting; mp->cur_type=mp_string_type;
19171 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, c);
19172 else mp_str_to_num(mp, c);
19175 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, font_size);
19176 else @<Find the design size of the font whose name is |cur_exp|@>;
19179 @ @<Declare unary action...@>=
19180 void mp_str_to_num (MP mp,quarterword c) { /* converts a string to a number */
19181 integer n; /* accumulator */
19182 ASCII_code m; /* current character */
19183 pool_pointer k; /* index into |str_pool| */
19184 int b; /* radix of conversion */
19185 boolean bad_char; /* did the string contain an invalid digit? */
19186 if ( c==ASCII_op ) {
19187 if ( length(mp->cur_exp)==0 ) n=-1;
19188 else n=mp->str_pool[mp->str_start[mp->cur_exp]];
19190 if ( c==oct_op ) b=8; else b=16;
19191 n=0; bad_char=false;
19192 for (k=mp->str_start[mp->cur_exp];k<=str_stop(mp->cur_exp)-1;k++) {
19194 if ( (m>='0')&&(m<='9') ) m=m-'0';
19195 else if ( (m>='A')&&(m<='F') ) m=m-'A'+10;
19196 else if ( (m>='a')&&(m<='f') ) m=m-'a'+10;
19197 else { bad_char=true; m=0; };
19198 if ( m>=b ) { bad_char=true; m=0; };
19199 if ( n<32768 / b ) n=n*b+m; else n=32767;
19201 @<Give error messages if |bad_char| or |n>=4096|@>;
19203 mp_flush_cur_exp(mp, n*unity);
19206 @ @<Give error messages if |bad_char|...@>=
19208 exp_err("String contains illegal digits");
19209 @.String contains illegal digits@>
19211 help1("I zeroed out characters that weren't in the range 0..7.");
19213 help1("I zeroed out characters that weren't hex digits.");
19215 mp_put_get_error(mp);
19218 if ( mp->internal[mp_warning_check]>0 ) {
19219 print_err("Number too large (");
19220 mp_print_int(mp, n); mp_print_char(mp, ')');
19221 @.Number too large@>
19222 help2("I have trouble with numbers greater than 4095; watch out.")
19223 ("(Set warningcheck:=0 to suppress this message.)");
19224 mp_put_get_error(mp);
19228 @ The length operation is somewhat unusual in that it applies to a variety
19229 of different types of operands.
19231 @<Additional cases of unary...@>=
19233 switch (mp->cur_type) {
19234 case mp_string_type: mp_flush_cur_exp(mp, length(mp->cur_exp)*unity); break;
19235 case mp_path_type: mp_flush_cur_exp(mp, mp_path_length(mp)); break;
19236 case mp_known: mp->cur_exp=abs(mp->cur_exp); break;
19237 case mp_picture_type: mp_flush_cur_exp(mp, mp_pict_length(mp)); break;
19239 if ( mp_nice_pair(mp, mp->cur_exp,mp->cur_type) )
19240 mp_flush_cur_exp(mp, mp_pyth_add(mp,
19241 value(x_part_loc(value(mp->cur_exp))),
19242 value(y_part_loc(value(mp->cur_exp)))));
19243 else mp_bad_unary(mp, c);
19248 @ @<Declare unary action...@>=
19249 scaled mp_path_length (MP mp) { /* computes the length of the current path */
19250 scaled n; /* the path length so far */
19251 pointer p; /* traverser */
19253 if ( left_type(p)==mp_endpoint ) n=-unity; else n=0;
19254 do { p=link(p); n=n+unity; } while (p!=mp->cur_exp);
19258 @ @<Declare unary action...@>=
19259 scaled mp_pict_length (MP mp) {
19260 /* counts interior components in picture |cur_exp| */
19261 scaled n; /* the count so far */
19262 pointer p; /* traverser */
19264 p=link(dummy_loc(mp->cur_exp));
19266 if ( is_start_or_stop(p) )
19267 if ( mp_skip_1component(mp, p)==null ) p=link(p);
19268 while ( p!=null ) {
19269 skip_component(p) return n;
19276 @ Implement |turningnumber|
19278 @<Additional cases of unary...@>=
19280 if ( mp->cur_type==mp_pair_type ) mp_flush_cur_exp(mp, 0);
19281 else if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, turning_op);
19282 else if ( left_type(mp->cur_exp)==mp_endpoint )
19283 mp_flush_cur_exp(mp, 0); /* not a cyclic path */
19285 mp_flush_cur_exp(mp, mp_turn_cycles_wrapper(mp, mp->cur_exp));
19288 @ The function |an_angle| returns the value of the |angle| primitive, or $0$ if the
19289 argument is |origin|.
19291 @<Declare unary action...@>=
19292 angle mp_an_angle (MP mp,scaled xpar, scaled ypar) {
19293 if ( (! ((xpar==0) && (ypar==0))) )
19294 return mp_n_arg(mp, xpar,ypar);
19299 @ The actual turning number is (for the moment) computed in a C function
19300 that receives eight integers corresponding to the four controlling points,
19301 and returns a single angle. Besides those, we have to account for discrete
19302 moves at the actual points.
19304 @d floor(a) (a>=0 ? a : -(int)(-a))
19305 @d bezier_error (720<<20)+1
19306 @d sign(v) ((v)>0 ? 1 : ((v)<0 ? -1 : 0 ))
19308 @d out ((double)(xo>>20))
19309 @d mid ((double)(xm>>20))
19310 @d in ((double)(xi>>20))
19311 @d divisor (256*256)
19312 @d double2angle(a) (int)floor(a*256.0*256.0*16.0)
19314 @<Declare unary action...@>=
19315 angle mp_bezier_slope(MP mp, integer AX,integer AY,integer BX,integer BY,
19316 integer CX,integer CY,integer DX,integer DY);
19319 angle mp_bezier_slope(MP mp, integer AX,integer AY,integer BX,integer BY,
19320 integer CX,integer CY,integer DX,integer DY) {
19322 integer deltax,deltay;
19323 double ax,ay,bx,by,cx,cy,dx,dy;
19324 angle xi = 0, xo = 0, xm = 0;
19326 ax=AX/divisor; ay=AY/divisor;
19327 bx=BX/divisor; by=BY/divisor;
19328 cx=CX/divisor; cy=CY/divisor;
19329 dx=DX/divisor; dy=DY/divisor;
19331 deltax = (BX-AX); deltay = (BY-AY);
19332 if (deltax==0 && deltay == 0) { deltax=(CX-AX); deltay=(CY-AY); }
19333 if (deltax==0 && deltay == 0) { deltax=(DX-AX); deltay=(DY-AY); }
19334 xi = mp_an_angle(mp,deltax,deltay);
19336 deltax = (CX-BX); deltay = (CY-BY);
19337 xm = mp_an_angle(mp,deltax,deltay);
19339 deltax = (DX-CX); deltay = (DY-CY);
19340 if (deltax==0 && deltay == 0) { deltax=(DX-BX); deltay=(DY-BY); }
19341 if (deltax==0 && deltay == 0) { deltax=(DX-AX); deltay=(DY-AY); }
19342 xo = mp_an_angle(mp,deltax,deltay);
19344 a = (bx-ax)*(cy-by) - (cx-bx)*(by-ay); /* a = (bp-ap)x(cp-bp); */
19345 b = (bx-ax)*(dy-cy) - (by-ay)*(dx-cx);; /* b = (bp-ap)x(dp-cp);*/
19346 c = (cx-bx)*(dy-cy) - (dx-cx)*(cy-by); /* c = (cp-bp)x(dp-cp);*/
19348 if ((a==0)&&(c==0)) {
19349 res = (b==0 ? 0 : (out-in));
19350 print_roots("no roots (a)");
19351 } else if ((a==0)||(c==0)) {
19352 if ((sign(b) == sign(a)) || (sign(b) == sign(c))) {
19353 res = out-in; /* ? */
19356 else if (res>180.0)
19358 print_roots("no roots (b)");
19360 res = out-in; /* ? */
19361 print_roots("one root (a)");
19363 } else if ((sign(a)*sign(c))<0) {
19364 res = out-in; /* ? */
19367 else if (res>180.0)
19369 print_roots("one root (b)");
19371 if (sign(a) == sign(b)) {
19372 res = out-in; /* ? */
19375 else if (res>180.0)
19377 print_roots("no roots (d)");
19379 if ((b*b) == (4*a*c)) {
19380 res = bezier_error;
19381 print_roots("double root"); /* cusp */
19382 } else if ((b*b) < (4*a*c)) {
19383 res = out-in; /* ? */
19384 if (res<=0.0 &&res>-180.0)
19386 else if (res>=0.0 && res<180.0)
19388 print_roots("no roots (e)");
19393 else if (res>180.0)
19395 print_roots("two roots"); /* two inflections */
19399 return double2angle(res);
19403 @d p_nextnext link(link(p))
19405 @d seven_twenty_deg 05500000000 /* $720\cdot2^{20}$, represents $720^\circ$ */
19407 @<Declare unary action...@>=
19408 scaled mp_new_turn_cycles (MP mp,pointer c) {
19409 angle res,ang; /* the angles of intermediate results */
19410 scaled turns; /* the turn counter */
19411 pointer p; /* for running around the path */
19412 integer xp,yp; /* coordinates of next point */
19413 integer x,y; /* helper coordinates */
19414 angle in_angle,out_angle; /* helper angles */
19415 int old_setting; /* saved |selector| setting */
19419 old_setting = mp->selector; mp->selector=term_only;
19420 if ( mp->internal[mp_tracing_commands]>unity ) {
19421 mp_begin_diagnostic(mp);
19422 mp_print_nl(mp, "");
19423 mp_end_diagnostic(mp, false);
19426 xp = x_coord(p_next); yp = y_coord(p_next);
19427 ang = mp_bezier_slope(mp,x_coord(p), y_coord(p), right_x(p), right_y(p),
19428 left_x(p_next), left_y(p_next), xp, yp);
19429 if ( ang>seven_twenty_deg ) {
19430 print_err("Strange path");
19432 mp->selector=old_setting;
19436 if ( res > one_eighty_deg ) {
19437 res = res - three_sixty_deg;
19438 turns = turns + unity;
19440 if ( res <= -one_eighty_deg ) {
19441 res = res + three_sixty_deg;
19442 turns = turns - unity;
19444 /* incoming angle at next point */
19445 x = left_x(p_next); y = left_y(p_next);
19446 if ( (xp==x)&&(yp==y) ) { x = right_x(p); y = right_y(p); };
19447 if ( (xp==x)&&(yp==y) ) { x = x_coord(p); y = y_coord(p); };
19448 in_angle = mp_an_angle(mp, xp - x, yp - y);
19449 /* outgoing angle at next point */
19450 x = right_x(p_next); y = right_y(p_next);
19451 if ( (xp==x)&&(yp==y) ) { x = left_x(p_nextnext); y = left_y(p_nextnext); };
19452 if ( (xp==x)&&(yp==y) ) { x = x_coord(p_nextnext); y = y_coord(p_nextnext); };
19453 out_angle = mp_an_angle(mp, x - xp, y- yp);
19454 ang = (out_angle - in_angle);
19458 if ( res >= one_eighty_deg ) {
19459 res = res - three_sixty_deg;
19460 turns = turns + unity;
19462 if ( res <= -one_eighty_deg ) {
19463 res = res + three_sixty_deg;
19464 turns = turns - unity;
19469 mp->selector=old_setting;
19474 @ This code is based on Bogus\l{}av Jackowski's
19475 |emergency_turningnumber| macro, with some minor changes by Taco
19476 Hoekwater. The macro code looked more like this:
19478 vardef turning\_number primary p =
19479 ~~save res, ang, turns;
19481 ~~if length p <= 2:
19482 ~~~~if Angle ((point 0 of p) - (postcontrol 0 of p)) >= 0: 1 else: -1 fi
19484 ~~~~for t = 0 upto length p-1 :
19485 ~~~~~~angc := Angle ((point t+1 of p) - (point t of p))
19486 ~~~~~~~~- Angle ((point t of p) - (point t-1 of p));
19487 ~~~~~~if angc > 180: angc := angc - 360; fi;
19488 ~~~~~~if angc < -180: angc := angc + 360; fi;
19489 ~~~~~~res := res + angc;
19494 The general idea is to calculate only the sum of the angles of
19495 straight lines between the points, of a path, not worrying about cusps
19496 or self-intersections in the segments at all. If the segment is not
19497 well-behaved, the result is not necesarily correct. But the old code
19498 was not always correct either, and worse, it sometimes failed for
19499 well-behaved paths as well. All known bugs that were triggered by the
19500 original code no longer occur with this code, and it runs roughly 3
19501 times as fast because the algorithm is much simpler.
19503 @ It is possible to overflow the return value of the |turn_cycles|
19504 function when the path is sufficiently long and winding, but I am not
19505 going to bother testing for that. In any case, it would only return
19506 the looped result value, which is not a big problem.
19508 The macro code for the repeat loop was a bit nicer to look
19509 at than the pascal code, because it could use |point -1 of p|. In
19510 pascal, the fastest way to loop around the path is not to look
19511 backward once, but forward twice. These defines help hide the trick.
19513 @d p_to link(link(p))
19517 @<Declare unary action...@>=
19518 scaled mp_turn_cycles (MP mp,pointer c) {
19519 angle res,ang; /* the angles of intermediate results */
19520 scaled turns; /* the turn counter */
19521 pointer p; /* for running around the path */
19522 res=0; turns= 0; p=c;
19524 ang = mp_an_angle (mp, x_coord(p_to) - x_coord(p_here),
19525 y_coord(p_to) - y_coord(p_here))
19526 - mp_an_angle (mp, x_coord(p_here) - x_coord(p_from),
19527 y_coord(p_here) - y_coord(p_from));
19530 if ( res >= three_sixty_deg ) {
19531 res = res - three_sixty_deg;
19532 turns = turns + unity;
19534 if ( res <= -three_sixty_deg ) {
19535 res = res + three_sixty_deg;
19536 turns = turns - unity;
19543 @ @<Declare unary action...@>=
19544 scaled mp_turn_cycles_wrapper (MP mp,pointer c) {
19546 scaled saved_t_o; /* tracing\_online saved */
19547 if ( (link(c)==c)||(link(link(c))==c) ) {
19548 if ( mp_an_angle (mp, x_coord(c) - right_x(c), y_coord(c) - right_y(c)) > 0 )
19553 nval = mp_new_turn_cycles(mp, c);
19554 oval = mp_turn_cycles(mp, c);
19555 if ( nval!=oval ) {
19556 saved_t_o=mp->internal[mp_tracing_online];
19557 mp->internal[mp_tracing_online]=unity;
19558 mp_begin_diagnostic(mp);
19559 mp_print_nl (mp, "Warning: the turningnumber algorithms do not agree."
19560 " The current computed value is ");
19561 mp_print_scaled(mp, nval);
19562 mp_print(mp, ", but the 'connect-the-dots' algorithm returned ");
19563 mp_print_scaled(mp, oval);
19564 mp_end_diagnostic(mp, false);
19565 mp->internal[mp_tracing_online]=saved_t_o;
19571 @ @<Declare unary action...@>=
19572 scaled mp_count_turns (MP mp,pointer c) {
19573 pointer p; /* a knot in envelope spec |c| */
19574 integer t; /* total pen offset changes counted */
19577 t=t+info(p)-zero_off;
19580 return ((t / 3)*unity);
19583 @ @d type_range(A,B) {
19584 if ( (mp->cur_type>=(A)) && (mp->cur_type<=(B)) )
19585 mp_flush_cur_exp(mp, true_code);
19586 else mp_flush_cur_exp(mp, false_code);
19587 mp->cur_type=mp_boolean_type;
19590 if ( mp->cur_type==(A) ) mp_flush_cur_exp(mp, true_code);
19591 else mp_flush_cur_exp(mp, false_code);
19592 mp->cur_type=mp_boolean_type;
19595 @<Additional cases of unary operators@>=
19596 case mp_boolean_type:
19597 type_range(mp_boolean_type,mp_unknown_boolean); break;
19598 case mp_string_type:
19599 type_range(mp_string_type,mp_unknown_string); break;
19601 type_range(mp_pen_type,mp_unknown_pen); break;
19603 type_range(mp_path_type,mp_unknown_path); break;
19604 case mp_picture_type:
19605 type_range(mp_picture_type,mp_unknown_picture); break;
19606 case mp_transform_type: case mp_color_type: case mp_cmykcolor_type:
19608 type_test(c); break;
19609 case mp_numeric_type:
19610 type_range(mp_known,mp_independent); break;
19611 case known_op: case unknown_op:
19612 mp_test_known(mp, c); break;
19614 @ @<Declare unary action procedures@>=
19615 void mp_test_known (MP mp,quarterword c) {
19616 int b; /* is the current expression known? */
19617 pointer p,q; /* locations in a big node */
19619 switch (mp->cur_type) {
19620 case mp_vacuous: case mp_boolean_type: case mp_string_type:
19621 case mp_pen_type: case mp_path_type: case mp_picture_type:
19625 case mp_transform_type:
19626 case mp_color_type: case mp_cmykcolor_type: case mp_pair_type:
19627 p=value(mp->cur_exp);
19628 q=p+mp->big_node_size[mp->cur_type];
19631 if ( type(q)!=mp_known )
19640 if ( c==known_op ) mp_flush_cur_exp(mp, b);
19641 else mp_flush_cur_exp(mp, true_code+false_code-b);
19642 mp->cur_type=mp_boolean_type;
19645 @ @<Additional cases of unary operators@>=
19647 if ( mp->cur_type!=mp_path_type ) mp_flush_cur_exp(mp, false_code);
19648 else if ( left_type(mp->cur_exp)!=mp_endpoint ) mp_flush_cur_exp(mp, true_code);
19649 else mp_flush_cur_exp(mp, false_code);
19650 mp->cur_type=mp_boolean_type;
19653 @ @<Additional cases of unary operators@>=
19655 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19656 if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, arc_length);
19657 else mp_flush_cur_exp(mp, mp_get_arc_length(mp, mp->cur_exp));
19660 @ Here we use the fact that |c-filled_op+fill_code| is the desired graphical
19662 @^data structure assumptions@>
19664 @<Additional cases of unary operators@>=
19670 if ( mp->cur_type!=mp_picture_type ) mp_flush_cur_exp(mp, false_code);
19671 else if ( link(dummy_loc(mp->cur_exp))==null ) mp_flush_cur_exp(mp, false_code);
19672 else if ( type(link(dummy_loc(mp->cur_exp)))==c+mp_fill_code-filled_op )
19673 mp_flush_cur_exp(mp, true_code);
19674 else mp_flush_cur_exp(mp, false_code);
19675 mp->cur_type=mp_boolean_type;
19678 @ @<Additional cases of unary operators@>=
19680 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19681 if ( mp->cur_type!=mp_path_type ) mp_bad_unary(mp, make_pen_op);
19683 mp->cur_type=mp_pen_type;
19684 mp->cur_exp=mp_make_pen(mp, mp->cur_exp,true);
19688 if ( mp->cur_type!=mp_pen_type ) mp_bad_unary(mp, make_path_op);
19690 mp->cur_type=mp_path_type;
19691 mp_make_path(mp, mp->cur_exp);
19695 if ( mp->cur_type==mp_path_type ) {
19696 p=mp_htap_ypoc(mp, mp->cur_exp);
19697 if ( right_type(p)==mp_endpoint ) p=link(p);
19698 mp_toss_knot_list(mp, mp->cur_exp); mp->cur_exp=p;
19699 } else if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
19700 else mp_bad_unary(mp, reverse);
19703 @ The |pair_value| routine changes the current expression to a
19704 given ordered pair of values.
19706 @<Declare unary action procedures@>=
19707 void mp_pair_value (MP mp,scaled x, scaled y) {
19708 pointer p; /* a pair node */
19709 p=mp_get_node(mp, value_node_size);
19710 mp_flush_cur_exp(mp, p); mp->cur_type=mp_pair_type;
19711 type(p)=mp_pair_type; name_type(p)=mp_capsule; mp_init_big_node(mp, p);
19713 type(x_part_loc(p))=mp_known; value(x_part_loc(p))=x;
19714 type(y_part_loc(p))=mp_known; value(y_part_loc(p))=y;
19717 @ @<Additional cases of unary operators@>=
19719 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ll_corner_op);
19720 else mp_pair_value(mp, minx,miny);
19723 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, lr_corner_op);
19724 else mp_pair_value(mp, maxx,miny);
19727 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ul_corner_op);
19728 else mp_pair_value(mp, minx,maxy);
19731 if ( ! mp_get_cur_bbox(mp) ) mp_bad_unary(mp, ur_corner_op);
19732 else mp_pair_value(mp, maxx,maxy);
19735 @ Here is a function that sets |minx|, |maxx|, |miny|, |maxy| to the bounding
19736 box of the current expression. The boolean result is |false| if the expression
19737 has the wrong type.
19739 @<Declare unary action procedures@>=
19740 boolean mp_get_cur_bbox (MP mp) {
19741 switch (mp->cur_type) {
19742 case mp_picture_type:
19743 mp_set_bbox(mp, mp->cur_exp,true);
19744 if ( minx_val(mp->cur_exp)>maxx_val(mp->cur_exp) ) {
19745 minx=0; maxx=0; miny=0; maxy=0;
19747 minx=minx_val(mp->cur_exp);
19748 maxx=maxx_val(mp->cur_exp);
19749 miny=miny_val(mp->cur_exp);
19750 maxy=maxy_val(mp->cur_exp);
19754 mp_path_bbox(mp, mp->cur_exp);
19757 mp_pen_bbox(mp, mp->cur_exp);
19765 @ @<Additional cases of unary operators@>=
19767 case close_from_op:
19768 if ( mp->cur_type!=mp_string_type ) mp_bad_unary(mp, c);
19769 else mp_do_read_or_close(mp,c);
19772 @ Here is a routine that interprets |cur_exp| as a file name and tries to read
19773 a line from the file or to close the file.
19775 @<Declare unary action procedures@>=
19776 void mp_do_read_or_close (MP mp,quarterword c) {
19777 readf_index n,n0; /* indices for searching |rd_fname| */
19778 @<Find the |n| where |rd_fname[n]=cur_exp|; if |cur_exp| must be inserted,
19779 call |start_read_input| and |goto found| or |not_found|@>;
19780 mp_begin_file_reading(mp);
19782 if ( mp_input_ln(mp, mp->rd_file[n] ) )
19784 mp_end_file_reading(mp);
19786 @<Record the end of file and set |cur_exp| to a dummy value@>;
19789 mp_flush_cur_exp(mp, 0); mp->cur_type=mp_vacuous;
19792 mp_flush_cur_exp(mp, 0);
19793 mp_finish_read(mp);
19796 @ Free slots in the |rd_file| and |rd_fname| arrays are marked with NULL's in
19799 @<Find the |n| where |rd_fname[n]=cur_exp|...@>=
19804 fn = str(mp->cur_exp);
19805 while (mp_xstrcmp(fn,mp->rd_fname[n])!=0) {
19808 } else if ( c==close_from_op ) {
19811 if ( n0==mp->read_files ) {
19812 if ( mp->read_files<mp->max_read_files ) {
19813 incr(mp->read_files);
19818 l = mp->max_read_files + (mp->max_read_files>>2);
19819 rd_file = xmalloc((l+1), sizeof(void *));
19820 rd_fname = xmalloc((l+1), sizeof(char *));
19821 for (k=0;k<=l;k++) {
19822 if (k<=mp->max_read_files) {
19823 rd_file[k]=mp->rd_file[k];
19824 rd_fname[k]=mp->rd_fname[k];
19830 xfree(mp->rd_file); xfree(mp->rd_fname);
19831 mp->max_read_files = l;
19832 mp->rd_file = rd_file;
19833 mp->rd_fname = rd_fname;
19837 if ( mp_start_read_input(mp,fn,n) )
19842 if ( mp->rd_fname[n]==NULL ) { n0=n; }
19844 if ( c==close_from_op ) {
19845 (mp->close_file)(mp,mp->rd_file[n]);
19850 @ @<Record the end of file and set |cur_exp| to a dummy value@>=
19851 xfree(mp->rd_fname[n]);
19852 mp->rd_fname[n]=NULL;
19853 if ( n==mp->read_files-1 ) mp->read_files=n;
19854 if ( c==close_from_op )
19856 mp_flush_cur_exp(mp, mp->eof_line);
19857 mp->cur_type=mp_string_type
19859 @ The string denoting end-of-file is a one-byte string at position zero, by definition
19862 str_number eof_line;
19867 @ Finally, we have the operations that combine a capsule~|p|
19868 with the current expression.
19870 @d binary_return { mp_finish_binary(mp, old_p, old_exp); return; }
19872 @c @<Declare binary action procedures@>
19873 void mp_finish_binary (MP mp, pointer old_p, pointer old_exp ){
19875 @<Recycle any sidestepped |independent| capsules@>;
19877 void mp_do_binary (MP mp,pointer p, quarterword c) {
19878 pointer q,r,rr; /* for list manipulation */
19879 pointer old_p,old_exp; /* capsules to recycle */
19880 integer v; /* for numeric manipulation */
19882 if ( mp->internal[mp_tracing_commands]>two ) {
19883 @<Trace the current binary operation@>;
19885 @<Sidestep |independent| cases in capsule |p|@>;
19886 @<Sidestep |independent| cases in the current expression@>;
19888 case plus: case minus:
19889 @<Add or subtract the current expression from |p|@>;
19891 @<Additional cases of binary operators@>;
19892 }; /* there are no other cases */
19893 mp_recycle_value(mp, p);
19894 mp_free_node(mp, p,value_node_size); /* |return| to avoid this */
19895 mp_finish_binary(mp, old_p, old_exp);
19898 @ @<Declare binary action...@>=
19899 void mp_bad_binary (MP mp,pointer p, quarterword c) {
19900 mp_disp_err(mp, p,"");
19901 exp_err("Not implemented: ");
19902 @.Not implemented...@>
19903 if ( c>=min_of ) mp_print_op(mp, c);
19904 mp_print_known_or_unknown_type(mp, type(p),p);
19905 if ( c>=min_of ) mp_print(mp, "of"); else mp_print_op(mp, c);
19906 mp_print_known_or_unknown_type(mp, mp->cur_type,mp->cur_exp);
19907 help3("I'm afraid I don't know how to apply that operation to that")
19908 ("combination of types. Continue, and I'll return the second")
19909 ("argument (see above) as the result of the operation.");
19910 mp_put_get_error(mp);
19912 void mp_bad_envelope_pen (MP mp) {
19913 mp_disp_err(mp, null,"");
19914 exp_err("Not implemented: envelope(elliptical pen)of(path)");
19915 @.Not implemented...@>
19916 help3("I'm afraid I don't know how to apply that operation to that")
19917 ("combination of types. Continue, and I'll return the second")
19918 ("argument (see above) as the result of the operation.");
19919 mp_put_get_error(mp);
19922 @ @<Trace the current binary operation@>=
19924 mp_begin_diagnostic(mp); mp_print_nl(mp, "{(");
19925 mp_print_exp(mp,p,0); /* show the operand, but not verbosely */
19926 mp_print_char(mp,')'); mp_print_op(mp,c); mp_print_char(mp,'(');
19927 mp_print_exp(mp,null,0); mp_print(mp,")}");
19928 mp_end_diagnostic(mp, false);
19931 @ Several of the binary operations are potentially complicated by the
19932 fact that |independent| values can sneak into capsules. For example,
19933 we've seen an instance of this difficulty in the unary operation
19934 of negation. In order to reduce the number of cases that need to be
19935 handled, we first change the two operands (if necessary)
19936 to rid them of |independent| components. The original operands are
19937 put into capsules called |old_p| and |old_exp|, which will be
19938 recycled after the binary operation has been safely carried out.
19940 @<Recycle any sidestepped |independent| capsules@>=
19941 if ( old_p!=null ) {
19942 mp_recycle_value(mp, old_p); mp_free_node(mp, old_p,value_node_size);
19944 if ( old_exp!=null ) {
19945 mp_recycle_value(mp, old_exp); mp_free_node(mp, old_exp,value_node_size);
19948 @ A big node is considered to be ``tarnished'' if it contains at least one
19949 independent component. We will define a simple function called `|tarnished|'
19950 that returns |null| if and only if its argument is not tarnished.
19952 @<Sidestep |independent| cases in capsule |p|@>=
19954 case mp_transform_type:
19955 case mp_color_type:
19956 case mp_cmykcolor_type:
19958 old_p=mp_tarnished(mp, p);
19960 case mp_independent: old_p=mp_void; break;
19961 default: old_p=null; break;
19963 if ( old_p!=null ) {
19964 q=mp_stash_cur_exp(mp); old_p=p; mp_make_exp_copy(mp, old_p);
19965 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q);
19968 @ @<Sidestep |independent| cases in the current expression@>=
19969 switch (mp->cur_type) {
19970 case mp_transform_type:
19971 case mp_color_type:
19972 case mp_cmykcolor_type:
19974 old_exp=mp_tarnished(mp, mp->cur_exp);
19976 case mp_independent:old_exp=mp_void; break;
19977 default: old_exp=null; break;
19979 if ( old_exp!=null ) {
19980 old_exp=mp->cur_exp; mp_make_exp_copy(mp, old_exp);
19983 @ @<Declare binary action...@>=
19984 pointer mp_tarnished (MP mp,pointer p) {
19985 pointer q; /* beginning of the big node */
19986 pointer r; /* current position in the big node */
19987 q=value(p); r=q+mp->big_node_size[type(p)];
19990 if ( type(r)==mp_independent ) return mp_void;
19995 @ @<Add or subtract the current expression from |p|@>=
19996 if ( (mp->cur_type<mp_color_type)||(type(p)<mp_color_type) ) {
19997 mp_bad_binary(mp, p,c);
19999 if ((mp->cur_type>mp_pair_type)&&(type(p)>mp_pair_type) ) {
20000 mp_add_or_subtract(mp, p,null,c);
20002 if ( mp->cur_type!=type(p) ) {
20003 mp_bad_binary(mp, p,c);
20005 q=value(p); r=value(mp->cur_exp);
20006 rr=r+mp->big_node_size[mp->cur_type];
20008 mp_add_or_subtract(mp, q,r,c);
20015 @ The first argument to |add_or_subtract| is the location of a value node
20016 in a capsule or pair node that will soon be recycled. The second argument
20017 is either a location within a pair or transform node of |cur_exp|,
20018 or it is null (which means that |cur_exp| itself should be the second
20019 argument). The third argument is either |plus| or |minus|.
20021 The sum or difference of the numeric quantities will replace the second
20022 operand. Arithmetic overflow may go undetected; users aren't supposed to
20023 be monkeying around with really big values.
20024 @^overflow in arithmetic@>
20026 @<Declare binary action...@>=
20027 @<Declare the procedure called |dep_finish|@>
20028 void mp_add_or_subtract (MP mp,pointer p, pointer q, quarterword c) {
20029 small_number s,t; /* operand types */
20030 pointer r; /* list traverser */
20031 integer v; /* second operand value */
20034 if ( t<mp_dependent ) v=mp->cur_exp; else v=dep_list(mp->cur_exp);
20037 if ( t<mp_dependent ) v=value(q); else v=dep_list(q);
20039 if ( t==mp_known ) {
20040 if ( c==minus ) negate(v);
20041 if ( type(p)==mp_known ) {
20042 v=mp_slow_add(mp, value(p),v);
20043 if ( q==null ) mp->cur_exp=v; else value(q)=v;
20046 @<Add a known value to the constant term of |dep_list(p)|@>;
20048 if ( c==minus ) mp_negate_dep_list(mp, v);
20049 @<Add operand |p| to the dependency list |v|@>;
20053 @ @<Add a known value to the constant term of |dep_list(p)|@>=
20055 while ( info(r)!=null ) r=link(r);
20056 value(r)=mp_slow_add(mp, value(r),v);
20058 q=mp_get_node(mp, value_node_size); mp->cur_exp=q; mp->cur_type=type(p);
20059 name_type(q)=mp_capsule;
20061 dep_list(q)=dep_list(p); type(q)=type(p);
20062 prev_dep(q)=prev_dep(p); link(prev_dep(p))=q;
20063 type(p)=mp_known; /* this will keep the recycler from collecting non-garbage */
20065 @ We prefer |dependent| lists to |mp_proto_dependent| ones, because it is
20066 nice to retain the extra accuracy of |fraction| coefficients.
20067 But we have to handle both kinds, and mixtures too.
20069 @<Add operand |p| to the dependency list |v|@>=
20070 if ( type(p)==mp_known ) {
20071 @<Add the known |value(p)| to the constant term of |v|@>;
20073 s=type(p); r=dep_list(p);
20074 if ( t==mp_dependent ) {
20075 if ( s==mp_dependent ) {
20076 if ( mp_max_coef(mp, r)+mp_max_coef(mp, v)<coef_bound )
20077 v=mp_p_plus_q(mp, v,r,mp_dependent); goto DONE;
20078 } /* |fix_needed| will necessarily be false */
20079 t=mp_proto_dependent;
20080 v=mp_p_over_v(mp, v,unity,mp_dependent,mp_proto_dependent);
20082 if ( s==mp_proto_dependent ) v=mp_p_plus_q(mp, v,r,mp_proto_dependent);
20083 else v=mp_p_plus_fq(mp, v,unity,r,mp_proto_dependent,mp_dependent);
20085 @<Output the answer, |v| (which might have become |known|)@>;
20088 @ @<Add the known |value(p)| to the constant term of |v|@>=
20090 while ( info(v)!=null ) v=link(v);
20091 value(v)=mp_slow_add(mp, value(p),value(v));
20094 @ @<Output the answer, |v| (which might have become |known|)@>=
20095 if ( q!=null ) mp_dep_finish(mp, v,q,t);
20096 else { mp->cur_type=t; mp_dep_finish(mp, v,null,t); }
20098 @ Here's the current situation: The dependency list |v| of type |t|
20099 should either be put into the current expression (if |q=null|) or
20100 into location |q| within a pair node (otherwise). The destination (|cur_exp|
20101 or |q|) formerly held a dependency list with the same
20102 final pointer as the list |v|.
20104 @<Declare the procedure called |dep_finish|@>=
20105 void mp_dep_finish (MP mp, pointer v, pointer q, small_number t) {
20106 pointer p; /* the destination */
20107 scaled vv; /* the value, if it is |known| */
20108 if ( q==null ) p=mp->cur_exp; else p=q;
20109 dep_list(p)=v; type(p)=t;
20110 if ( info(v)==null ) {
20113 mp_flush_cur_exp(mp, vv);
20115 mp_recycle_value(mp, p); type(q)=mp_known; value(q)=vv;
20117 } else if ( q==null ) {
20120 if ( mp->fix_needed ) mp_fix_dependencies(mp);
20123 @ Let's turn now to the six basic relations of comparison.
20125 @<Additional cases of binary operators@>=
20126 case less_than: case less_or_equal: case greater_than:
20127 case greater_or_equal: case equal_to: case unequal_to:
20128 check_arith; /* at this point |arith_error| should be |false|? */
20129 if ( (mp->cur_type>mp_pair_type)&&(type(p)>mp_pair_type) ) {
20130 mp_add_or_subtract(mp, p,null,minus); /* |cur_exp:=(p)-cur_exp| */
20131 } else if ( mp->cur_type!=type(p) ) {
20132 mp_bad_binary(mp, p,c); goto DONE;
20133 } else if ( mp->cur_type==mp_string_type ) {
20134 mp_flush_cur_exp(mp, mp_str_vs_str(mp, value(p),mp->cur_exp));
20135 } else if ((mp->cur_type==mp_unknown_string)||
20136 (mp->cur_type==mp_unknown_boolean) ) {
20137 @<Check if unknowns have been equated@>;
20138 } else if ( (mp->cur_type<=mp_pair_type)&&(mp->cur_type>=mp_transform_type)) {
20139 @<Reduce comparison of big nodes to comparison of scalars@>;
20140 } else if ( mp->cur_type==mp_boolean_type ) {
20141 mp_flush_cur_exp(mp, mp->cur_exp-value(p));
20143 mp_bad_binary(mp, p,c); goto DONE;
20145 @<Compare the current expression with zero@>;
20147 mp->arith_error=false; /* ignore overflow in comparisons */
20150 @ @<Compare the current expression with zero@>=
20151 if ( mp->cur_type!=mp_known ) {
20152 if ( mp->cur_type<mp_known ) {
20153 mp_disp_err(mp, p,"");
20154 help1("The quantities shown above have not been equated.")
20156 help2("Oh dear. I can\'t decide if the expression above is positive,")
20157 ("negative, or zero. So this comparison test won't be `true'.");
20159 exp_err("Unknown relation will be considered false");
20160 @.Unknown relation...@>
20161 mp_put_get_flush_error(mp, false_code);
20164 case less_than: boolean_reset(mp->cur_exp<0); break;
20165 case less_or_equal: boolean_reset(mp->cur_exp<=0); break;
20166 case greater_than: boolean_reset(mp->cur_exp>0); break;
20167 case greater_or_equal: boolean_reset(mp->cur_exp>=0); break;
20168 case equal_to: boolean_reset(mp->cur_exp==0); break;
20169 case unequal_to: boolean_reset(mp->cur_exp!=0); break;
20170 }; /* there are no other cases */
20172 mp->cur_type=mp_boolean_type
20174 @ When two unknown strings are in the same ring, we know that they are
20175 equal. Otherwise, we don't know whether they are equal or not, so we
20178 @<Check if unknowns have been equated@>=
20180 q=value(mp->cur_exp);
20181 while ( (q!=mp->cur_exp)&&(q!=p) ) q=value(q);
20182 if ( q==p ) mp_flush_cur_exp(mp, 0);
20185 @ @<Reduce comparison of big nodes to comparison of scalars@>=
20187 q=value(p); r=value(mp->cur_exp);
20188 rr=r+mp->big_node_size[mp->cur_type]-2;
20189 while (1) { mp_add_or_subtract(mp, q,r,minus);
20190 if ( type(r)!=mp_known ) break;
20191 if ( value(r)!=0 ) break;
20192 if ( r==rr ) break;
20195 mp_take_part(mp, name_type(r)+x_part-mp_x_part_sector);
20198 @ Here we use the sneaky fact that |and_op-false_code=or_op-true_code|.
20200 @<Additional cases of binary operators@>=
20203 if ( (type(p)!=mp_boolean_type)||(mp->cur_type!=mp_boolean_type) )
20204 mp_bad_binary(mp, p,c);
20205 else if ( value(p)==c+false_code-and_op ) mp->cur_exp=value(p);
20208 @ @<Additional cases of binary operators@>=
20210 if ( (mp->cur_type<mp_color_type)||(type(p)<mp_color_type) ) {
20211 mp_bad_binary(mp, p,times);
20212 } else if ( (mp->cur_type==mp_known)||(type(p)==mp_known) ) {
20213 @<Multiply when at least one operand is known@>;
20214 } else if ( (mp_nice_color_or_pair(mp, p,type(p))&&(mp->cur_type>mp_pair_type))
20215 ||(mp_nice_color_or_pair(mp, mp->cur_exp,mp->cur_type)&&
20216 (type(p)>mp_pair_type)) ) {
20217 mp_hard_times(mp, p);
20220 mp_bad_binary(mp, p,times);
20224 @ @<Multiply when at least one operand is known@>=
20226 if ( type(p)==mp_known ) {
20227 v=value(p); mp_free_node(mp, p,value_node_size);
20229 v=mp->cur_exp; mp_unstash_cur_exp(mp, p);
20231 if ( mp->cur_type==mp_known ) {
20232 mp->cur_exp=mp_take_scaled(mp, mp->cur_exp,v);
20233 } else if ( (mp->cur_type==mp_pair_type)||
20234 (mp->cur_type==mp_color_type)||
20235 (mp->cur_type==mp_cmykcolor_type) ) {
20236 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20238 p=p-2; mp_dep_mult(mp, p,v,true);
20239 } while (p!=value(mp->cur_exp));
20241 mp_dep_mult(mp, null,v,true);
20246 @ @<Declare binary action...@>=
20247 void mp_dep_mult (MP mp,pointer p, integer v, boolean v_is_scaled) {
20248 pointer q; /* the dependency list being multiplied by |v| */
20249 small_number s,t; /* its type, before and after */
20252 } else if ( type(p)!=mp_known ) {
20255 if ( v_is_scaled ) value(p)=mp_take_scaled(mp, value(p),v);
20256 else value(p)=mp_take_fraction(mp, value(p),v);
20259 t=type(q); q=dep_list(q); s=t;
20260 if ( t==mp_dependent ) if ( v_is_scaled )
20261 if (mp_ab_vs_cd(mp, mp_max_coef(mp,q),abs(v),coef_bound-1,unity)>=0 )
20262 t=mp_proto_dependent;
20263 q=mp_p_times_v(mp, q,v,s,t,v_is_scaled);
20264 mp_dep_finish(mp, q,p,t);
20267 @ Here is a routine that is similar to |times|; but it is invoked only
20268 internally, when |v| is a |fraction| whose magnitude is at most~1,
20269 and when |cur_type>=mp_color_type|.
20271 @c void mp_frac_mult (MP mp,scaled n, scaled d) {
20272 /* multiplies |cur_exp| by |n/d| */
20273 pointer p; /* a pair node */
20274 pointer old_exp; /* a capsule to recycle */
20275 fraction v; /* |n/d| */
20276 if ( mp->internal[mp_tracing_commands]>two ) {
20277 @<Trace the fraction multiplication@>;
20279 switch (mp->cur_type) {
20280 case mp_transform_type:
20281 case mp_color_type:
20282 case mp_cmykcolor_type:
20284 old_exp=mp_tarnished(mp, mp->cur_exp);
20286 case mp_independent: old_exp=mp_void; break;
20287 default: old_exp=null; break;
20289 if ( old_exp!=null ) {
20290 old_exp=mp->cur_exp; mp_make_exp_copy(mp, old_exp);
20292 v=mp_make_fraction(mp, n,d);
20293 if ( mp->cur_type==mp_known ) {
20294 mp->cur_exp=mp_take_fraction(mp, mp->cur_exp,v);
20295 } else if ( mp->cur_type<=mp_pair_type ) {
20296 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20299 mp_dep_mult(mp, p,v,false);
20300 } while (p!=value(mp->cur_exp));
20302 mp_dep_mult(mp, null,v,false);
20304 if ( old_exp!=null ) {
20305 mp_recycle_value(mp, old_exp);
20306 mp_free_node(mp, old_exp,value_node_size);
20310 @ @<Trace the fraction multiplication@>=
20312 mp_begin_diagnostic(mp);
20313 mp_print_nl(mp, "{("); mp_print_scaled(mp,n); mp_print_char(mp,'/');
20314 mp_print_scaled(mp,d); mp_print(mp,")*("); mp_print_exp(mp,null,0);
20316 mp_end_diagnostic(mp, false);
20319 @ The |hard_times| routine multiplies a nice color or pair by a dependency list.
20321 @<Declare binary action procedures@>=
20322 void mp_hard_times (MP mp,pointer p) {
20323 pointer q; /* a copy of the dependent variable |p| */
20324 pointer r; /* a component of the big node for the nice color or pair */
20325 scaled v; /* the known value for |r| */
20326 if ( type(p)<=mp_pair_type ) {
20327 q=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, p); p=q;
20328 }; /* now |cur_type=mp_pair_type| or |cur_type=mp_color_type| */
20329 r=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20334 if ( r==value(mp->cur_exp) )
20336 mp_new_dep(mp, r,mp_copy_dep_list(mp, dep_list(p)));
20337 mp_dep_mult(mp, r,v,true);
20339 mp->mem[value_loc(r)]=mp->mem[value_loc(p)];
20340 link(prev_dep(p))=r;
20341 mp_free_node(mp, p,value_node_size);
20342 mp_dep_mult(mp, r,v,true);
20345 @ @<Additional cases of binary operators@>=
20347 if ( (mp->cur_type!=mp_known)||(type(p)<mp_color_type) ) {
20348 mp_bad_binary(mp, p,over);
20350 v=mp->cur_exp; mp_unstash_cur_exp(mp, p);
20352 @<Squeal about division by zero@>;
20354 if ( mp->cur_type==mp_known ) {
20355 mp->cur_exp=mp_make_scaled(mp, mp->cur_exp,v);
20356 } else if ( mp->cur_type<=mp_pair_type ) {
20357 p=value(mp->cur_exp)+mp->big_node_size[mp->cur_type];
20359 p=p-2; mp_dep_div(mp, p,v);
20360 } while (p!=value(mp->cur_exp));
20362 mp_dep_div(mp, null,v);
20369 @ @<Declare binary action...@>=
20370 void mp_dep_div (MP mp,pointer p, scaled v) {
20371 pointer q; /* the dependency list being divided by |v| */
20372 small_number s,t; /* its type, before and after */
20373 if ( p==null ) q=mp->cur_exp;
20374 else if ( type(p)!=mp_known ) q=p;
20375 else { value(p)=mp_make_scaled(mp, value(p),v); return; };
20376 t=type(q); q=dep_list(q); s=t;
20377 if ( t==mp_dependent )
20378 if ( mp_ab_vs_cd(mp, mp_max_coef(mp,q),unity,coef_bound-1,abs(v))>=0 )
20379 t=mp_proto_dependent;
20380 q=mp_p_over_v(mp, q,v,s,t);
20381 mp_dep_finish(mp, q,p,t);
20384 @ @<Squeal about division by zero@>=
20386 exp_err("Division by zero");
20387 @.Division by zero@>
20388 help2("You're trying to divide the quantity shown above the error")
20389 ("message by zero. I'm going to divide it by one instead.");
20390 mp_put_get_error(mp);
20393 @ @<Additional cases of binary operators@>=
20396 if ( (mp->cur_type==mp_known)&&(type(p)==mp_known) ) {
20397 if ( c==pythag_add ) mp->cur_exp=mp_pyth_add(mp, value(p),mp->cur_exp);
20398 else mp->cur_exp=mp_pyth_sub(mp, value(p),mp->cur_exp);
20399 } else mp_bad_binary(mp, p,c);
20402 @ The next few sections of the program deal with affine transformations
20403 of coordinate data.
20405 @<Additional cases of binary operators@>=
20406 case rotated_by: case slanted_by:
20407 case scaled_by: case shifted_by: case transformed_by:
20408 case x_scaled: case y_scaled: case z_scaled:
20409 if ( type(p)==mp_path_type ) {
20410 path_trans(c,p); binary_return;
20411 } else if ( type(p)==mp_pen_type ) {
20413 mp->cur_exp=mp_convex_hull(mp, mp->cur_exp);
20414 /* rounding error could destroy convexity */
20416 } else if ( (type(p)==mp_pair_type)||(type(p)==mp_transform_type) ) {
20417 mp_big_trans(mp, p,c);
20418 } else if ( type(p)==mp_picture_type ) {
20419 mp_do_edges_trans(mp, p,c); binary_return;
20421 mp_bad_binary(mp, p,c);
20425 @ Let |c| be one of the eight transform operators. The procedure call
20426 |set_up_trans(c)| first changes |cur_exp| to a transform that corresponds to
20427 |c| and the original value of |cur_exp|. (In particular, |cur_exp| doesn't
20428 change at all if |c=transformed_by|.)
20430 Then, if all components of the resulting transform are |known|, they are
20431 moved to the global variables |txx|, |txy|, |tyx|, |tyy|, |tx|, |ty|;
20432 and |cur_exp| is changed to the known value zero.
20434 @<Declare binary action...@>=
20435 void mp_set_up_trans (MP mp,quarterword c) {
20436 pointer p,q,r; /* list manipulation registers */
20437 if ( (c!=transformed_by)||(mp->cur_type!=mp_transform_type) ) {
20438 @<Put the current transform into |cur_exp|@>;
20440 @<If the current transform is entirely known, stash it in global variables;
20441 otherwise |return|@>;
20450 scaled ty; /* current transform coefficients */
20452 @ @<Put the current transform...@>=
20454 p=mp_stash_cur_exp(mp);
20455 mp->cur_exp=mp_id_transform(mp);
20456 mp->cur_type=mp_transform_type;
20457 q=value(mp->cur_exp);
20459 @<For each of the eight cases, change the relevant fields of |cur_exp|
20461 but do nothing if capsule |p| doesn't have the appropriate type@>;
20462 }; /* there are no other cases */
20463 mp_disp_err(mp, p,"Improper transformation argument");
20464 @.Improper transformation argument@>
20465 help3("The expression shown above has the wrong type,")
20466 ("so I can\'t transform anything using it.")
20467 ("Proceed, and I'll omit the transformation.");
20468 mp_put_get_error(mp);
20470 mp_recycle_value(mp, p);
20471 mp_free_node(mp, p,value_node_size);
20474 @ @<If the current transform is entirely known, ...@>=
20475 q=value(mp->cur_exp); r=q+transform_node_size;
20478 if ( type(r)!=mp_known ) return;
20480 mp->txx=value(xx_part_loc(q));
20481 mp->txy=value(xy_part_loc(q));
20482 mp->tyx=value(yx_part_loc(q));
20483 mp->tyy=value(yy_part_loc(q));
20484 mp->tx=value(x_part_loc(q));
20485 mp->ty=value(y_part_loc(q));
20486 mp_flush_cur_exp(mp, 0)
20488 @ @<For each of the eight cases...@>=
20490 if ( type(p)==mp_known )
20491 @<Install sines and cosines, then |goto done|@>;
20494 if ( type(p)>mp_pair_type ) {
20495 mp_install(mp, xy_part_loc(q),p); goto DONE;
20499 if ( type(p)>mp_pair_type ) {
20500 mp_install(mp, xx_part_loc(q),p); mp_install(mp, yy_part_loc(q),p);
20505 if ( type(p)==mp_pair_type ) {
20506 r=value(p); mp_install(mp, x_part_loc(q),x_part_loc(r));
20507 mp_install(mp, y_part_loc(q),y_part_loc(r)); goto DONE;
20511 if ( type(p)>mp_pair_type ) {
20512 mp_install(mp, xx_part_loc(q),p); goto DONE;
20516 if ( type(p)>mp_pair_type ) {
20517 mp_install(mp, yy_part_loc(q),p); goto DONE;
20521 if ( type(p)==mp_pair_type )
20522 @<Install a complex multiplier, then |goto done|@>;
20524 case transformed_by:
20528 @ @<Install sines and cosines, then |goto done|@>=
20529 { mp_n_sin_cos(mp, (value(p) % three_sixty_units)*16);
20530 value(xx_part_loc(q))=mp_round_fraction(mp, mp->n_cos);
20531 value(yx_part_loc(q))=mp_round_fraction(mp, mp->n_sin);
20532 value(xy_part_loc(q))=-value(yx_part_loc(q));
20533 value(yy_part_loc(q))=value(xx_part_loc(q));
20537 @ @<Install a complex multiplier, then |goto done|@>=
20540 mp_install(mp, xx_part_loc(q),x_part_loc(r));
20541 mp_install(mp, yy_part_loc(q),x_part_loc(r));
20542 mp_install(mp, yx_part_loc(q),y_part_loc(r));
20543 if ( type(y_part_loc(r))==mp_known ) negate(value(y_part_loc(r)));
20544 else mp_negate_dep_list(mp, dep_list(y_part_loc(r)));
20545 mp_install(mp, xy_part_loc(q),y_part_loc(r));
20549 @ Procedure |set_up_known_trans| is like |set_up_trans|, but it
20550 insists that the transformation be entirely known.
20552 @<Declare binary action...@>=
20553 void mp_set_up_known_trans (MP mp,quarterword c) {
20554 mp_set_up_trans(mp, c);
20555 if ( mp->cur_type!=mp_known ) {
20556 exp_err("Transform components aren't all known");
20557 @.Transform components...@>
20558 help3("I'm unable to apply a partially specified transformation")
20559 ("except to a fully known pair or transform.")
20560 ("Proceed, and I'll omit the transformation.");
20561 mp_put_get_flush_error(mp, 0);
20562 mp->txx=unity; mp->txy=0; mp->tyx=0; mp->tyy=unity;
20563 mp->tx=0; mp->ty=0;
20567 @ Here's a procedure that applies the transform |txx..ty| to a pair of
20568 coordinates in locations |p| and~|q|.
20570 @<Declare binary action...@>=
20571 void mp_trans (MP mp,pointer p, pointer q) {
20572 scaled v; /* the new |x| value */
20573 v=mp_take_scaled(mp, mp->mem[p].sc,mp->txx)+
20574 mp_take_scaled(mp, mp->mem[q].sc,mp->txy)+mp->tx;
20575 mp->mem[q].sc=mp_take_scaled(mp, mp->mem[p].sc,mp->tyx)+
20576 mp_take_scaled(mp, mp->mem[q].sc,mp->tyy)+mp->ty;
20580 @ The simplest transformation procedure applies a transform to all
20581 coordinates of a path. The |path_trans(c)(p)| macro applies
20582 a transformation defined by |cur_exp| and the transform operator |c|
20585 @d path_trans(A,B) { mp_set_up_known_trans(mp, (A));
20586 mp_unstash_cur_exp(mp, (B));
20587 mp_do_path_trans(mp, mp->cur_exp); }
20589 @<Declare binary action...@>=
20590 void mp_do_path_trans (MP mp,pointer p) {
20591 pointer q; /* list traverser */
20594 if ( left_type(q)!=mp_endpoint )
20595 mp_trans(mp, q+3,q+4); /* that's |left_x| and |left_y| */
20596 mp_trans(mp, q+1,q+2); /* that's |x_coord| and |y_coord| */
20597 if ( right_type(q)!=mp_endpoint )
20598 mp_trans(mp, q+5,q+6); /* that's |right_x| and |right_y| */
20599 @^data structure assumptions@>
20604 @ Transforming a pen is very similar, except that there are no |left_type|
20605 and |right_type| fields.
20607 @d pen_trans(A,B) { mp_set_up_known_trans(mp, (A));
20608 mp_unstash_cur_exp(mp, (B));
20609 mp_do_pen_trans(mp, mp->cur_exp); }
20611 @<Declare binary action...@>=
20612 void mp_do_pen_trans (MP mp,pointer p) {
20613 pointer q; /* list traverser */
20614 if ( pen_is_elliptical(p) ) {
20615 mp_trans(mp, p+3,p+4); /* that's |left_x| and |left_y| */
20616 mp_trans(mp, p+5,p+6); /* that's |right_x| and |right_y| */
20620 mp_trans(mp, q+1,q+2); /* that's |x_coord| and |y_coord| */
20621 @^data structure assumptions@>
20626 @ The next transformation procedure applies to edge structures. It will do
20627 any transformation, but the results may be substandard if the picture contains
20628 text that uses downloaded bitmap fonts. The binary action procedure is
20629 |do_edges_trans|, but we also need a function that just scales a picture.
20630 That routine is |scale_edges|. Both it and the underlying routine |edges_trans|
20631 should be thought of as procedures that update an edge structure |h|, except
20632 that they have to return a (possibly new) structure because of the need to call
20635 @<Declare binary action...@>=
20636 pointer mp_edges_trans (MP mp, pointer h) {
20637 pointer q; /* the object being transformed */
20638 pointer r,s; /* for list manipulation */
20639 scaled sx,sy; /* saved transformation parameters */
20640 scaled sqdet; /* square root of determinant for |dash_scale| */
20641 integer sgndet; /* sign of the determinant */
20642 scaled v; /* a temporary value */
20643 h=mp_private_edges(mp, h);
20644 sqdet=mp_sqrt_det(mp, mp->txx,mp->txy,mp->tyx,mp->tyy);
20645 sgndet=mp_ab_vs_cd(mp, mp->txx,mp->tyy,mp->txy,mp->tyx);
20646 if ( dash_list(h)!=null_dash ) {
20647 @<Try to transform the dash list of |h|@>;
20649 @<Make the bounding box of |h| unknown if it can't be updated properly
20650 without scanning the whole structure@>;
20651 q=link(dummy_loc(h));
20652 while ( q!=null ) {
20653 @<Transform graphical object |q|@>;
20658 void mp_do_edges_trans (MP mp,pointer p, quarterword c) {
20659 mp_set_up_known_trans(mp, c);
20660 value(p)=mp_edges_trans(mp, value(p));
20661 mp_unstash_cur_exp(mp, p);
20663 void mp_scale_edges (MP mp) {
20664 mp->txx=mp->se_sf; mp->tyy=mp->se_sf;
20665 mp->txy=0; mp->tyx=0; mp->tx=0; mp->ty=0;
20666 mp->se_pic=mp_edges_trans(mp, mp->se_pic);
20669 @ @<Try to transform the dash list of |h|@>=
20670 if ( (mp->txy!=0)||(mp->tyx!=0)||
20671 (mp->ty!=0)||(abs(mp->txx)!=abs(mp->tyy))) {
20672 mp_flush_dash_list(mp, h);
20674 if ( mp->txx<0 ) { @<Reverse the dash list of |h|@>; }
20675 @<Scale the dash list by |txx| and shift it by |tx|@>;
20676 dash_y(h)=mp_take_scaled(mp, dash_y(h),abs(mp->tyy));
20679 @ @<Reverse the dash list of |h|@>=
20682 dash_list(h)=null_dash;
20683 while ( r!=null_dash ) {
20685 v=start_x(s); start_x(s)=stop_x(s); stop_x(s)=v;
20686 link(s)=dash_list(h);
20691 @ @<Scale the dash list by |txx| and shift it by |tx|@>=
20693 while ( r!=null_dash ) {
20694 start_x(r)=mp_take_scaled(mp, start_x(r),mp->txx)+mp->tx;
20695 stop_x(r)=mp_take_scaled(mp, stop_x(r),mp->txx)+mp->tx;
20699 @ @<Make the bounding box of |h| unknown if it can't be updated properly...@>=
20700 if ( (mp->txx==0)&&(mp->tyy==0) ) {
20701 @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>;
20702 } else if ( (mp->txy!=0)||(mp->tyx!=0) ) {
20703 mp_init_bbox(mp, h);
20706 if ( minx_val(h)<=maxx_val(h) ) {
20707 @<Scale the bounding box by |txx+txy| and |tyx+tyy|; then shift by
20714 @ @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>=
20716 v=minx_val(h); minx_val(h)=miny_val(h); miny_val(h)=v;
20717 v=maxx_val(h); maxx_val(h)=maxy_val(h); maxy_val(h)=v;
20720 @ The sum ``|txx+txy|'' is whichever of |txx| or |txy| is nonzero. The other
20723 @<Scale the bounding box by |txx+txy| and |tyx+tyy|; then shift...@>=
20725 minx_val(h)=mp_take_scaled(mp, minx_val(h),mp->txx+mp->txy)+mp->tx;
20726 maxx_val(h)=mp_take_scaled(mp, maxx_val(h),mp->txx+mp->txy)+mp->tx;
20727 miny_val(h)=mp_take_scaled(mp, miny_val(h),mp->tyx+mp->tyy)+mp->ty;
20728 maxy_val(h)=mp_take_scaled(mp, maxy_val(h),mp->tyx+mp->tyy)+mp->ty;
20729 if ( mp->txx+mp->txy<0 ) {
20730 v=minx_val(h); minx_val(h)=maxx_val(h); maxx_val(h)=v;
20732 if ( mp->tyx+mp->tyy<0 ) {
20733 v=miny_val(h); miny_val(h)=maxy_val(h); maxy_val(h)=v;
20737 @ Now we ready for the main task of transforming the graphical objects in edge
20740 @<Transform graphical object |q|@>=
20742 case mp_fill_code: case mp_stroked_code:
20743 mp_do_path_trans(mp, path_p(q));
20744 @<Transform |pen_p(q)|, making sure polygonal pens stay counter-clockwise@>;
20746 case mp_start_clip_code: case mp_start_bounds_code:
20747 mp_do_path_trans(mp, path_p(q));
20751 @<Transform the compact transformation starting at |r|@>;
20753 case mp_stop_clip_code: case mp_stop_bounds_code:
20755 } /* there are no other cases */
20757 @ Note that the shift parameters |(tx,ty)| apply only to the path being stroked.
20758 The |dash_scale| has to be adjusted to scale the dash lengths in |dash_p(q)|
20759 since the \ps\ output procedures will try to compensate for the transformation
20760 we are applying to |pen_p(q)|. Since this compensation is based on the square
20761 root of the determinant, |sqdet| is the appropriate factor.
20763 @<Transform |pen_p(q)|, making sure...@>=
20764 if ( pen_p(q)!=null ) {
20765 sx=mp->tx; sy=mp->ty;
20766 mp->tx=0; mp->ty=0;
20767 mp_do_pen_trans(mp, pen_p(q));
20768 if ( ((type(q)==mp_stroked_code)&&(dash_p(q)!=null)) )
20769 dash_scale(q)=mp_take_scaled(mp, dash_scale(q),sqdet);
20770 if ( ! pen_is_elliptical(pen_p(q)) )
20772 pen_p(q)=mp_make_pen(mp, mp_copy_path(mp, pen_p(q)),true);
20773 /* this unreverses the pen */
20774 mp->tx=sx; mp->ty=sy;
20777 @ This uses the fact that transformations are stored in the order
20778 |(tx,ty,txx,txy,tyx,tyy)|.
20779 @^data structure assumptions@>
20781 @<Transform the compact transformation starting at |r|@>=
20782 mp_trans(mp, r,r+1);
20783 sx=mp->tx; sy=mp->ty;
20784 mp->tx=0; mp->ty=0;
20785 mp_trans(mp, r+2,r+4);
20786 mp_trans(mp, r+3,r+5);
20787 mp->tx=sx; mp->ty=sy
20789 @ The hard cases of transformation occur when big nodes are involved,
20790 and when some of their components are unknown.
20792 @<Declare binary action...@>=
20793 @<Declare subroutines needed by |big_trans|@>
20794 void mp_big_trans (MP mp,pointer p, quarterword c) {
20795 pointer q,r,pp,qq; /* list manipulation registers */
20796 small_number s; /* size of a big node */
20797 s=mp->big_node_size[type(p)]; q=value(p); r=q+s;
20800 if ( type(r)!=mp_known ) {
20801 @<Transform an unknown big node and |return|@>;
20804 @<Transform a known big node@>;
20805 } /* node |p| will now be recycled by |do_binary| */
20807 @ @<Transform an unknown big node and |return|@>=
20809 mp_set_up_known_trans(mp, c); mp_make_exp_copy(mp, p);
20810 r=value(mp->cur_exp);
20811 if ( mp->cur_type==mp_transform_type ) {
20812 mp_bilin1(mp, yy_part_loc(r),mp->tyy,xy_part_loc(q),mp->tyx,0);
20813 mp_bilin1(mp, yx_part_loc(r),mp->tyy,xx_part_loc(q),mp->tyx,0);
20814 mp_bilin1(mp, xy_part_loc(r),mp->txx,yy_part_loc(q),mp->txy,0);
20815 mp_bilin1(mp, xx_part_loc(r),mp->txx,yx_part_loc(q),mp->txy,0);
20817 mp_bilin1(mp, y_part_loc(r),mp->tyy,x_part_loc(q),mp->tyx,mp->ty);
20818 mp_bilin1(mp, x_part_loc(r),mp->txx,y_part_loc(q),mp->txy,mp->tx);
20822 @ Let |p| point to a two-word value field inside a big node of |cur_exp|,
20823 and let |q| point to a another value field. The |bilin1| procedure
20824 replaces |p| by $p\cdot t+q\cdot u+\delta$.
20826 @<Declare subroutines needed by |big_trans|@>=
20827 void mp_bilin1 (MP mp, pointer p, scaled t, pointer q,
20828 scaled u, scaled delta) {
20829 pointer r; /* list traverser */
20830 if ( t!=unity ) mp_dep_mult(mp, p,t,true);
20832 if ( type(q)==mp_known ) {
20833 delta+=mp_take_scaled(mp, value(q),u);
20835 @<Ensure that |type(p)=mp_proto_dependent|@>;
20836 dep_list(p)=mp_p_plus_fq(mp, dep_list(p),u,dep_list(q),
20837 mp_proto_dependent,type(q));
20840 if ( type(p)==mp_known ) {
20844 while ( info(r)!=null ) r=link(r);
20846 if ( r!=dep_list(p) ) value(r)=delta;
20847 else { mp_recycle_value(mp, p); type(p)=mp_known; value(p)=delta; };
20849 if ( mp->fix_needed ) mp_fix_dependencies(mp);
20852 @ @<Ensure that |type(p)=mp_proto_dependent|@>=
20853 if ( type(p)!=mp_proto_dependent ) {
20854 if ( type(p)==mp_known )
20855 mp_new_dep(mp, p,mp_const_dependency(mp, value(p)));
20857 dep_list(p)=mp_p_times_v(mp, dep_list(p),unity,mp_dependent,
20858 mp_proto_dependent,true);
20859 type(p)=mp_proto_dependent;
20862 @ @<Transform a known big node@>=
20863 mp_set_up_trans(mp, c);
20864 if ( mp->cur_type==mp_known ) {
20865 @<Transform known by known@>;
20867 pp=mp_stash_cur_exp(mp); qq=value(pp);
20868 mp_make_exp_copy(mp, p); r=value(mp->cur_exp);
20869 if ( mp->cur_type==mp_transform_type ) {
20870 mp_bilin2(mp, yy_part_loc(r),yy_part_loc(qq),
20871 value(xy_part_loc(q)),yx_part_loc(qq),null);
20872 mp_bilin2(mp, yx_part_loc(r),yy_part_loc(qq),
20873 value(xx_part_loc(q)),yx_part_loc(qq),null);
20874 mp_bilin2(mp, xy_part_loc(r),xx_part_loc(qq),
20875 value(yy_part_loc(q)),xy_part_loc(qq),null);
20876 mp_bilin2(mp, xx_part_loc(r),xx_part_loc(qq),
20877 value(yx_part_loc(q)),xy_part_loc(qq),null);
20879 mp_bilin2(mp, y_part_loc(r),yy_part_loc(qq),
20880 value(x_part_loc(q)),yx_part_loc(qq),y_part_loc(qq));
20881 mp_bilin2(mp, x_part_loc(r),xx_part_loc(qq),
20882 value(y_part_loc(q)),xy_part_loc(qq),x_part_loc(qq));
20883 mp_recycle_value(mp, pp); mp_free_node(mp, pp,value_node_size);
20886 @ Let |p| be a |mp_proto_dependent| value whose dependency list ends
20887 at |dep_final|. The following procedure adds |v| times another
20888 numeric quantity to~|p|.
20890 @<Declare subroutines needed by |big_trans|@>=
20891 void mp_add_mult_dep (MP mp,pointer p, scaled v, pointer r) {
20892 if ( type(r)==mp_known ) {
20893 value(mp->dep_final)+=mp_take_scaled(mp, value(r),v);
20895 dep_list(p)=mp_p_plus_fq(mp, dep_list(p),v,dep_list(r),
20896 mp_proto_dependent,type(r));
20897 if ( mp->fix_needed ) mp_fix_dependencies(mp);
20901 @ The |bilin2| procedure is something like |bilin1|, but with known
20902 and unknown quantities reversed. Parameter |p| points to a value field
20903 within the big node for |cur_exp|; and |type(p)=mp_known|. Parameters
20904 |t| and~|u| point to value fields elsewhere; so does parameter~|q|,
20905 unless it is |null| (which stands for zero). Location~|p| will be
20906 replaced by $p\cdot t+v\cdot u+q$.
20908 @<Declare subroutines needed by |big_trans|@>=
20909 void mp_bilin2 (MP mp,pointer p, pointer t, scaled v,
20910 pointer u, pointer q) {
20911 scaled vv; /* temporary storage for |value(p)| */
20912 vv=value(p); type(p)=mp_proto_dependent;
20913 mp_new_dep(mp, p,mp_const_dependency(mp, 0)); /* this sets |dep_final| */
20915 mp_add_mult_dep(mp, p,vv,t); /* |dep_final| doesn't change */
20916 if ( v!=0 ) mp_add_mult_dep(mp, p,v,u);
20917 if ( q!=null ) mp_add_mult_dep(mp, p,unity,q);
20918 if ( dep_list(p)==mp->dep_final ) {
20919 vv=value(mp->dep_final); mp_recycle_value(mp, p);
20920 type(p)=mp_known; value(p)=vv;
20924 @ @<Transform known by known@>=
20926 mp_make_exp_copy(mp, p); r=value(mp->cur_exp);
20927 if ( mp->cur_type==mp_transform_type ) {
20928 mp_bilin3(mp, yy_part_loc(r),mp->tyy,value(xy_part_loc(q)),mp->tyx,0);
20929 mp_bilin3(mp, yx_part_loc(r),mp->tyy,value(xx_part_loc(q)),mp->tyx,0);
20930 mp_bilin3(mp, xy_part_loc(r),mp->txx,value(yy_part_loc(q)),mp->txy,0);
20931 mp_bilin3(mp, xx_part_loc(r),mp->txx,value(yx_part_loc(q)),mp->txy,0);
20933 mp_bilin3(mp, y_part_loc(r),mp->tyy,value(x_part_loc(q)),mp->tyx,mp->ty);
20934 mp_bilin3(mp, x_part_loc(r),mp->txx,value(y_part_loc(q)),mp->txy,mp->tx);
20937 @ Finally, in |bilin3| everything is |known|.
20939 @<Declare subroutines needed by |big_trans|@>=
20940 void mp_bilin3 (MP mp,pointer p, scaled t,
20941 scaled v, scaled u, scaled delta) {
20943 delta+=mp_take_scaled(mp, value(p),t);
20946 if ( u!=0 ) value(p)=delta+mp_take_scaled(mp, v,u);
20947 else value(p)=delta;
20950 @ @<Additional cases of binary operators@>=
20952 if ( (mp->cur_type==mp_string_type)&&(type(p)==mp_string_type) ) mp_cat(mp, p);
20953 else mp_bad_binary(mp, p,concatenate);
20956 if ( mp_nice_pair(mp, p,type(p))&&(mp->cur_type==mp_string_type) )
20957 mp_chop_string(mp, value(p));
20958 else mp_bad_binary(mp, p,substring_of);
20961 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
20962 if ( mp_nice_pair(mp, p,type(p))&&(mp->cur_type==mp_path_type) )
20963 mp_chop_path(mp, value(p));
20964 else mp_bad_binary(mp, p,subpath_of);
20967 @ @<Declare binary action...@>=
20968 void mp_cat (MP mp,pointer p) {
20969 str_number a,b; /* the strings being concatenated */
20970 pool_pointer k; /* index into |str_pool| */
20971 a=value(p); b=mp->cur_exp; str_room(length(a)+length(b));
20972 for (k=mp->str_start[a];k<=str_stop(a)-1;k++) {
20973 append_char(mp->str_pool[k]);
20975 for (k=mp->str_start[b];k<=str_stop(b)-1;k++) {
20976 append_char(mp->str_pool[k]);
20978 mp->cur_exp=mp_make_string(mp); delete_str_ref(b);
20981 @ @<Declare binary action...@>=
20982 void mp_chop_string (MP mp,pointer p) {
20983 integer a, b; /* start and stop points */
20984 integer l; /* length of the original string */
20985 integer k; /* runs from |a| to |b| */
20986 str_number s; /* the original string */
20987 boolean reversed; /* was |a>b|? */
20988 a=mp_round_unscaled(mp, value(x_part_loc(p)));
20989 b=mp_round_unscaled(mp, value(y_part_loc(p)));
20990 if ( a<=b ) reversed=false;
20991 else { reversed=true; k=a; a=b; b=k; };
20992 s=mp->cur_exp; l=length(s);
21003 for (k=mp->str_start[s]+b-1;k>=mp->str_start[s]+a;k--) {
21004 append_char(mp->str_pool[k]);
21007 for (k=mp->str_start[s]+a;k<=mp->str_start[s]+b-1;k++) {
21008 append_char(mp->str_pool[k]);
21011 mp->cur_exp=mp_make_string(mp); delete_str_ref(s);
21014 @ @<Declare binary action...@>=
21015 void mp_chop_path (MP mp,pointer p) {
21016 pointer q; /* a knot in the original path */
21017 pointer pp,qq,rr,ss; /* link variables for copies of path nodes */
21018 scaled a,b,k,l; /* indices for chopping */
21019 boolean reversed; /* was |a>b|? */
21020 l=mp_path_length(mp); a=value(x_part_loc(p)); b=value(y_part_loc(p));
21021 if ( a<=b ) reversed=false;
21022 else { reversed=true; k=a; a=b; b=k; };
21023 @<Dispense with the cases |a<0| and/or |b>l|@>;
21025 while ( a>=unity ) {
21026 q=link(q); a=a-unity; b=b-unity;
21029 @<Construct a path from |pp| to |qq| of length zero@>;
21031 @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>;
21033 left_type(pp)=mp_endpoint; right_type(qq)=mp_endpoint; link(qq)=pp;
21034 mp_toss_knot_list(mp, mp->cur_exp);
21036 mp->cur_exp=link(mp_htap_ypoc(mp, pp)); mp_toss_knot_list(mp, pp);
21042 @ @<Dispense with the cases |a<0| and/or |b>l|@>=
21044 if ( left_type(mp->cur_exp)==mp_endpoint ) {
21045 a=0; if ( b<0 ) b=0;
21047 do { a=a+l; b=b+l; } while (a<0); /* a cycle always has length |l>0| */
21051 if ( left_type(mp->cur_exp)==mp_endpoint ) {
21052 b=l; if ( a>l ) a=l;
21060 @ @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>=
21062 pp=mp_copy_knot(mp, q); qq=pp;
21064 q=link(q); rr=qq; qq=mp_copy_knot(mp, q); link(rr)=qq; b=b-unity;
21067 ss=pp; pp=link(pp);
21068 mp_split_cubic(mp, ss,a*010000); pp=link(ss);
21069 mp_free_node(mp, ss,knot_node_size);
21071 b=mp_make_scaled(mp, b,unity-a); rr=pp;
21075 mp_split_cubic(mp, rr,(b+unity)*010000);
21076 mp_free_node(mp, qq,knot_node_size);
21081 @ @<Construct a path from |pp| to |qq| of length zero@>=
21083 if ( a>0 ) { mp_split_cubic(mp, q,a*010000); q=link(q); };
21084 pp=mp_copy_knot(mp, q); qq=pp;
21087 @ @<Additional cases of binary operators@>=
21088 case point_of: case precontrol_of: case postcontrol_of:
21089 if ( mp->cur_type==mp_pair_type )
21090 mp_pair_to_path(mp);
21091 if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_known) )
21092 mp_find_point(mp, value(p),c);
21094 mp_bad_binary(mp, p,c);
21096 case pen_offset_of:
21097 if ( (mp->cur_type==mp_pen_type)&& mp_nice_pair(mp, p,type(p)) )
21098 mp_set_up_offset(mp, value(p));
21100 mp_bad_binary(mp, p,pen_offset_of);
21102 case direction_time_of:
21103 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
21104 if ( (mp->cur_type==mp_path_type)&& mp_nice_pair(mp, p,type(p)) )
21105 mp_set_up_direction_time(mp, value(p));
21107 mp_bad_binary(mp, p,direction_time_of);
21110 if ( (type(p) != mp_pen_type) || (mp->cur_type != mp_path_type) )
21111 mp_bad_binary(mp, p,envelope_of);
21113 mp_set_up_envelope(mp, p);
21116 @ @<Declare binary action...@>=
21117 void mp_set_up_offset (MP mp,pointer p) {
21118 mp_find_offset(mp, value(x_part_loc(p)),value(y_part_loc(p)),mp->cur_exp);
21119 mp_pair_value(mp, mp->cur_x,mp->cur_y);
21121 void mp_set_up_direction_time (MP mp,pointer p) {
21122 mp_flush_cur_exp(mp, mp_find_direction_time(mp, value(x_part_loc(p)),
21123 value(y_part_loc(p)),mp->cur_exp));
21125 void mp_set_up_envelope (MP mp,pointer p) {
21126 small_number ljoin, lcap;
21128 pointer q = mp_copy_path(mp, mp->cur_exp); /* the original path */
21129 /* TODO: accept elliptical pens for straight paths */
21130 if (pen_is_elliptical(value(p))) {
21131 mp_bad_envelope_pen(mp);
21133 mp->cur_type = mp_path_type;
21136 if ( mp->internal[mp_linejoin]>unity ) ljoin=2;
21137 else if ( mp->internal[mp_linejoin]>0 ) ljoin=1;
21139 if ( mp->internal[mp_linecap]>unity ) lcap=2;
21140 else if ( mp->internal[mp_linecap]>0 ) lcap=1;
21142 if ( mp->internal[mp_miterlimit]<unity )
21145 miterlim=mp->internal[mp_miterlimit];
21146 mp->cur_exp = mp_make_envelope(mp, q, value(p), ljoin,lcap,miterlim);
21147 mp->cur_type = mp_path_type;
21150 @ @<Declare binary action...@>=
21151 void mp_find_point (MP mp,scaled v, quarterword c) {
21152 pointer p; /* the path */
21153 scaled n; /* its length */
21155 if ( left_type(p)==mp_endpoint ) n=-unity; else n=0;
21156 do { p=link(p); n=n+unity; } while (p!=mp->cur_exp);
21159 } else if ( v<0 ) {
21160 if ( left_type(p)==mp_endpoint ) v=0;
21161 else v=n-1-((-v-1) % n);
21162 } else if ( v>n ) {
21163 if ( left_type(p)==mp_endpoint ) v=n;
21167 while ( v>=unity ) { p=link(p); v=v-unity; };
21169 @<Insert a fractional node by splitting the cubic@>;
21171 @<Set the current expression to the desired path coordinates@>;
21174 @ @<Insert a fractional node...@>=
21175 { mp_split_cubic(mp, p,v*010000); p=link(p); }
21177 @ @<Set the current expression to the desired path coordinates...@>=
21180 mp_pair_value(mp, x_coord(p),y_coord(p));
21182 case precontrol_of:
21183 if ( left_type(p)==mp_endpoint ) mp_pair_value(mp, x_coord(p),y_coord(p));
21184 else mp_pair_value(mp, left_x(p),left_y(p));
21186 case postcontrol_of:
21187 if ( right_type(p)==mp_endpoint ) mp_pair_value(mp, x_coord(p),y_coord(p));
21188 else mp_pair_value(mp, right_x(p),right_y(p));
21190 } /* there are no other cases */
21192 @ @<Additional cases of binary operators@>=
21194 if ( mp->cur_type==mp_pair_type )
21195 mp_pair_to_path(mp);
21196 if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_known) )
21197 mp_flush_cur_exp(mp, mp_get_arc_time(mp, mp->cur_exp,value(p)));
21199 mp_bad_binary(mp, p,c);
21202 @ @<Additional cases of bin...@>=
21204 if ( type(p)==mp_pair_type ) {
21205 q=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, p);
21206 mp_pair_to_path(mp); p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q);
21208 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
21209 if ( (mp->cur_type==mp_path_type)&&(type(p)==mp_path_type) ) {
21210 mp_path_intersection(mp, value(p),mp->cur_exp);
21211 mp_pair_value(mp, mp->cur_t,mp->cur_tt);
21213 mp_bad_binary(mp, p,intersect);
21217 @ @<Additional cases of bin...@>=
21219 if ( (mp->cur_type!=mp_string_type)||(type(p)!=mp_string_type))
21220 mp_bad_binary(mp, p,in_font);
21221 else { mp_do_infont(mp, p); binary_return; }
21224 @ Function |new_text_node| owns the reference count for its second argument
21225 (the text string) but not its first (the font name).
21227 @<Declare binary action...@>=
21228 void mp_do_infont (MP mp,pointer p) {
21230 q=mp_get_node(mp, edge_header_size);
21231 mp_init_edges(mp, q);
21232 link(obj_tail(q))=mp_new_text_node(mp,str(mp->cur_exp),value(p));
21233 obj_tail(q)=link(obj_tail(q));
21234 mp_free_node(mp, p,value_node_size);
21235 mp_flush_cur_exp(mp, q);
21236 mp->cur_type=mp_picture_type;
21239 @* \[40] Statements and commands.
21240 The chief executive of \MP\ is the |do_statement| routine, which
21241 contains the master switch that causes all the various pieces of \MP\
21242 to do their things, in the right order.
21244 In a sense, this is the grand climax of the program: It applies all the
21245 tools that we have worked so hard to construct. In another sense, this is
21246 the messiest part of the program: It necessarily refers to other pieces
21247 of code all over the place, so that a person can't fully understand what is
21248 going on without paging back and forth to be reminded of conventions that
21249 are defined elsewhere. We are now at the hub of the web.
21251 The structure of |do_statement| itself is quite simple. The first token
21252 of the statement is fetched using |get_x_next|. If it can be the first
21253 token of an expression, we look for an equation, an assignment, or a
21254 title. Otherwise we use a \&{case} construction to branch at high speed to
21255 the appropriate routine for various and sundry other types of commands,
21256 each of which has an ``action procedure'' that does the necessary work.
21258 The program uses the fact that
21259 $$\hbox{|min_primary_command=max_statement_command=type_name|}$$
21260 to interpret a statement that starts with, e.g., `\&{string}',
21261 as a type declaration rather than a boolean expression.
21263 @c void mp_do_statement (MP mp) { /* governs \MP's activities */
21264 mp->cur_type=mp_vacuous; mp_get_x_next(mp);
21265 if ( mp->cur_cmd>max_primary_command ) {
21266 @<Worry about bad statement@>;
21267 } else if ( mp->cur_cmd>max_statement_command ) {
21268 @<Do an equation, assignment, title, or
21269 `$\langle\,$expression$\,\rangle\,$\&{endgroup}'@>;
21271 @<Do a statement that doesn't begin with an expression@>;
21273 if ( mp->cur_cmd<semicolon )
21274 @<Flush unparsable junk that was found after the statement@>;
21278 @ @<Declarations@>=
21279 @<Declare action procedures for use by |do_statement|@>
21281 @ The only command codes |>max_primary_command| that can be present
21282 at the beginning of a statement are |semicolon| and higher; these
21283 occur when the statement is null.
21285 @<Worry about bad statement@>=
21287 if ( mp->cur_cmd<semicolon ) {
21288 print_err("A statement can't begin with `");
21289 @.A statement can't begin with x@>
21290 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod); mp_print_char(mp, '\'');
21291 help5("I was looking for the beginning of a new statement.")
21292 ("If you just proceed without changing anything, I'll ignore")
21293 ("everything up to the next `;'. Please insert a semicolon")
21294 ("now in front of anything that you don't want me to delete.")
21295 ("(See Chapter 27 of The METAFONTbook for an example.)");
21296 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
21297 mp_back_error(mp); mp_get_x_next(mp);
21301 @ The help message printed here says that everything is flushed up to
21302 a semicolon, but actually the commands |end_group| and |stop| will
21303 also terminate a statement.
21305 @<Flush unparsable junk that was found after the statement@>=
21307 print_err("Extra tokens will be flushed");
21308 @.Extra tokens will be flushed@>
21309 help6("I've just read as much of that statement as I could fathom,")
21310 ("so a semicolon should have been next. It's very puzzling...")
21311 ("but I'll try to get myself back together, by ignoring")
21312 ("everything up to the next `;'. Please insert a semicolon")
21313 ("now in front of anything that you don't want me to delete.")
21314 ("(See Chapter 27 of The METAFONTbook for an example.)");
21315 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
21316 mp_back_error(mp); mp->scanner_status=flushing;
21319 @<Decrease the string reference count...@>;
21320 } while (! end_of_statement); /* |cur_cmd=semicolon|, |end_group|, or |stop| */
21321 mp->scanner_status=normal;
21324 @ If |do_statement| ends with |cur_cmd=end_group|, we should have
21325 |cur_type=mp_vacuous| unless the statement was simply an expression;
21326 in the latter case, |cur_type| and |cur_exp| should represent that
21329 @<Do a statement that doesn't...@>=
21331 if ( mp->internal[mp_tracing_commands]>0 )
21333 switch (mp->cur_cmd ) {
21334 case type_name:mp_do_type_declaration(mp); break;
21336 if ( mp->cur_mod>var_def ) mp_make_op_def(mp);
21337 else if ( mp->cur_mod>end_def ) mp_scan_def(mp);
21339 @<Cases of |do_statement| that invoke particular commands@>;
21340 } /* there are no other cases */
21341 mp->cur_type=mp_vacuous;
21344 @ The most important statements begin with expressions.
21346 @<Do an equation, assignment, title, or...@>=
21348 mp->var_flag=assignment; mp_scan_expression(mp);
21349 if ( mp->cur_cmd<end_group ) {
21350 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21351 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21352 else if ( mp->cur_type==mp_string_type ) {@<Do a title@> ; }
21353 else if ( mp->cur_type!=mp_vacuous ){
21354 exp_err("Isolated expression");
21355 @.Isolated expression@>
21356 help3("I couldn't find an `=' or `:=' after the")
21357 ("expression that is shown above this error message,")
21358 ("so I guess I'll just ignore it and carry on.");
21359 mp_put_get_error(mp);
21361 mp_flush_cur_exp(mp, 0); mp->cur_type=mp_vacuous;
21367 if ( mp->internal[mp_tracing_titles]>0 ) {
21368 mp_print_nl(mp, ""); mp_print_str(mp, mp->cur_exp); update_terminal;
21372 @ Equations and assignments are performed by the pair of mutually recursive
21374 routines |do_equation| and |do_assignment|. These routines are called when
21375 |cur_cmd=equals| and when |cur_cmd=assignment|, respectively; the left-hand
21376 side is in |cur_type| and |cur_exp|, while the right-hand side is yet
21377 to be scanned. After the routines are finished, |cur_type| and |cur_exp|
21378 will be equal to the right-hand side (which will normally be equal
21379 to the left-hand side).
21381 @<Declare action procedures for use by |do_statement|@>=
21382 @<Declare the procedure called |try_eq|@>
21383 @<Declare the procedure called |make_eq|@>
21384 void mp_do_equation (MP mp) ;
21387 void mp_do_equation (MP mp) {
21388 pointer lhs; /* capsule for the left-hand side */
21389 pointer p; /* temporary register */
21390 lhs=mp_stash_cur_exp(mp); mp_get_x_next(mp);
21391 mp->var_flag=assignment; mp_scan_expression(mp);
21392 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21393 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21394 if ( mp->internal[mp_tracing_commands]>two )
21395 @<Trace the current equation@>;
21396 if ( mp->cur_type==mp_unknown_path ) if ( type(lhs)==mp_pair_type ) {
21397 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, lhs); lhs=p;
21398 }; /* in this case |make_eq| will change the pair to a path */
21399 mp_make_eq(mp, lhs); /* equate |lhs| to |(cur_type,cur_exp)| */
21402 @ And |do_assignment| is similar to |do_equation|:
21405 void mp_do_assignment (MP mp);
21407 @ @<Declare action procedures for use by |do_statement|@>=
21408 void mp_do_assignment (MP mp) ;
21411 void mp_do_assignment (MP mp) {
21412 pointer lhs; /* token list for the left-hand side */
21413 pointer p; /* where the left-hand value is stored */
21414 pointer q; /* temporary capsule for the right-hand value */
21415 if ( mp->cur_type!=mp_token_list ) {
21416 exp_err("Improper `:=' will be changed to `='");
21418 help2("I didn't find a variable name at the left of the `:=',")
21419 ("so I'm going to pretend that you said `=' instead.");
21420 mp_error(mp); mp_do_equation(mp);
21422 lhs=mp->cur_exp; mp->cur_type=mp_vacuous;
21423 mp_get_x_next(mp); mp->var_flag=assignment; mp_scan_expression(mp);
21424 if ( mp->cur_cmd==equals ) mp_do_equation(mp);
21425 else if ( mp->cur_cmd==assignment ) mp_do_assignment(mp);
21426 if ( mp->internal[mp_tracing_commands]>two )
21427 @<Trace the current assignment@>;
21428 if ( info(lhs)>hash_end ) {
21429 @<Assign the current expression to an internal variable@>;
21431 @<Assign the current expression to the variable |lhs|@>;
21433 mp_flush_node_list(mp, lhs);
21437 @ @<Trace the current equation@>=
21439 mp_begin_diagnostic(mp); mp_print_nl(mp, "{("); mp_print_exp(mp,lhs,0);
21440 mp_print(mp,")=("); mp_print_exp(mp,null,0);
21441 mp_print(mp,")}"); mp_end_diagnostic(mp, false);
21444 @ @<Trace the current assignment@>=
21446 mp_begin_diagnostic(mp); mp_print_nl(mp, "{");
21447 if ( info(lhs)>hash_end )
21448 mp_print(mp, mp->int_name[info(lhs)-(hash_end)]);
21450 mp_show_token_list(mp, lhs,null,1000,0);
21451 mp_print(mp, ":="); mp_print_exp(mp, null,0);
21452 mp_print_char(mp, '}'); mp_end_diagnostic(mp, false);
21455 @ @<Assign the current expression to an internal variable@>=
21456 if ( mp->cur_type==mp_known ) {
21457 mp->internal[info(lhs)-(hash_end)]=mp->cur_exp;
21459 exp_err("Internal quantity `");
21460 @.Internal quantity...@>
21461 mp_print(mp, mp->int_name[info(lhs)-(hash_end)]);
21462 mp_print(mp, "' must receive a known value");
21463 help2("I can\'t set an internal quantity to anything but a known")
21464 ("numeric value, so I'll have to ignore this assignment.");
21465 mp_put_get_error(mp);
21468 @ @<Assign the current expression to the variable |lhs|@>=
21470 p=mp_find_variable(mp, lhs);
21472 q=mp_stash_cur_exp(mp); mp->cur_type=mp_und_type(mp, p);
21473 mp_recycle_value(mp, p);
21474 type(p)=mp->cur_type; value(p)=null; mp_make_exp_copy(mp, p);
21475 p=mp_stash_cur_exp(mp); mp_unstash_cur_exp(mp, q); mp_make_eq(mp, p);
21477 mp_obliterated(mp, lhs); mp_put_get_error(mp);
21482 @ And now we get to the nitty-gritty. The |make_eq| procedure is given
21483 a pointer to a capsule that is to be equated to the current expression.
21485 @<Declare the procedure called |make_eq|@>=
21486 void mp_make_eq (MP mp,pointer lhs) ;
21490 @c void mp_make_eq (MP mp,pointer lhs) {
21491 small_number t; /* type of the left-hand side */
21492 pointer p,q; /* pointers inside of big nodes */
21493 integer v=0; /* value of the left-hand side */
21496 if ( t<=mp_pair_type ) v=value(lhs);
21498 @<For each type |t|, make an equation and |goto done| unless |cur_type|
21499 is incompatible with~|t|@>;
21500 } /* all cases have been listed */
21501 @<Announce that the equation cannot be performed@>;
21503 check_arith; mp_recycle_value(mp, lhs);
21504 mp_free_node(mp, lhs,value_node_size);
21507 @ @<Announce that the equation cannot be performed@>=
21508 mp_disp_err(mp, lhs,"");
21509 exp_err("Equation cannot be performed (");
21510 @.Equation cannot be performed@>
21511 if ( type(lhs)<=mp_pair_type ) mp_print_type(mp, type(lhs));
21512 else mp_print(mp, "numeric");
21513 mp_print_char(mp, '=');
21514 if ( mp->cur_type<=mp_pair_type ) mp_print_type(mp, mp->cur_type);
21515 else mp_print(mp, "numeric");
21516 mp_print_char(mp, ')');
21517 help2("I'm sorry, but I don't know how to make such things equal.")
21518 ("(See the two expressions just above the error message.)");
21519 mp_put_get_error(mp)
21521 @ @<For each type |t|, make an equation and |goto done| unless...@>=
21522 case mp_boolean_type: case mp_string_type: case mp_pen_type:
21523 case mp_path_type: case mp_picture_type:
21524 if ( mp->cur_type==t+unknown_tag ) {
21525 mp_nonlinear_eq(mp, v,mp->cur_exp,false);
21526 mp_unstash_cur_exp(mp, mp->cur_exp); goto DONE;
21527 } else if ( mp->cur_type==t ) {
21528 @<Report redundant or inconsistent equation and |goto done|@>;
21531 case unknown_types:
21532 if ( mp->cur_type==t-unknown_tag ) {
21533 mp_nonlinear_eq(mp, mp->cur_exp,lhs,true); goto DONE;
21534 } else if ( mp->cur_type==t ) {
21535 mp_ring_merge(mp, lhs,mp->cur_exp); goto DONE;
21536 } else if ( mp->cur_type==mp_pair_type ) {
21537 if ( t==mp_unknown_path ) {
21538 mp_pair_to_path(mp); goto RESTART;
21542 case mp_transform_type: case mp_color_type:
21543 case mp_cmykcolor_type: case mp_pair_type:
21544 if ( mp->cur_type==t ) {
21545 @<Do multiple equations and |goto done|@>;
21548 case mp_known: case mp_dependent:
21549 case mp_proto_dependent: case mp_independent:
21550 if ( mp->cur_type>=mp_known ) {
21551 mp_try_eq(mp, lhs,null); goto DONE;
21557 @ @<Report redundant or inconsistent equation and |goto done|@>=
21559 if ( mp->cur_type<=mp_string_type ) {
21560 if ( mp->cur_type==mp_string_type ) {
21561 if ( mp_str_vs_str(mp, v,mp->cur_exp)!=0 ) {
21564 } else if ( v!=mp->cur_exp ) {
21567 @<Exclaim about a redundant equation@>; goto DONE;
21569 print_err("Redundant or inconsistent equation");
21570 @.Redundant or inconsistent equation@>
21571 help2("An equation between already-known quantities can't help.")
21572 ("But don't worry; continue and I'll just ignore it.");
21573 mp_put_get_error(mp); goto DONE;
21575 print_err("Inconsistent equation");
21576 @.Inconsistent equation@>
21577 help2("The equation I just read contradicts what was said before.")
21578 ("But don't worry; continue and I'll just ignore it.");
21579 mp_put_get_error(mp); goto DONE;
21582 @ @<Do multiple equations and |goto done|@>=
21584 p=v+mp->big_node_size[t];
21585 q=value(mp->cur_exp)+mp->big_node_size[t];
21587 p=p-2; q=q-2; mp_try_eq(mp, p,q);
21592 @ The first argument to |try_eq| is the location of a value node
21593 in a capsule that will soon be recycled. The second argument is
21594 either a location within a pair or transform node pointed to by
21595 |cur_exp|, or it is |null| (which means that |cur_exp| itself
21596 serves as the second argument). The idea is to leave |cur_exp| unchanged,
21597 but to equate the two operands.
21599 @<Declare the procedure called |try_eq|@>=
21600 void mp_try_eq (MP mp,pointer l, pointer r) ;
21603 @c void mp_try_eq (MP mp,pointer l, pointer r) {
21604 pointer p; /* dependency list for right operand minus left operand */
21605 int t; /* the type of list |p| */
21606 pointer q; /* the constant term of |p| is here */
21607 pointer pp; /* dependency list for right operand */
21608 int tt; /* the type of list |pp| */
21609 boolean copied; /* have we copied a list that ought to be recycled? */
21610 @<Remove the left operand from its container, negate it, and
21611 put it into dependency list~|p| with constant term~|q|@>;
21612 @<Add the right operand to list |p|@>;
21613 if ( info(p)==null ) {
21614 @<Deal with redundant or inconsistent equation@>;
21616 mp_linear_eq(mp, p,t);
21617 if ( r==null ) if ( mp->cur_type!=mp_known ) {
21618 if ( type(mp->cur_exp)==mp_known ) {
21619 pp=mp->cur_exp; mp->cur_exp=value(mp->cur_exp); mp->cur_type=mp_known;
21620 mp_free_node(mp, pp,value_node_size);
21626 @ @<Remove the left operand from its container, negate it, and...@>=
21628 if ( t==mp_known ) {
21629 t=mp_dependent; p=mp_const_dependency(mp, -value(l)); q=p;
21630 } else if ( t==mp_independent ) {
21631 t=mp_dependent; p=mp_single_dependency(mp, l); negate(value(p));
21634 p=dep_list(l); q=p;
21637 if ( info(q)==null ) break;
21640 link(prev_dep(l))=link(q); prev_dep(link(q))=prev_dep(l);
21644 @ @<Deal with redundant or inconsistent equation@>=
21646 if ( abs(value(p))>64 ) { /* off by .001 or more */
21647 print_err("Inconsistent equation");
21648 @.Inconsistent equation@>
21649 mp_print(mp, " (off by "); mp_print_scaled(mp, value(p));
21650 mp_print_char(mp, ')');
21651 help2("The equation I just read contradicts what was said before.")
21652 ("But don't worry; continue and I'll just ignore it.");
21653 mp_put_get_error(mp);
21654 } else if ( r==null ) {
21655 @<Exclaim about a redundant equation@>;
21657 mp_free_node(mp, p,dep_node_size);
21660 @ @<Add the right operand to list |p|@>=
21662 if ( mp->cur_type==mp_known ) {
21663 value(q)=value(q)+mp->cur_exp; goto DONE1;
21666 if ( tt==mp_independent ) pp=mp_single_dependency(mp, mp->cur_exp);
21667 else pp=dep_list(mp->cur_exp);
21670 if ( type(r)==mp_known ) {
21671 value(q)=value(q)+value(r); goto DONE1;
21674 if ( tt==mp_independent ) pp=mp_single_dependency(mp, r);
21675 else pp=dep_list(r);
21678 if ( tt!=mp_independent ) copied=false;
21679 else { copied=true; tt=mp_dependent; };
21680 @<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>;
21681 if ( copied ) mp_flush_node_list(mp, pp);
21684 @ @<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>=
21685 mp->watch_coefs=false;
21687 p=mp_p_plus_q(mp, p,pp,t);
21688 } else if ( t==mp_proto_dependent ) {
21689 p=mp_p_plus_fq(mp, p,unity,pp,mp_proto_dependent,mp_dependent);
21692 while ( info(q)!=null ) {
21693 value(q)=mp_round_fraction(mp, value(q)); q=link(q);
21695 t=mp_proto_dependent; p=mp_p_plus_q(mp, p,pp,t);
21697 mp->watch_coefs=true;
21699 @ Our next goal is to process type declarations. For this purpose it's
21700 convenient to have a procedure that scans a $\langle\,$declared
21701 variable$\,\rangle$ and returns the corresponding token list. After the
21702 following procedure has acted, the token after the declared variable
21703 will have been scanned, so it will appear in |cur_cmd|, |cur_mod|,
21706 @<Declare the function called |scan_declared_variable|@>=
21707 pointer mp_scan_declared_variable (MP mp) {
21708 pointer x; /* hash address of the variable's root */
21709 pointer h,t; /* head and tail of the token list to be returned */
21710 pointer l; /* hash address of left bracket */
21711 mp_get_symbol(mp); x=mp->cur_sym;
21712 if ( mp->cur_cmd!=tag_token ) mp_clear_symbol(mp, x,false);
21713 h=mp_get_avail(mp); info(h)=x; t=h;
21716 if ( mp->cur_sym==0 ) break;
21717 if ( mp->cur_cmd!=tag_token ) if ( mp->cur_cmd!=internal_quantity) {
21718 if ( mp->cur_cmd==left_bracket ) {
21719 @<Descend past a collective subscript@>;
21724 link(t)=mp_get_avail(mp); t=link(t); info(t)=mp->cur_sym;
21726 if ( (eq_type(x)%outer_tag)!=tag_token ) mp_clear_symbol(mp, x,false);
21727 if ( equiv(x)==null ) mp_new_root(mp, x);
21731 @ If the subscript isn't collective, we don't accept it as part of the
21734 @<Descend past a collective subscript@>=
21736 l=mp->cur_sym; mp_get_x_next(mp);
21737 if ( mp->cur_cmd!=right_bracket ) {
21738 mp_back_input(mp); mp->cur_sym=l; mp->cur_cmd=left_bracket; break;
21740 mp->cur_sym=collective_subscript;
21744 @ Type declarations are introduced by the following primitive operations.
21747 mp_primitive(mp, "numeric",type_name,mp_numeric_type);
21748 @:numeric_}{\&{numeric} primitive@>
21749 mp_primitive(mp, "string",type_name,mp_string_type);
21750 @:string_}{\&{string} primitive@>
21751 mp_primitive(mp, "boolean",type_name,mp_boolean_type);
21752 @:boolean_}{\&{boolean} primitive@>
21753 mp_primitive(mp, "path",type_name,mp_path_type);
21754 @:path_}{\&{path} primitive@>
21755 mp_primitive(mp, "pen",type_name,mp_pen_type);
21756 @:pen_}{\&{pen} primitive@>
21757 mp_primitive(mp, "picture",type_name,mp_picture_type);
21758 @:picture_}{\&{picture} primitive@>
21759 mp_primitive(mp, "transform",type_name,mp_transform_type);
21760 @:transform_}{\&{transform} primitive@>
21761 mp_primitive(mp, "color",type_name,mp_color_type);
21762 @:color_}{\&{color} primitive@>
21763 mp_primitive(mp, "rgbcolor",type_name,mp_color_type);
21764 @:color_}{\&{rgbcolor} primitive@>
21765 mp_primitive(mp, "cmykcolor",type_name,mp_cmykcolor_type);
21766 @:color_}{\&{cmykcolor} primitive@>
21767 mp_primitive(mp, "pair",type_name,mp_pair_type);
21768 @:pair_}{\&{pair} primitive@>
21770 @ @<Cases of |print_cmd...@>=
21771 case type_name: mp_print_type(mp, m); break;
21773 @ Now we are ready to handle type declarations, assuming that a
21774 |type_name| has just been scanned.
21776 @<Declare action procedures for use by |do_statement|@>=
21777 void mp_do_type_declaration (MP mp) ;
21780 void mp_do_type_declaration (MP mp) {
21781 small_number t; /* the type being declared */
21782 pointer p; /* token list for a declared variable */
21783 pointer q; /* value node for the variable */
21784 if ( mp->cur_mod>=mp_transform_type )
21787 t=mp->cur_mod+unknown_tag;
21789 p=mp_scan_declared_variable(mp);
21790 mp_flush_variable(mp, equiv(info(p)),link(p),false);
21791 q=mp_find_variable(mp, p);
21793 type(q)=t; value(q)=null;
21795 print_err("Declared variable conflicts with previous vardef");
21796 @.Declared variable conflicts...@>
21797 help2("You can't use, e.g., `numeric foo[]' after `vardef foo'.")
21798 ("Proceed, and I'll ignore the illegal redeclaration.");
21799 mp_put_get_error(mp);
21801 mp_flush_list(mp, p);
21802 if ( mp->cur_cmd<comma ) {
21803 @<Flush spurious symbols after the declared variable@>;
21805 } while (! end_of_statement);
21808 @ @<Flush spurious symbols after the declared variable@>=
21810 print_err("Illegal suffix of declared variable will be flushed");
21811 @.Illegal suffix...flushed@>
21812 help5("Variables in declarations must consist entirely of")
21813 ("names and collective subscripts, e.g., `x[]a'.")
21814 ("Are you trying to use a reserved word in a variable name?")
21815 ("I'm going to discard the junk I found here,")
21816 ("up to the next comma or the end of the declaration.");
21817 if ( mp->cur_cmd==numeric_token )
21818 mp->help_line[2]="Explicit subscripts like `x15a' aren't permitted.";
21819 mp_put_get_error(mp); mp->scanner_status=flushing;
21822 @<Decrease the string reference count...@>;
21823 } while (mp->cur_cmd<comma); /* either |end_of_statement| or |cur_cmd=comma| */
21824 mp->scanner_status=normal;
21827 @ \MP's |main_control| procedure just calls |do_statement| repeatedly
21828 until coming to the end of the user's program.
21829 Each execution of |do_statement| concludes with
21830 |cur_cmd=semicolon|, |end_group|, or |stop|.
21832 @c void mp_main_control (MP mp) {
21834 mp_do_statement(mp);
21835 if ( mp->cur_cmd==end_group ) {
21836 print_err("Extra `endgroup'");
21837 @.Extra `endgroup'@>
21838 help2("I'm not currently working on a `begingroup',")
21839 ("so I had better not try to end anything.");
21840 mp_flush_error(mp, 0);
21842 } while (mp->cur_cmd!=stop);
21844 int __attribute__((noinline))
21847 if (mp->history < mp_fatal_error_stop ) {
21848 @<Install and test the non-local jump buffer@>;
21849 mp_main_control(mp); /* come to life */
21850 mp_final_cleanup(mp); /* prepare for death */
21851 mp_close_files_and_terminate(mp);
21853 return mp->history;
21856 @ For |mp_execute|, we need to define a structure to store the
21857 redirected input and output. This structure holds the five relevant
21858 streams: the three informational output streams, the PostScript
21859 generation stream, and the input stream. These streams have many
21860 things in common, so it makes sense to give them their own structure
21863 \item{fptr} is a virtual file pointer
21864 \item{data} is the data this stream holds
21865 \item{cur} is a cursor pointing into |data|
21866 \item{size} is the allocated length of the data stream
21867 \item{used} is the actual length of the data stream
21869 There are small differences between input and output: |term_in| never
21870 uses |used|, whereas the other four never use |cur|.
21872 @<Exported types@>=
21873 typedef struct mp_stream {
21881 typedef struct mp_run_data {
21882 mp_stream term_out;
21883 mp_stream error_out;
21887 struct mp_edge_object *edges;
21890 @ We need a function to clear an output stream, this is called at the
21891 beginning of |mp_execute|. We also need one for destroying an output
21892 stream, this is called just before a stream is (re)opened.
21895 static void mp_reset_stream(mp_stream *str) {
21901 static void mp_free_stream(mp_stream *str) {
21903 mp_reset_stream(str);
21906 @ @<Declarations@>=
21907 static void mp_reset_stream(mp_stream *str);
21908 static void mp_free_stream(mp_stream *str);
21910 @ The global instance contains a pointer instead of the actual structure
21911 even though it is essentially static, because that makes it is easier to move
21915 mp_run_data run_data;
21917 @ Another type is needed: the indirection will overload some of the
21918 file pointer objects in the instance (but not all). For clarity, an
21919 indirect object is used that wraps a |FILE *|.
21922 typedef struct File {
21926 @ Here are all of the functions that need to be overloaded for |mp_execute|.
21929 static void *mplib_open_file(MP mp, const char *fname, const char *fmode, int ftype);
21930 static int mplib_get_char(void *f, mp_run_data * mplib_data);
21931 static void mplib_unget_char(void *f, mp_run_data * mplib_data, int c);
21932 static char *mplib_read_ascii_file(MP mp, void *ff, size_t * size);
21933 static void mplib_write_ascii_file(MP mp, void *ff, const char *s);
21934 static void mplib_read_binary_file(MP mp, void *ff, void **data, size_t * size);
21935 static void mplib_write_binary_file(MP mp, void *ff, void *s, size_t size);
21936 static void mplib_close_file(MP mp, void *ff);
21937 static int mplib_eof_file(MP mp, void *ff);
21938 static void mplib_flush_file(MP mp, void *ff);
21939 static void mplib_shipout_backend(MP mp, int h);
21941 @ The |xmalloc(1,1)| calls make sure the stored indirection values are unique.
21943 @d reset_stream(a) do {
21944 mp_reset_stream(&(a));
21946 ff->f = xmalloc(1,1);
21952 static void *mplib_open_file(MP mp, const char *fname, const char *fmode, int ftype)
21954 File *ff = xmalloc(1, sizeof(File));
21955 mp_run_data *run = mp_rundata(mp);
21957 if (ftype == mp_filetype_terminal) {
21958 if (fmode[0] == 'r') {
21960 ff->f = xmalloc(1,1);
21961 run->term_in.fptr = ff->f;
21964 reset_stream(run->term_out);
21966 } else if (ftype == mp_filetype_error) {
21967 reset_stream(run->error_out);
21968 } else if (ftype == mp_filetype_log) {
21969 reset_stream(run->log_out);
21970 } else if (ftype == mp_filetype_postscript) {
21971 mp_free_stream(&(run->ps_out));
21972 ff->f = xmalloc(1,1);
21973 run->ps_out.fptr = ff->f;
21976 char *f = (mp->find_file)(mp, fname, fmode, ftype);
21979 realmode[0] = *fmode;
21982 ff->f = fopen(f, realmode);
21984 if ((fmode[0] == 'r') && (ff->f == NULL)) {
21992 static int mplib_get_char(void *f, mp_run_data * run)
21995 if (f == run->term_in.fptr && run->term_in.data != NULL) {
21996 if (run->term_in.size == 0) {
21997 if (run->term_in.cur != NULL) {
21998 run->term_in.cur = NULL;
22000 xfree(run->term_in.data);
22004 run->term_in.size--;
22005 c = *(run->term_in.cur)++;
22013 static void mplib_unget_char(void *f, mp_run_data * run, int c)
22015 if (f == run->term_in.fptr && run->term_in.cur != NULL) {
22016 run->term_in.size++;
22017 run->term_in.cur--;
22024 static char *mplib_read_ascii_file(MP mp, void *ff, size_t * size)
22029 size_t len = 0, lim = 128;
22030 mp_run_data *run = mp_rundata(mp);
22031 FILE *f = ((File *) ff)->f;
22035 c = mplib_get_char(f, run);
22041 while (c != EOF && c != '\n' && c != '\r') {
22043 s = xrealloc(s, (lim + (lim >> 2)),1);
22049 c = mplib_get_char(f, run);
22052 c = mplib_get_char(f, run);
22053 if (c != EOF && c != '\n')
22054 mplib_unget_char(f, run, c);
22062 static void mp_append_string (MP mp, mp_stream *a,const char *b) {
22064 if ((a->used+l)>=a->size) {
22065 a->size += 256+(a->size)/5+l;
22066 a->data = xrealloc(a->data,a->size,1);
22068 (void)strcpy(a->data+a->used,b);
22073 static void mplib_write_ascii_file(MP mp, void *ff, const char *s)
22076 void *f = ((File *) ff)->f;
22077 mp_run_data *run = mp_rundata(mp);
22079 if (f == run->term_out.fptr) {
22080 mp_append_string(mp,&(run->term_out), s);
22081 } else if (f == run->error_out.fptr) {
22082 mp_append_string(mp,&(run->error_out), s);
22083 } else if (f == run->log_out.fptr) {
22084 mp_append_string(mp,&(run->log_out), s);
22085 } else if (f == run->ps_out.fptr) {
22086 mp_append_string(mp,&(run->ps_out), s);
22088 fprintf((FILE *) f, "%s", s);
22094 static void mplib_read_binary_file(MP mp, void *ff, void **data, size_t * size)
22099 FILE *f = ((File *) ff)->f;
22101 len = fread(*data, 1, *size, f);
22106 static void mplib_write_binary_file(MP mp, void *ff, void *s, size_t size)
22110 FILE *f = ((File *) ff)->f;
22112 fwrite(s, size, 1, f);
22116 static void mplib_close_file(MP mp, void *ff)
22119 mp_run_data *run = mp_rundata(mp);
22120 void *f = ((File *) ff)->f;
22122 if (f != run->term_out.fptr
22123 && f != run->error_out.fptr
22124 && f != run->log_out.fptr
22125 && f != run->ps_out.fptr
22126 && f != run->term_in.fptr) {
22134 static int mplib_eof_file(MP mp, void *ff)
22137 mp_run_data *run = mp_rundata(mp);
22138 FILE *f = ((File *) ff)->f;
22141 if (f == run->term_in.fptr && run->term_in.data != NULL) {
22142 return (run->term_in.size == 0);
22149 static void mplib_flush_file(MP mp, void *ff)
22156 static void mplib_shipout_backend(MP mp, int h)
22158 struct mp_edge_object *hh = mp_gr_export(mp, h);
22160 mp_run_data *run = mp_rundata(mp);
22161 if (run->edges==NULL) {
22164 struct mp_edge_object *p = run->edges;
22165 while (p->_next!=NULL) { p = p->_next; }
22172 @ This is where we fill them all in.
22173 @<Prepare function pointers for non-interactive use@>=
22175 mp->open_file = mplib_open_file;
22176 mp->close_file = mplib_close_file;
22177 mp->eof_file = mplib_eof_file;
22178 mp->flush_file = mplib_flush_file;
22179 mp->write_ascii_file = mplib_write_ascii_file;
22180 mp->read_ascii_file = mplib_read_ascii_file;
22181 mp->write_binary_file = mplib_write_binary_file;
22182 mp->read_binary_file = mplib_read_binary_file;
22183 mp->shipout_backend = mplib_shipout_backend;
22186 @ Perhaps this is the most important API function in the library.
22188 @<Exported function ...@>=
22189 mp_run_data *mp_rundata (MP mp) ;
22192 mp_run_data *mp_rundata (MP mp) {
22193 return &(mp->run_data);
22197 mp_free_stream(&(mp->run_data.term_in));
22198 mp_free_stream(&(mp->run_data.term_out));
22199 mp_free_stream(&(mp->run_data.log_out));
22200 mp_free_stream(&(mp->run_data.error_out));
22201 mp_free_stream(&(mp->run_data.ps_out));
22203 @ @<Finish non-interactive use@>=
22204 xfree(mp->term_out);
22205 xfree(mp->term_in);
22206 xfree(mp->err_out);
22208 @ @<Start non-interactive work@>=
22209 @<Initialize the output routines@>;
22210 mp->input_ptr=0; mp->max_in_stack=0;
22211 mp->in_open=0; mp->open_parens=0; mp->max_buf_stack=0;
22212 mp->param_ptr=0; mp->max_param_stack=0;
22213 start = iindex = loc = mp->first = 0;
22214 line=0; name=is_term;
22215 mp->mpx_name[0]=absent;
22216 mp->force_eof=false;
22218 mp->scanner_status=normal;
22219 if (mp->mem_ident==NULL) {
22220 if ( ! mp_load_mem_file(mp) ) {
22221 (mp->close_file)(mp, mp->mem_file);
22222 mp->history = mp_fatal_error_stop;
22223 return mp->history;
22225 (mp->close_file)(mp, mp->mem_file);
22227 mp_fix_date_and_time(mp);
22228 if (mp->random_seed==0)
22229 mp->random_seed = (mp->internal[mp_time] / unity)+mp->internal[mp_day];
22230 mp_init_randoms(mp, mp->random_seed);
22231 @<Initialize the print |selector|...@>;
22232 mp_open_log_file(mp);
22234 mp_init_map_file(mp, mp->troff_mode);
22235 mp->history=mp_spotless; /* ready to go! */
22236 if (mp->troff_mode) {
22237 mp->internal[mp_gtroffmode]=unity;
22238 mp->internal[mp_prologues]=unity;
22240 if ( mp->start_sym>0 ) { /* insert the `\&{everyjob}' symbol */
22241 mp->cur_sym=mp->start_sym; mp_back_input(mp);
22245 int __attribute__((noinline))
22246 mp_execute (MP mp, char *s, size_t l) {
22248 mp_reset_stream(&(mp->run_data.term_out));
22249 mp_reset_stream(&(mp->run_data.log_out));
22250 mp_reset_stream(&(mp->run_data.error_out));
22251 mp_reset_stream(&(mp->run_data.ps_out));
22252 if (mp->finished) {
22253 return mp->history;
22254 } else if (!mp->noninteractive) {
22255 mp->history = mp_fatal_error_stop ;
22256 return mp->history;
22258 if (mp->history < mp_fatal_error_stop ) {
22259 mp->jump_buf = &buf;
22260 if (setjmp(*(mp->jump_buf)) != 0) {
22261 return mp->history;
22263 if (s==NULL) { /* this signals EOF */
22264 mp_final_cleanup(mp); /* prepare for death */
22265 mp_close_files_and_terminate(mp);
22266 return mp->history;
22269 mp->term_offset=0; mp->file_offset=0;
22270 /* Perhaps some sort of warning here when |data| is not
22271 * yet exhausted would be nice ... this happens after errors
22273 if (mp->run_data.term_in.data)
22274 xfree(mp->run_data.term_in.data);
22275 mp->run_data.term_in.data = xstrdup(s);
22276 mp->run_data.term_in.cur = mp->run_data.term_in.data;
22277 mp->run_data.term_in.size = l;
22278 if (mp->run_state == 0) {
22279 mp->selector=term_only;
22280 @<Start non-interactive work@>;
22283 mp_input_ln(mp,mp->term_in);
22284 mp_firm_up_the_line(mp);
22285 mp->buffer[limit]='%';
22289 mp_do_statement(mp);
22290 } while (mp->cur_cmd!=stop);
22291 mp_final_cleanup(mp);
22292 mp_close_files_and_terminate(mp);
22294 return mp->history;
22297 @ This function cleans up
22299 int __attribute__((noinline))
22300 mp_finish (MP mp) {
22301 int history = mp->history;
22302 if (!mp->finished) {
22303 if (mp->history < mp_fatal_error_stop ) {
22305 mp->jump_buf = &buf;
22306 if (setjmp(*(mp->jump_buf)) != 0) {
22307 history = mp->history;
22308 mp_close_files_and_terminate(mp);
22311 mp_final_cleanup(mp); /* prepare for death */
22312 mp_close_files_and_terminate(mp);
22320 @ People may want to know the library version
22322 const char * mp_metapost_version (void) {
22323 return metapost_version;
22326 @ @<Exported function headers@>=
22327 int mp_run (MP mp);
22328 int mp_execute (MP mp, char *s, size_t l);
22329 int mp_finish (MP mp);
22330 const char * mp_metapost_version (void);
22333 mp_primitive(mp, "end",stop,0);
22334 @:end_}{\&{end} primitive@>
22335 mp_primitive(mp, "dump",stop,1);
22336 @:dump_}{\&{dump} primitive@>
22338 @ @<Cases of |print_cmd...@>=
22340 if ( m==0 ) mp_print(mp, "end");
22341 else mp_print(mp, "dump");
22345 Let's turn now to statements that are classified as ``commands'' because
22346 of their imperative nature. We'll begin with simple ones, so that it
22347 will be clear how to hook command processing into the |do_statement| routine;
22348 then we'll tackle the tougher commands.
22350 Here's one of the simplest:
22352 @<Cases of |do_statement|...@>=
22353 case mp_random_seed: mp_do_random_seed(mp); break;
22355 @ @<Declare action procedures for use by |do_statement|@>=
22356 void mp_do_random_seed (MP mp) ;
22358 @ @c void mp_do_random_seed (MP mp) {
22360 if ( mp->cur_cmd!=assignment ) {
22361 mp_missing_err(mp, ":=");
22363 help1("Always say `randomseed:=<numeric expression>'.");
22366 mp_get_x_next(mp); mp_scan_expression(mp);
22367 if ( mp->cur_type!=mp_known ) {
22368 exp_err("Unknown value will be ignored");
22369 @.Unknown value...ignored@>
22370 help2("Your expression was too random for me to handle,")
22371 ("so I won't change the random seed just now.");
22372 mp_put_get_flush_error(mp, 0);
22374 @<Initialize the random seed to |cur_exp|@>;
22378 @ @<Initialize the random seed to |cur_exp|@>=
22380 mp_init_randoms(mp, mp->cur_exp);
22381 if ( mp->selector>=log_only && mp->selector<write_file) {
22382 mp->old_setting=mp->selector; mp->selector=log_only;
22383 mp_print_nl(mp, "{randomseed:=");
22384 mp_print_scaled(mp, mp->cur_exp);
22385 mp_print_char(mp, '}');
22386 mp_print_nl(mp, ""); mp->selector=mp->old_setting;
22390 @ And here's another simple one (somewhat different in flavor):
22392 @<Cases of |do_statement|...@>=
22394 mp_print_ln(mp); mp->interaction=mp->cur_mod;
22395 @<Initialize the print |selector| based on |interaction|@>;
22396 if ( mp->log_opened ) mp->selector=mp->selector+2;
22401 mp_primitive(mp, "batchmode",mode_command,mp_batch_mode);
22402 @:mp_batch_mode_}{\&{batchmode} primitive@>
22403 mp_primitive(mp, "nonstopmode",mode_command,mp_nonstop_mode);
22404 @:mp_nonstop_mode_}{\&{nonstopmode} primitive@>
22405 mp_primitive(mp, "scrollmode",mode_command,mp_scroll_mode);
22406 @:mp_scroll_mode_}{\&{scrollmode} primitive@>
22407 mp_primitive(mp, "errorstopmode",mode_command,mp_error_stop_mode);
22408 @:mp_error_stop_mode_}{\&{errorstopmode} primitive@>
22410 @ @<Cases of |print_cmd_mod|...@>=
22413 case mp_batch_mode: mp_print(mp, "batchmode"); break;
22414 case mp_nonstop_mode: mp_print(mp, "nonstopmode"); break;
22415 case mp_scroll_mode: mp_print(mp, "scrollmode"); break;
22416 default: mp_print(mp, "errorstopmode"); break;
22420 @ The `\&{inner}' and `\&{outer}' commands are only slightly harder.
22422 @<Cases of |do_statement|...@>=
22423 case protection_command: mp_do_protection(mp); break;
22426 mp_primitive(mp, "inner",protection_command,0);
22427 @:inner_}{\&{inner} primitive@>
22428 mp_primitive(mp, "outer",protection_command,1);
22429 @:outer_}{\&{outer} primitive@>
22431 @ @<Cases of |print_cmd...@>=
22432 case protection_command:
22433 if ( m==0 ) mp_print(mp, "inner");
22434 else mp_print(mp, "outer");
22437 @ @<Declare action procedures for use by |do_statement|@>=
22438 void mp_do_protection (MP mp) ;
22440 @ @c void mp_do_protection (MP mp) {
22441 int m; /* 0 to unprotect, 1 to protect */
22442 halfword t; /* the |eq_type| before we change it */
22445 mp_get_symbol(mp); t=eq_type(mp->cur_sym);
22447 if ( t>=outer_tag )
22448 eq_type(mp->cur_sym)=t-outer_tag;
22449 } else if ( t<outer_tag ) {
22450 eq_type(mp->cur_sym)=t+outer_tag;
22453 } while (mp->cur_cmd==comma);
22456 @ \MP\ never defines the tokens `\.(' and `\.)' to be primitives, but
22457 plain \MP\ begins with the declaration `\&{delimiters} \.{()}'. Such a
22458 declaration assigns the command code |left_delimiter| to `\.{(}' and
22459 |right_delimiter| to `\.{)}'; the |equiv| of each delimiter is the
22460 hash address of its mate.
22462 @<Cases of |do_statement|...@>=
22463 case delimiters: mp_def_delims(mp); break;
22465 @ @<Declare action procedures for use by |do_statement|@>=
22466 void mp_def_delims (MP mp) ;
22468 @ @c void mp_def_delims (MP mp) {
22469 pointer l_delim,r_delim; /* the new delimiter pair */
22470 mp_get_clear_symbol(mp); l_delim=mp->cur_sym;
22471 mp_get_clear_symbol(mp); r_delim=mp->cur_sym;
22472 eq_type(l_delim)=left_delimiter; equiv(l_delim)=r_delim;
22473 eq_type(r_delim)=right_delimiter; equiv(r_delim)=l_delim;
22477 @ Here is a procedure that is called when \MP\ has reached a point
22478 where some right delimiter is mandatory.
22480 @<Declare the procedure called |check_delimiter|@>=
22481 void mp_check_delimiter (MP mp,pointer l_delim, pointer r_delim) {
22482 if ( mp->cur_cmd==right_delimiter )
22483 if ( mp->cur_mod==l_delim )
22485 if ( mp->cur_sym!=r_delim ) {
22486 mp_missing_err(mp, str(text(r_delim)));
22488 help2("I found no right delimiter to match a left one. So I've")
22489 ("put one in, behind the scenes; this may fix the problem.");
22492 print_err("The token `"); mp_print_text(r_delim);
22493 @.The token...delimiter@>
22494 mp_print(mp, "' is no longer a right delimiter");
22495 help3("Strange: This token has lost its former meaning!")
22496 ("I'll read it as a right delimiter this time;")
22497 ("but watch out, I'll probably miss it later.");
22502 @ The next four commands save or change the values associated with tokens.
22504 @<Cases of |do_statement|...@>=
22507 mp_get_symbol(mp); mp_save_variable(mp, mp->cur_sym); mp_get_x_next(mp);
22508 } while (mp->cur_cmd==comma);
22510 case interim_command: mp_do_interim(mp); break;
22511 case let_command: mp_do_let(mp); break;
22512 case new_internal: mp_do_new_internal(mp); break;
22514 @ @<Declare action procedures for use by |do_statement|@>=
22515 void mp_do_statement (MP mp);
22516 void mp_do_interim (MP mp);
22518 @ @c void mp_do_interim (MP mp) {
22520 if ( mp->cur_cmd!=internal_quantity ) {
22521 print_err("The token `");
22522 @.The token...quantity@>
22523 if ( mp->cur_sym==0 ) mp_print(mp, "(%CAPSULE)");
22524 else mp_print_text(mp->cur_sym);
22525 mp_print(mp, "' isn't an internal quantity");
22526 help1("Something like `tracingonline' should follow `interim'.");
22529 mp_save_internal(mp, mp->cur_mod); mp_back_input(mp);
22531 mp_do_statement(mp);
22534 @ The following procedure is careful not to undefine the left-hand symbol
22535 too soon, lest commands like `{\tt let x=x}' have a surprising effect.
22537 @<Declare action procedures for use by |do_statement|@>=
22538 void mp_do_let (MP mp) ;
22540 @ @c void mp_do_let (MP mp) {
22541 pointer l; /* hash location of the left-hand symbol */
22542 mp_get_symbol(mp); l=mp->cur_sym; mp_get_x_next(mp);
22543 if ( mp->cur_cmd!=equals ) if ( mp->cur_cmd!=assignment ) {
22544 mp_missing_err(mp, "=");
22546 help3("You should have said `let symbol = something'.")
22547 ("But don't worry; I'll pretend that an equals sign")
22548 ("was present. The next token I read will be `something'.");
22552 switch (mp->cur_cmd) {
22553 case defined_macro: case secondary_primary_macro:
22554 case tertiary_secondary_macro: case expression_tertiary_macro:
22555 add_mac_ref(mp->cur_mod);
22560 mp_clear_symbol(mp, l,false); eq_type(l)=mp->cur_cmd;
22561 if ( mp->cur_cmd==tag_token ) equiv(l)=null;
22562 else equiv(l)=mp->cur_mod;
22566 @ @<Declarations@>=
22567 void mp_grow_internals (MP mp, int l);
22568 void mp_do_new_internal (MP mp) ;
22571 void mp_grow_internals (MP mp, int l) {
22575 if ( hash_end+l>max_halfword ) {
22576 mp_confusion(mp, "out of memory space"); /* can't be reached */
22578 int_name = xmalloc ((l+1),sizeof(char *));
22579 internal = xmalloc ((l+1),sizeof(scaled));
22580 for (k=0;k<=l; k++ ) {
22581 if (k<=mp->max_internal) {
22582 internal[k]=mp->internal[k];
22583 int_name[k]=mp->int_name[k];
22589 xfree(mp->internal); xfree(mp->int_name);
22590 mp->int_name = int_name;
22591 mp->internal = internal;
22592 mp->max_internal = l;
22596 void mp_do_new_internal (MP mp) {
22598 if ( mp->int_ptr==mp->max_internal ) {
22599 mp_grow_internals(mp, (mp->max_internal + (mp->max_internal>>2)));
22601 mp_get_clear_symbol(mp); incr(mp->int_ptr);
22602 eq_type(mp->cur_sym)=internal_quantity;
22603 equiv(mp->cur_sym)=mp->int_ptr;
22604 if(mp->int_name[mp->int_ptr]!=NULL)
22605 xfree(mp->int_name[mp->int_ptr]);
22606 mp->int_name[mp->int_ptr]=str(text(mp->cur_sym));
22607 mp->internal[mp->int_ptr]=0;
22609 } while (mp->cur_cmd==comma);
22612 @ @<Dealloc variables@>=
22613 for (k=0;k<=mp->max_internal;k++) {
22614 xfree(mp->int_name[k]);
22616 xfree(mp->internal);
22617 xfree(mp->int_name);
22620 @ The various `\&{show}' commands are distinguished by modifier fields
22623 @d show_token_code 0 /* show the meaning of a single token */
22624 @d show_stats_code 1 /* show current memory and string usage */
22625 @d show_code 2 /* show a list of expressions */
22626 @d show_var_code 3 /* show a variable and its descendents */
22627 @d show_dependencies_code 4 /* show dependent variables in terms of independents */
22630 mp_primitive(mp, "showtoken",show_command,show_token_code);
22631 @:show_token_}{\&{showtoken} primitive@>
22632 mp_primitive(mp, "showstats",show_command,show_stats_code);
22633 @:show_stats_}{\&{showstats} primitive@>
22634 mp_primitive(mp, "show",show_command,show_code);
22635 @:show_}{\&{show} primitive@>
22636 mp_primitive(mp, "showvariable",show_command,show_var_code);
22637 @:show_var_}{\&{showvariable} primitive@>
22638 mp_primitive(mp, "showdependencies",show_command,show_dependencies_code);
22639 @:show_dependencies_}{\&{showdependencies} primitive@>
22641 @ @<Cases of |print_cmd...@>=
22644 case show_token_code:mp_print(mp, "showtoken"); break;
22645 case show_stats_code:mp_print(mp, "showstats"); break;
22646 case show_code:mp_print(mp, "show"); break;
22647 case show_var_code:mp_print(mp, "showvariable"); break;
22648 default: mp_print(mp, "showdependencies"); break;
22652 @ @<Cases of |do_statement|...@>=
22653 case show_command:mp_do_show_whatever(mp); break;
22655 @ The value of |cur_mod| controls the |verbosity| in the |print_exp| routine:
22656 if it's |show_code|, complicated structures are abbreviated, otherwise
22659 @<Declare action procedures for use by |do_statement|@>=
22660 void mp_do_show (MP mp) ;
22662 @ @c void mp_do_show (MP mp) {
22664 mp_get_x_next(mp); mp_scan_expression(mp);
22665 mp_print_nl(mp, ">> ");
22667 mp_print_exp(mp, null,2); mp_flush_cur_exp(mp, 0);
22668 } while (mp->cur_cmd==comma);
22671 @ @<Declare action procedures for use by |do_statement|@>=
22672 void mp_disp_token (MP mp) ;
22674 @ @c void mp_disp_token (MP mp) {
22675 mp_print_nl(mp, "> ");
22677 if ( mp->cur_sym==0 ) {
22678 @<Show a numeric or string or capsule token@>;
22680 mp_print_text(mp->cur_sym); mp_print_char(mp, '=');
22681 if ( eq_type(mp->cur_sym)>=outer_tag ) mp_print(mp, "(outer) ");
22682 mp_print_cmd_mod(mp, mp->cur_cmd,mp->cur_mod);
22683 if ( mp->cur_cmd==defined_macro ) {
22684 mp_print_ln(mp); mp_show_macro(mp, mp->cur_mod,null,100000);
22685 } /* this avoids recursion between |show_macro| and |print_cmd_mod| */
22690 @ @<Show a numeric or string or capsule token@>=
22692 if ( mp->cur_cmd==numeric_token ) {
22693 mp_print_scaled(mp, mp->cur_mod);
22694 } else if ( mp->cur_cmd==capsule_token ) {
22695 mp_print_capsule(mp,mp->cur_mod);
22697 mp_print_char(mp, '"');
22698 mp_print_str(mp, mp->cur_mod); mp_print_char(mp, '"');
22699 delete_str_ref(mp->cur_mod);
22703 @ The following cases of |print_cmd_mod| might arise in connection
22704 with |disp_token|, although they don't necessarily correspond to
22707 @<Cases of |print_cmd_...@>=
22708 case left_delimiter:
22709 case right_delimiter:
22710 if ( c==left_delimiter ) mp_print(mp, "left");
22711 else mp_print(mp, "right");
22712 mp_print(mp, " delimiter that matches ");
22716 if ( m==null ) mp_print(mp, "tag");
22717 else mp_print(mp, "variable");
22719 case defined_macro:
22720 mp_print(mp, "macro:");
22722 case secondary_primary_macro:
22723 case tertiary_secondary_macro:
22724 case expression_tertiary_macro:
22725 mp_print_cmd_mod(mp, macro_def,c);
22726 mp_print(mp, "'d macro:");
22727 mp_print_ln(mp); mp_show_token_list(mp, link(link(m)),null,1000,0);
22730 mp_print(mp, "[repeat the loop]");
22732 case internal_quantity:
22733 mp_print(mp, mp->int_name[m]);
22736 @ @<Declare action procedures for use by |do_statement|@>=
22737 void mp_do_show_token (MP mp) ;
22739 @ @c void mp_do_show_token (MP mp) {
22741 get_t_next; mp_disp_token(mp);
22743 } while (mp->cur_cmd==comma);
22746 @ @<Declare action procedures for use by |do_statement|@>=
22747 void mp_do_show_stats (MP mp) ;
22749 @ @c void mp_do_show_stats (MP mp) {
22750 mp_print_nl(mp, "Memory usage ");
22751 @.Memory usage...@>
22752 mp_print_int(mp, mp->var_used); mp_print_char(mp, '&'); mp_print_int(mp, mp->dyn_used);
22753 mp_print(mp, " ("); mp_print_int(mp, mp->hi_mem_min-mp->lo_mem_max-1);
22754 mp_print(mp, " still untouched)"); mp_print_ln(mp);
22755 mp_print_nl(mp, "String usage ");
22756 mp_print_int(mp, mp->strs_in_use-mp->init_str_use);
22757 mp_print_char(mp, '&'); mp_print_int(mp, mp->pool_in_use-mp->init_pool_ptr);
22758 mp_print(mp, " (");
22759 mp_print_int(mp, mp->max_strings-1-mp->strs_used_up); mp_print_char(mp, '&');
22760 mp_print_int(mp, mp->pool_size-mp->pool_ptr);
22761 mp_print(mp, " now untouched)"); mp_print_ln(mp);
22765 @ Here's a recursive procedure that gives an abbreviated account
22766 of a variable, for use by |do_show_var|.
22768 @<Declare action procedures for use by |do_statement|@>=
22769 void mp_disp_var (MP mp,pointer p) ;
22771 @ @c void mp_disp_var (MP mp,pointer p) {
22772 pointer q; /* traverses attributes and subscripts */
22773 int n; /* amount of macro text to show */
22774 if ( type(p)==mp_structured ) {
22775 @<Descend the structure@>;
22776 } else if ( type(p)>=mp_unsuffixed_macro ) {
22777 @<Display a variable macro@>;
22778 } else if ( type(p)!=undefined ){
22779 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22780 mp_print_char(mp, '=');
22781 mp_print_exp(mp, p,0);
22785 @ @<Descend the structure@>=
22788 do { mp_disp_var(mp, q); q=link(q); } while (q!=end_attr);
22790 while ( name_type(q)==mp_subscr ) {
22791 mp_disp_var(mp, q); q=link(q);
22795 @ @<Display a variable macro@>=
22797 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22798 if ( type(p)>mp_unsuffixed_macro )
22799 mp_print(mp, "@@#"); /* |suffixed_macro| */
22800 mp_print(mp, "=macro:");
22801 if ( (int)mp->file_offset>=mp->max_print_line-20 ) n=5;
22802 else n=mp->max_print_line-mp->file_offset-15;
22803 mp_show_macro(mp, value(p),null,n);
22806 @ @<Declare action procedures for use by |do_statement|@>=
22807 void mp_do_show_var (MP mp) ;
22809 @ @c void mp_do_show_var (MP mp) {
22812 if ( mp->cur_sym>0 ) if ( mp->cur_sym<=hash_end )
22813 if ( mp->cur_cmd==tag_token ) if ( mp->cur_mod!=null ) {
22814 mp_disp_var(mp, mp->cur_mod); goto DONE;
22819 } while (mp->cur_cmd==comma);
22822 @ @<Declare action procedures for use by |do_statement|@>=
22823 void mp_do_show_dependencies (MP mp) ;
22825 @ @c void mp_do_show_dependencies (MP mp) {
22826 pointer p; /* link that runs through all dependencies */
22828 while ( p!=dep_head ) {
22829 if ( mp_interesting(mp, p) ) {
22830 mp_print_nl(mp, ""); mp_print_variable_name(mp, p);
22831 if ( type(p)==mp_dependent ) mp_print_char(mp, '=');
22832 else mp_print(mp, " = "); /* extra spaces imply proto-dependency */
22833 mp_print_dependency(mp, dep_list(p),type(p));
22836 while ( info(p)!=null ) p=link(p);
22842 @ Finally we are ready for the procedure that governs all of the
22845 @<Declare action procedures for use by |do_statement|@>=
22846 void mp_do_show_whatever (MP mp) ;
22848 @ @c void mp_do_show_whatever (MP mp) {
22849 if ( mp->interaction==mp_error_stop_mode ) wake_up_terminal;
22850 switch (mp->cur_mod) {
22851 case show_token_code:mp_do_show_token(mp); break;
22852 case show_stats_code:mp_do_show_stats(mp); break;
22853 case show_code:mp_do_show(mp); break;
22854 case show_var_code:mp_do_show_var(mp); break;
22855 case show_dependencies_code:mp_do_show_dependencies(mp); break;
22856 } /* there are no other cases */
22857 if ( mp->internal[mp_showstopping]>0 ){
22860 if ( mp->interaction<mp_error_stop_mode ) {
22861 help0; decr(mp->error_count);
22863 help1("This isn't an error message; I'm just showing something.");
22865 if ( mp->cur_cmd==semicolon ) mp_error(mp);
22866 else mp_put_get_error(mp);
22870 @ The `\&{addto}' command needs the following additional primitives:
22872 @d double_path_code 0 /* command modifier for `\&{doublepath}' */
22873 @d contour_code 1 /* command modifier for `\&{contour}' */
22874 @d also_code 2 /* command modifier for `\&{also}' */
22876 @ Pre and postscripts need two new identifiers:
22878 @d with_pre_script 11
22879 @d with_post_script 13
22882 mp_primitive(mp, "doublepath",thing_to_add,double_path_code);
22883 @:double_path_}{\&{doublepath} primitive@>
22884 mp_primitive(mp, "contour",thing_to_add,contour_code);
22885 @:contour_}{\&{contour} primitive@>
22886 mp_primitive(mp, "also",thing_to_add,also_code);
22887 @:also_}{\&{also} primitive@>
22888 mp_primitive(mp, "withpen",with_option,mp_pen_type);
22889 @:with_pen_}{\&{withpen} primitive@>
22890 mp_primitive(mp, "dashed",with_option,mp_picture_type);
22891 @:dashed_}{\&{dashed} primitive@>
22892 mp_primitive(mp, "withprescript",with_option,with_pre_script);
22893 @:with_pre_script_}{\&{withprescript} primitive@>
22894 mp_primitive(mp, "withpostscript",with_option,with_post_script);
22895 @:with_post_script_}{\&{withpostscript} primitive@>
22896 mp_primitive(mp, "withoutcolor",with_option,mp_no_model);
22897 @:with_color_}{\&{withoutcolor} primitive@>
22898 mp_primitive(mp, "withgreyscale",with_option,mp_grey_model);
22899 @:with_color_}{\&{withgreyscale} primitive@>
22900 mp_primitive(mp, "withcolor",with_option,mp_uninitialized_model);
22901 @:with_color_}{\&{withcolor} primitive@>
22902 /* \&{withrgbcolor} is an alias for \&{withcolor} */
22903 mp_primitive(mp, "withrgbcolor",with_option,mp_rgb_model);
22904 @:with_color_}{\&{withrgbcolor} primitive@>
22905 mp_primitive(mp, "withcmykcolor",with_option,mp_cmyk_model);
22906 @:with_color_}{\&{withcmykcolor} primitive@>
22908 @ @<Cases of |print_cmd...@>=
22910 if ( m==contour_code ) mp_print(mp, "contour");
22911 else if ( m==double_path_code ) mp_print(mp, "doublepath");
22912 else mp_print(mp, "also");
22915 if ( m==mp_pen_type ) mp_print(mp, "withpen");
22916 else if ( m==with_pre_script ) mp_print(mp, "withprescript");
22917 else if ( m==with_post_script ) mp_print(mp, "withpostscript");
22918 else if ( m==mp_no_model ) mp_print(mp, "withoutcolor");
22919 else if ( m==mp_rgb_model ) mp_print(mp, "withrgbcolor");
22920 else if ( m==mp_uninitialized_model ) mp_print(mp, "withcolor");
22921 else if ( m==mp_cmyk_model ) mp_print(mp, "withcmykcolor");
22922 else if ( m==mp_grey_model ) mp_print(mp, "withgreyscale");
22923 else mp_print(mp, "dashed");
22926 @ The |scan_with_list| procedure parses a $\langle$with list$\rangle$ and
22927 updates the list of graphical objects starting at |p|. Each $\langle$with
22928 clause$\rangle$ updates all graphical objects whose |type| is compatible.
22929 Other objects are ignored.
22931 @<Declare action procedures for use by |do_statement|@>=
22932 void mp_scan_with_list (MP mp,pointer p) ;
22934 @ @c void mp_scan_with_list (MP mp,pointer p) {
22935 small_number t; /* |cur_mod| of the |with_option| (should match |cur_type|) */
22936 pointer q; /* for list manipulation */
22937 int old_setting; /* saved |selector| setting */
22938 pointer k; /* for finding the near-last item in a list */
22939 str_number s; /* for string cleanup after combining */
22940 pointer cp,pp,dp,ap,bp;
22941 /* objects being updated; |void| initially; |null| to suppress update */
22942 cp=mp_void; pp=mp_void; dp=mp_void; ap=mp_void; bp=mp_void;
22944 while ( mp->cur_cmd==with_option ){
22947 if ( t!=mp_no_model ) mp_scan_expression(mp);
22948 if (((t==with_pre_script)&&(mp->cur_type!=mp_string_type))||
22949 ((t==with_post_script)&&(mp->cur_type!=mp_string_type))||
22950 ((t==mp_uninitialized_model)&&
22951 ((mp->cur_type!=mp_cmykcolor_type)&&(mp->cur_type!=mp_color_type)
22952 &&(mp->cur_type!=mp_known)&&(mp->cur_type!=mp_boolean_type)))||
22953 ((t==mp_cmyk_model)&&(mp->cur_type!=mp_cmykcolor_type))||
22954 ((t==mp_rgb_model)&&(mp->cur_type!=mp_color_type))||
22955 ((t==mp_grey_model)&&(mp->cur_type!=mp_known))||
22956 ((t==mp_pen_type)&&(mp->cur_type!=t))||
22957 ((t==mp_picture_type)&&(mp->cur_type!=t)) ) {
22958 @<Complain about improper type@>;
22959 } else if ( t==mp_uninitialized_model ) {
22960 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22962 @<Transfer a color from the current expression to object~|cp|@>;
22963 mp_flush_cur_exp(mp, 0);
22964 } else if ( t==mp_rgb_model ) {
22965 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22967 @<Transfer a rgbcolor from the current expression to object~|cp|@>;
22968 mp_flush_cur_exp(mp, 0);
22969 } else if ( t==mp_cmyk_model ) {
22970 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22972 @<Transfer a cmykcolor from the current expression to object~|cp|@>;
22973 mp_flush_cur_exp(mp, 0);
22974 } else if ( t==mp_grey_model ) {
22975 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22977 @<Transfer a greyscale from the current expression to object~|cp|@>;
22978 mp_flush_cur_exp(mp, 0);
22979 } else if ( t==mp_no_model ) {
22980 if ( cp==mp_void ) @<Make |cp| a colored object in object list~|p|@>;
22982 @<Transfer a noncolor from the current expression to object~|cp|@>;
22983 } else if ( t==mp_pen_type ) {
22984 if ( pp==mp_void ) @<Make |pp| an object in list~|p| that needs a pen@>;
22986 if ( pen_p(pp)!=null ) mp_toss_knot_list(mp, pen_p(pp));
22987 pen_p(pp)=mp->cur_exp; mp->cur_type=mp_vacuous;
22989 } else if ( t==with_pre_script ) {
22992 while ( (ap!=null)&&(! has_color(ap)) )
22995 if ( pre_script(ap)!=null ) { /* build a new,combined string */
22997 old_setting=mp->selector;
22998 mp->selector=new_string;
22999 str_room(length(pre_script(ap))+length(mp->cur_exp)+2);
23000 mp_print_str(mp, mp->cur_exp);
23001 append_char(13); /* a forced \ps\ newline */
23002 mp_print_str(mp, pre_script(ap));
23003 pre_script(ap)=mp_make_string(mp);
23005 mp->selector=old_setting;
23007 pre_script(ap)=mp->cur_exp;
23009 mp->cur_type=mp_vacuous;
23011 } else if ( t==with_post_script ) {
23015 while ( link(k)!=null ) {
23017 if ( has_color(k) ) bp=k;
23020 if ( post_script(bp)!=null ) {
23022 old_setting=mp->selector;
23023 mp->selector=new_string;
23024 str_room(length(post_script(bp))+length(mp->cur_exp)+2);
23025 mp_print_str(mp, post_script(bp));
23026 append_char(13); /* a forced \ps\ newline */
23027 mp_print_str(mp, mp->cur_exp);
23028 post_script(bp)=mp_make_string(mp);
23030 mp->selector=old_setting;
23032 post_script(bp)=mp->cur_exp;
23034 mp->cur_type=mp_vacuous;
23037 if ( dp==mp_void ) {
23038 @<Make |dp| a stroked node in list~|p|@>;
23041 if ( dash_p(dp)!=null ) delete_edge_ref(dash_p(dp));
23042 dash_p(dp)=mp_make_dashes(mp, mp->cur_exp);
23043 dash_scale(dp)=unity;
23044 mp->cur_type=mp_vacuous;
23048 @<Copy the information from objects |cp|, |pp|, and |dp| into the rest
23052 @ @<Complain about improper type@>=
23053 { exp_err("Improper type");
23055 help2("Next time say `withpen <known pen expression>';")
23056 ("I'll ignore the bad `with' clause and look for another.");
23057 if ( t==with_pre_script )
23058 mp->help_line[1]="Next time say `withprescript <known string expression>';";
23059 else if ( t==with_post_script )
23060 mp->help_line[1]="Next time say `withpostscript <known string expression>';";
23061 else if ( t==mp_picture_type )
23062 mp->help_line[1]="Next time say `dashed <known picture expression>';";
23063 else if ( t==mp_uninitialized_model )
23064 mp->help_line[1]="Next time say `withcolor <known color expression>';";
23065 else if ( t==mp_rgb_model )
23066 mp->help_line[1]="Next time say `withrgbcolor <known color expression>';";
23067 else if ( t==mp_cmyk_model )
23068 mp->help_line[1]="Next time say `withcmykcolor <known cmykcolor expression>';";
23069 else if ( t==mp_grey_model )
23070 mp->help_line[1]="Next time say `withgreyscale <known numeric expression>';";;
23071 mp_put_get_flush_error(mp, 0);
23074 @ Forcing the color to be between |0| and |unity| here guarantees that no
23075 picture will ever contain a color outside the legal range for \ps\ graphics.
23077 @<Transfer a color from the current expression to object~|cp|@>=
23078 { if ( mp->cur_type==mp_color_type )
23079 @<Transfer a rgbcolor from the current expression to object~|cp|@>
23080 else if ( mp->cur_type==mp_cmykcolor_type )
23081 @<Transfer a cmykcolor from the current expression to object~|cp|@>
23082 else if ( mp->cur_type==mp_known )
23083 @<Transfer a greyscale from the current expression to object~|cp|@>
23084 else if ( mp->cur_exp==false_code )
23085 @<Transfer a noncolor from the current expression to object~|cp|@>;
23088 @ @<Transfer a rgbcolor from the current expression to object~|cp|@>=
23089 { q=value(mp->cur_exp);
23094 red_val(cp)=value(red_part_loc(q));
23095 green_val(cp)=value(green_part_loc(q));
23096 blue_val(cp)=value(blue_part_loc(q));
23097 color_model(cp)=mp_rgb_model;
23098 if ( red_val(cp)<0 ) red_val(cp)=0;
23099 if ( green_val(cp)<0 ) green_val(cp)=0;
23100 if ( blue_val(cp)<0 ) blue_val(cp)=0;
23101 if ( red_val(cp)>unity ) red_val(cp)=unity;
23102 if ( green_val(cp)>unity ) green_val(cp)=unity;
23103 if ( blue_val(cp)>unity ) blue_val(cp)=unity;
23106 @ @<Transfer a cmykcolor from the current expression to object~|cp|@>=
23107 { q=value(mp->cur_exp);
23108 cyan_val(cp)=value(cyan_part_loc(q));
23109 magenta_val(cp)=value(magenta_part_loc(q));
23110 yellow_val(cp)=value(yellow_part_loc(q));
23111 black_val(cp)=value(black_part_loc(q));
23112 color_model(cp)=mp_cmyk_model;
23113 if ( cyan_val(cp)<0 ) cyan_val(cp)=0;
23114 if ( magenta_val(cp)<0 ) magenta_val(cp)=0;
23115 if ( yellow_val(cp)<0 ) yellow_val(cp)=0;
23116 if ( black_val(cp)<0 ) black_val(cp)=0;
23117 if ( cyan_val(cp)>unity ) cyan_val(cp)=unity;
23118 if ( magenta_val(cp)>unity ) magenta_val(cp)=unity;
23119 if ( yellow_val(cp)>unity ) yellow_val(cp)=unity;
23120 if ( black_val(cp)>unity ) black_val(cp)=unity;
23123 @ @<Transfer a greyscale from the current expression to object~|cp|@>=
23130 color_model(cp)=mp_grey_model;
23131 if ( grey_val(cp)<0 ) grey_val(cp)=0;
23132 if ( grey_val(cp)>unity ) grey_val(cp)=unity;
23135 @ @<Transfer a noncolor from the current expression to object~|cp|@>=
23142 color_model(cp)=mp_no_model;
23145 @ @<Make |cp| a colored object in object list~|p|@>=
23147 while ( cp!=null ){
23148 if ( has_color(cp) ) break;
23153 @ @<Make |pp| an object in list~|p| that needs a pen@>=
23155 while ( pp!=null ) {
23156 if ( has_pen(pp) ) break;
23161 @ @<Make |dp| a stroked node in list~|p|@>=
23163 while ( dp!=null ) {
23164 if ( type(dp)==mp_stroked_code ) break;
23169 @ @<Copy the information from objects |cp|, |pp|, and |dp| into...@>=
23170 @<Copy |cp|'s color into the colored objects linked to~|cp|@>;
23171 if ( pp>mp_void ) {
23172 @<Copy |pen_p(pp)| into stroked and filled nodes linked to |pp|@>;
23174 if ( dp>mp_void ) {
23175 @<Make stroked nodes linked to |dp| refer to |dash_p(dp)|@>;
23179 @ @<Copy |cp|'s color into the colored objects linked to~|cp|@>=
23181 while ( q!=null ) {
23182 if ( has_color(q) ) {
23183 red_val(q)=red_val(cp);
23184 green_val(q)=green_val(cp);
23185 blue_val(q)=blue_val(cp);
23186 black_val(q)=black_val(cp);
23187 color_model(q)=color_model(cp);
23193 @ @<Copy |pen_p(pp)| into stroked and filled nodes linked to |pp|@>=
23195 while ( q!=null ) {
23196 if ( has_pen(q) ) {
23197 if ( pen_p(q)!=null ) mp_toss_knot_list(mp, pen_p(q));
23198 pen_p(q)=copy_pen(pen_p(pp));
23204 @ @<Make stroked nodes linked to |dp| refer to |dash_p(dp)|@>=
23206 while ( q!=null ) {
23207 if ( type(q)==mp_stroked_code ) {
23208 if ( dash_p(q)!=null ) delete_edge_ref(dash_p(q));
23209 dash_p(q)=dash_p(dp);
23210 dash_scale(q)=unity;
23211 if ( dash_p(q)!=null ) add_edge_ref(dash_p(q));
23217 @ One of the things we need to do when we've parsed an \&{addto} or
23218 similar command is find the header of a supposed \&{picture} variable, given
23219 a token list for that variable. Since the edge structure is about to be
23220 updated, we use |private_edges| to make sure that this is possible.
23222 @<Declare action procedures for use by |do_statement|@>=
23223 pointer mp_find_edges_var (MP mp, pointer t) ;
23225 @ @c pointer mp_find_edges_var (MP mp, pointer t) {
23227 pointer cur_edges; /* the return value */
23228 p=mp_find_variable(mp, t); cur_edges=null;
23230 mp_obliterated(mp, t); mp_put_get_error(mp);
23231 } else if ( type(p)!=mp_picture_type ) {
23232 print_err("Variable "); mp_show_token_list(mp, t,null,1000,0);
23233 @.Variable x is the wrong type@>
23234 mp_print(mp, " is the wrong type (");
23235 mp_print_type(mp, type(p)); mp_print_char(mp, ')');
23236 help2("I was looking for a \"known\" picture variable.")
23237 ("So I'll not change anything just now.");
23238 mp_put_get_error(mp);
23240 value(p)=mp_private_edges(mp, value(p));
23241 cur_edges=value(p);
23243 mp_flush_node_list(mp, t);
23247 @ @<Cases of |do_statement|...@>=
23248 case add_to_command: mp_do_add_to(mp); break;
23249 case bounds_command:mp_do_bounds(mp); break;
23252 mp_primitive(mp, "clip",bounds_command,mp_start_clip_code);
23253 @:clip_}{\&{clip} primitive@>
23254 mp_primitive(mp, "setbounds",bounds_command,mp_start_bounds_code);
23255 @:set_bounds_}{\&{setbounds} primitive@>
23257 @ @<Cases of |print_cmd...@>=
23258 case bounds_command:
23259 if ( m==mp_start_clip_code ) mp_print(mp, "clip");
23260 else mp_print(mp, "setbounds");
23263 @ The following function parses the beginning of an \&{addto} or \&{clip}
23264 command: it expects a variable name followed by a token with |cur_cmd=sep|
23265 and then an expression. The function returns the token list for the variable
23266 and stores the command modifier for the separator token in the global variable
23267 |last_add_type|. We must be careful because this variable might get overwritten
23268 any time we call |get_x_next|.
23271 quarterword last_add_type;
23272 /* command modifier that identifies the last \&{addto} command */
23274 @ @<Declare action procedures for use by |do_statement|@>=
23275 pointer mp_start_draw_cmd (MP mp,quarterword sep) ;
23277 @ @c pointer mp_start_draw_cmd (MP mp,quarterword sep) {
23278 pointer lhv; /* variable to add to left */
23279 quarterword add_type=0; /* value to be returned in |last_add_type| */
23281 mp_get_x_next(mp); mp->var_flag=sep; mp_scan_primary(mp);
23282 if ( mp->cur_type!=mp_token_list ) {
23283 @<Abandon edges command because there's no variable@>;
23285 lhv=mp->cur_exp; add_type=mp->cur_mod;
23286 mp->cur_type=mp_vacuous; mp_get_x_next(mp); mp_scan_expression(mp);
23288 mp->last_add_type=add_type;
23292 @ @<Abandon edges command because there's no variable@>=
23293 { exp_err("Not a suitable variable");
23294 @.Not a suitable variable@>
23295 help4("At this point I needed to see the name of a picture variable.")
23296 ("(Or perhaps you have indeed presented me with one; I might")
23297 ("have missed it, if it wasn't followed by the proper token.)")
23298 ("So I'll not change anything just now.");
23299 mp_put_get_flush_error(mp, 0);
23302 @ Here is an example of how to use |start_draw_cmd|.
23304 @<Declare action procedures for use by |do_statement|@>=
23305 void mp_do_bounds (MP mp) ;
23307 @ @c void mp_do_bounds (MP mp) {
23308 pointer lhv,lhe; /* variable on left, the corresponding edge structure */
23309 pointer p; /* for list manipulation */
23310 integer m; /* initial value of |cur_mod| */
23312 lhv=mp_start_draw_cmd(mp, to_token);
23314 lhe=mp_find_edges_var(mp, lhv);
23316 mp_flush_cur_exp(mp, 0);
23317 } else if ( mp->cur_type!=mp_path_type ) {
23318 exp_err("Improper `clip'");
23319 @.Improper `addto'@>
23320 help2("This expression should have specified a known path.")
23321 ("So I'll not change anything just now.");
23322 mp_put_get_flush_error(mp, 0);
23323 } else if ( left_type(mp->cur_exp)==mp_endpoint ) {
23324 @<Complain about a non-cycle@>;
23326 @<Make |cur_exp| into a \&{setbounds} or clipping path and add it to |lhe|@>;
23331 @ @<Complain about a non-cycle@>=
23332 { print_err("Not a cycle");
23334 help2("That contour should have ended with `..cycle' or `&cycle'.")
23335 ("So I'll not change anything just now."); mp_put_get_error(mp);
23338 @ @<Make |cur_exp| into a \&{setbounds} or clipping path and add...@>=
23339 { p=mp_new_bounds_node(mp, mp->cur_exp,m);
23340 link(p)=link(dummy_loc(lhe));
23341 link(dummy_loc(lhe))=p;
23342 if ( obj_tail(lhe)==dummy_loc(lhe) ) obj_tail(lhe)=p;
23343 p=mp_get_node(mp, mp->gr_object_size[stop_type(m)]);
23344 type(p)=stop_type(m);
23345 link(obj_tail(lhe))=p;
23347 mp_init_bbox(mp, lhe);
23350 @ The |do_add_to| procedure is a little like |do_clip| but there are a lot more
23351 cases to deal with.
23353 @<Declare action procedures for use by |do_statement|@>=
23354 void mp_do_add_to (MP mp) ;
23356 @ @c void mp_do_add_to (MP mp) {
23357 pointer lhv,lhe; /* variable on left, the corresponding edge structure */
23358 pointer p; /* the graphical object or list for |scan_with_list| to update */
23359 pointer e; /* an edge structure to be merged */
23360 quarterword add_type; /* |also_code|, |contour_code|, or |double_path_code| */
23361 lhv=mp_start_draw_cmd(mp, thing_to_add); add_type=mp->last_add_type;
23363 if ( add_type==also_code ) {
23364 @<Make sure the current expression is a suitable picture and set |e| and |p|
23367 @<Create a graphical object |p| based on |add_type| and the current
23370 mp_scan_with_list(mp, p);
23371 @<Use |p|, |e|, and |add_type| to augment |lhv| as requested@>;
23375 @ Setting |p:=null| causes the $\langle$with list$\rangle$ to be ignored;
23376 setting |e:=null| prevents anything from being added to |lhe|.
23378 @ @<Make sure the current expression is a suitable picture and set |e|...@>=
23381 if ( mp->cur_type!=mp_picture_type ) {
23382 exp_err("Improper `addto'");
23383 @.Improper `addto'@>
23384 help2("This expression should have specified a known picture.")
23385 ("So I'll not change anything just now."); mp_put_get_flush_error(mp, 0);
23387 e=mp_private_edges(mp, mp->cur_exp); mp->cur_type=mp_vacuous;
23388 p=link(dummy_loc(e));
23392 @ In this case |add_type<>also_code| so setting |p:=null| suppresses future
23393 attempts to add to the edge structure.
23395 @<Create a graphical object |p| based on |add_type| and the current...@>=
23397 if ( mp->cur_type==mp_pair_type ) mp_pair_to_path(mp);
23398 if ( mp->cur_type!=mp_path_type ) {
23399 exp_err("Improper `addto'");
23400 @.Improper `addto'@>
23401 help2("This expression should have specified a known path.")
23402 ("So I'll not change anything just now.");
23403 mp_put_get_flush_error(mp, 0);
23404 } else if ( add_type==contour_code ) {
23405 if ( left_type(mp->cur_exp)==mp_endpoint ) {
23406 @<Complain about a non-cycle@>;
23408 p=mp_new_fill_node(mp, mp->cur_exp);
23409 mp->cur_type=mp_vacuous;
23412 p=mp_new_stroked_node(mp, mp->cur_exp);
23413 mp->cur_type=mp_vacuous;
23417 @ @<Use |p|, |e|, and |add_type| to augment |lhv| as requested@>=
23418 lhe=mp_find_edges_var(mp, lhv);
23420 if ( (e==null)&&(p!=null) ) e=mp_toss_gr_object(mp, p);
23421 if ( e!=null ) delete_edge_ref(e);
23422 } else if ( add_type==also_code ) {
23424 @<Merge |e| into |lhe| and delete |e|@>;
23428 } else if ( p!=null ) {
23429 link(obj_tail(lhe))=p;
23431 if ( add_type==double_path_code )
23432 if ( pen_p(p)==null )
23433 pen_p(p)=mp_get_pen_circle(mp, 0);
23436 @ @<Merge |e| into |lhe| and delete |e|@>=
23437 { if ( link(dummy_loc(e))!=null ) {
23438 link(obj_tail(lhe))=link(dummy_loc(e));
23439 obj_tail(lhe)=obj_tail(e);
23440 obj_tail(e)=dummy_loc(e);
23441 link(dummy_loc(e))=null;
23442 mp_flush_dash_list(mp, lhe);
23444 mp_toss_edges(mp, e);
23447 @ @<Cases of |do_statement|...@>=
23448 case ship_out_command: mp_do_ship_out(mp); break;
23450 @ @<Declare action procedures for use by |do_statement|@>=
23451 @<Declare the function called |tfm_check|@>
23452 @<Declare the \ps\ output procedures@>
23453 void mp_do_ship_out (MP mp) ;
23455 @ @c void mp_do_ship_out (MP mp) {
23456 integer c; /* the character code */
23457 mp_get_x_next(mp); mp_scan_expression(mp);
23458 if ( mp->cur_type!=mp_picture_type ) {
23459 @<Complain that it's not a known picture@>;
23461 c=mp_round_unscaled(mp, mp->internal[mp_char_code]) % 256;
23462 if ( c<0 ) c=c+256;
23463 @<Store the width information for character code~|c|@>;
23464 mp_ship_out(mp, mp->cur_exp);
23465 mp_flush_cur_exp(mp, 0);
23469 @ @<Complain that it's not a known picture@>=
23471 exp_err("Not a known picture");
23472 help1("I can only output known pictures.");
23473 mp_put_get_flush_error(mp, 0);
23476 @ The \&{everyjob} command simply assigns a nonzero value to the global variable
23479 @<Cases of |do_statement|...@>=
23480 case every_job_command:
23481 mp_get_symbol(mp); mp->start_sym=mp->cur_sym; mp_get_x_next(mp);
23485 halfword start_sym; /* a symbolic token to insert at beginning of job */
23490 @ Finally, we have only the ``message'' commands remaining.
23493 @d err_message_code 1
23495 @d filename_template_code 3
23496 @d print_with_leading_zeroes(A) g = mp->pool_ptr;
23497 mp_print_int(mp, (A)); g = mp->pool_ptr-g;
23499 mp->pool_ptr = mp->pool_ptr - g;
23501 mp_print_char(mp, '0');
23504 mp_print_int(mp, (A));
23509 mp_primitive(mp, "message",message_command,message_code);
23510 @:message_}{\&{message} primitive@>
23511 mp_primitive(mp, "errmessage",message_command,err_message_code);
23512 @:err_message_}{\&{errmessage} primitive@>
23513 mp_primitive(mp, "errhelp",message_command,err_help_code);
23514 @:err_help_}{\&{errhelp} primitive@>
23515 mp_primitive(mp, "filenametemplate",message_command,filename_template_code);
23516 @:filename_template_}{\&{filenametemplate} primitive@>
23518 @ @<Cases of |print_cmd...@>=
23519 case message_command:
23520 if ( m<err_message_code ) mp_print(mp, "message");
23521 else if ( m==err_message_code ) mp_print(mp, "errmessage");
23522 else if ( m==filename_template_code ) mp_print(mp, "filenametemplate");
23523 else mp_print(mp, "errhelp");
23526 @ @<Cases of |do_statement|...@>=
23527 case message_command: mp_do_message(mp); break;
23529 @ @<Declare action procedures for use by |do_statement|@>=
23530 @<Declare a procedure called |no_string_err|@>
23531 void mp_do_message (MP mp) ;
23534 @c void mp_do_message (MP mp) {
23535 int m; /* the type of message */
23536 m=mp->cur_mod; mp_get_x_next(mp); mp_scan_expression(mp);
23537 if ( mp->cur_type!=mp_string_type )
23538 mp_no_string_err(mp, "A message should be a known string expression.");
23542 mp_print_nl(mp, ""); mp_print_str(mp, mp->cur_exp);
23544 case err_message_code:
23545 @<Print string |cur_exp| as an error message@>;
23547 case err_help_code:
23548 @<Save string |cur_exp| as the |err_help|@>;
23550 case filename_template_code:
23551 @<Save the filename template@>;
23553 } /* there are no other cases */
23555 mp_flush_cur_exp(mp, 0);
23558 @ @<Declare a procedure called |no_string_err|@>=
23559 void mp_no_string_err (MP mp, const char *s) {
23560 exp_err("Not a string");
23563 mp_put_get_error(mp);
23566 @ The global variable |err_help| is zero when the user has most recently
23567 given an empty help string, or if none has ever been given.
23569 @<Save string |cur_exp| as the |err_help|@>=
23571 if ( mp->err_help!=0 ) delete_str_ref(mp->err_help);
23572 if ( length(mp->cur_exp)==0 ) mp->err_help=0;
23573 else { mp->err_help=mp->cur_exp; add_str_ref(mp->err_help); }
23576 @ If \&{errmessage} occurs often in |mp_scroll_mode|, without user-defined
23577 \&{errhelp}, we don't want to give a long help message each time. So we
23578 give a verbose explanation only once.
23581 boolean long_help_seen; /* has the long \.{\\errmessage} help been used? */
23583 @ @<Set init...@>=mp->long_help_seen=false;
23585 @ @<Print string |cur_exp| as an error message@>=
23587 print_err(""); mp_print_str(mp, mp->cur_exp);
23588 if ( mp->err_help!=0 ) {
23589 mp->use_err_help=true;
23590 } else if ( mp->long_help_seen ) {
23591 help1("(That was another `errmessage'.)") ;
23593 if ( mp->interaction<mp_error_stop_mode ) mp->long_help_seen=true;
23594 help4("This error message was generated by an `errmessage'")
23595 ("command, so I can\'t give any explicit help.")
23596 ("Pretend that you're Miss Marple: Examine all clues,")
23598 ("and deduce the truth by inspired guesses.");
23600 mp_put_get_error(mp); mp->use_err_help=false;
23603 @ @<Cases of |do_statement|...@>=
23604 case write_command: mp_do_write(mp); break;
23606 @ @<Declare action procedures for use by |do_statement|@>=
23607 void mp_do_write (MP mp) ;
23609 @ @c void mp_do_write (MP mp) {
23610 str_number t; /* the line of text to be written */
23611 write_index n,n0; /* for searching |wr_fname| and |wr_file| arrays */
23612 int old_setting; /* for saving |selector| during output */
23614 mp_scan_expression(mp);
23615 if ( mp->cur_type!=mp_string_type ) {
23616 mp_no_string_err(mp, "The text to be written should be a known string expression");
23617 } else if ( mp->cur_cmd!=to_token ) {
23618 print_err("Missing `to' clause");
23619 help1("A write command should end with `to <filename>'");
23620 mp_put_get_error(mp);
23622 t=mp->cur_exp; mp->cur_type=mp_vacuous;
23624 mp_scan_expression(mp);
23625 if ( mp->cur_type!=mp_string_type )
23626 mp_no_string_err(mp, "I can\'t write to that file name. It isn't a known string");
23628 @<Write |t| to the file named by |cur_exp|@>;
23632 mp_flush_cur_exp(mp, 0);
23635 @ @<Write |t| to the file named by |cur_exp|@>=
23637 @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if
23638 |cur_exp| must be inserted@>;
23639 if ( mp_str_vs_str(mp, t,mp->eof_line)==0 ) {
23640 @<Record the end of file on |wr_file[n]|@>;
23642 old_setting=mp->selector;
23643 mp->selector=n+write_file;
23644 mp_print_str(mp, t); mp_print_ln(mp);
23645 mp->selector = old_setting;
23649 @ @<Find |n| where |wr_fname[n]=cur_exp| and call |open_write_file| if...@>=
23651 char *fn = str(mp->cur_exp);
23653 n0=mp->write_files;
23654 while (mp_xstrcmp(fn,mp->wr_fname[n])!=0) {
23655 if ( n==0 ) { /* bottom reached */
23656 if ( n0==mp->write_files ) {
23657 if ( mp->write_files<mp->max_write_files ) {
23658 incr(mp->write_files);
23663 l = mp->max_write_files + (mp->max_write_files>>2);
23664 wr_file = xmalloc((l+1),sizeof(void *));
23665 wr_fname = xmalloc((l+1),sizeof(char *));
23666 for (k=0;k<=l;k++) {
23667 if (k<=mp->max_write_files) {
23668 wr_file[k]=mp->wr_file[k];
23669 wr_fname[k]=mp->wr_fname[k];
23675 xfree(mp->wr_file); xfree(mp->wr_fname);
23676 mp->max_write_files = l;
23677 mp->wr_file = wr_file;
23678 mp->wr_fname = wr_fname;
23682 mp_open_write_file(mp, fn ,n);
23685 if ( mp->wr_fname[n]==NULL ) n0=n;
23690 @ @<Record the end of file on |wr_file[n]|@>=
23691 { (mp->close_file)(mp,mp->wr_file[n]);
23692 xfree(mp->wr_fname[n]);
23693 if ( n==mp->write_files-1 ) mp->write_files=n;
23697 @* \[42] Writing font metric data.
23698 \TeX\ gets its knowledge about fonts from font metric files, also called
23699 \.{TFM} files; the `\.T' in `\.{TFM}' stands for \TeX,
23700 but other programs know about them too. One of \MP's duties is to
23701 write \.{TFM} files so that the user's fonts can readily be
23702 applied to typesetting.
23703 @:TFM files}{\.{TFM} files@>
23704 @^font metric files@>
23706 The information in a \.{TFM} file appears in a sequence of 8-bit bytes.
23707 Since the number of bytes is always a multiple of~4, we could
23708 also regard the file as a sequence of 32-bit words, but \MP\ uses the
23709 byte interpretation. The format of \.{TFM} files was designed by
23710 Lyle Ramshaw in 1980. The intent is to convey a lot of different kinds
23711 @^Ramshaw, Lyle Harold@>
23712 of information in a compact but useful form.
23715 void * tfm_file; /* the font metric output goes here */
23716 char * metric_file_name; /* full name of the font metric file */
23718 @ The first 24 bytes (6 words) of a \.{TFM} file contain twelve 16-bit
23719 integers that give the lengths of the various subsequent portions
23720 of the file. These twelve integers are, in order:
23721 $$\vbox{\halign{\hfil#&$\null=\null$#\hfil\cr
23722 |lf|&length of the entire file, in words;\cr
23723 |lh|&length of the header data, in words;\cr
23724 |bc|&smallest character code in the font;\cr
23725 |ec|&largest character code in the font;\cr
23726 |nw|&number of words in the width table;\cr
23727 |nh|&number of words in the height table;\cr
23728 |nd|&number of words in the depth table;\cr
23729 |ni|&number of words in the italic correction table;\cr
23730 |nl|&number of words in the lig/kern table;\cr
23731 |nk|&number of words in the kern table;\cr
23732 |ne|&number of words in the extensible character table;\cr
23733 |np|&number of font parameter words.\cr}}$$
23734 They are all nonnegative and less than $2^{15}$. We must have |bc-1<=ec<=255|,
23736 $$\hbox{|lf=6+lh+(ec-bc+1)+nw+nh+nd+ni+nl+nk+ne+np|.}$$
23737 Note that a font may contain as many as 256 characters (if |bc=0| and |ec=255|),
23738 and as few as 0 characters (if |bc=ec+1|).
23740 Incidentally, when two or more 8-bit bytes are combined to form an integer of
23741 16 or more bits, the most significant bytes appear first in the file.
23742 This is called BigEndian order.
23743 @^BigEndian order@>
23745 @ The rest of the \.{TFM} file may be regarded as a sequence of ten data
23748 The most important data type used here is a |fix_word|, which is
23749 a 32-bit representation of a binary fraction. A |fix_word| is a signed
23750 quantity, with the two's complement of the entire word used to represent
23751 negation. Of the 32 bits in a |fix_word|, exactly 12 are to the left of the
23752 binary point; thus, the largest |fix_word| value is $2048-2^{-20}$, and
23753 the smallest is $-2048$. We will see below, however, that all but two of
23754 the |fix_word| values must lie between $-16$ and $+16$.
23756 @ The first data array is a block of header information, which contains
23757 general facts about the font. The header must contain at least two words,
23758 |header[0]| and |header[1]|, whose meaning is explained below. Additional
23759 header information of use to other software routines might also be
23760 included, and \MP\ will generate it if the \.{headerbyte} command occurs.
23761 For example, 16 more words of header information are in use at the Xerox
23762 Palo Alto Research Center; the first ten specify the character coding
23763 scheme used (e.g., `\.{XEROX TEXT}' or `\.{TEX MATHSY}'), the next five
23764 give the font family name (e.g., `\.{HELVETICA}' or `\.{CMSY}'), and the
23765 last gives the ``face byte.''
23767 \yskip\hang|header[0]| is a 32-bit check sum that \MP\ will copy into
23768 the \.{GF} output file. This helps ensure consistency between files,
23769 since \TeX\ records the check sums from the \.{TFM}'s it reads, and these
23770 should match the check sums on actual fonts that are used. The actual
23771 relation between this check sum and the rest of the \.{TFM} file is not
23772 important; the check sum is simply an identification number with the
23773 property that incompatible fonts almost always have distinct check sums.
23776 \yskip\hang|header[1]| is a |fix_word| containing the design size of the
23777 font, in units of \TeX\ points. This number must be at least 1.0; it is
23778 fairly arbitrary, but usually the design size is 10.0 for a ``10 point''
23779 font, i.e., a font that was designed to look best at a 10-point size,
23780 whatever that really means. When a \TeX\ user asks for a font `\.{at}
23781 $\delta$ \.{pt}', the effect is to override the design size and replace it
23782 by $\delta$, and to multiply the $x$ and~$y$ coordinates of the points in
23783 the font image by a factor of $\delta$ divided by the design size. {\sl
23784 All other dimensions in the\/ \.{TFM} file are |fix_word|\kern-1pt\
23785 numbers in design-size units.} Thus, for example, the value of |param[6]|,
23786 which defines the \.{em} unit, is often the |fix_word| value $2^{20}=1.0$,
23787 since many fonts have a design size equal to one em. The other dimensions
23788 must be less than 16 design-size units in absolute value; thus,
23789 |header[1]| and |param[1]| are the only |fix_word| entries in the whole
23790 \.{TFM} file whose first byte might be something besides 0 or 255.
23793 @ Next comes the |char_info| array, which contains one |char_info_word|
23794 per character. Each word in this part of the file contains six fields
23795 packed into four bytes as follows.
23797 \yskip\hang first byte: |width_index| (8 bits)\par
23798 \hang second byte: |height_index| (4 bits) times 16, plus |depth_index|
23800 \hang third byte: |italic_index| (6 bits) times 4, plus |tag|
23802 \hang fourth byte: |remainder| (8 bits)\par
23804 The actual width of a character is \\{width}|[width_index]|, in design-size
23805 units; this is a device for compressing information, since many characters
23806 have the same width. Since it is quite common for many characters
23807 to have the same height, depth, or italic correction, the \.{TFM} format
23808 imposes a limit of 16 different heights, 16 different depths, and
23809 64 different italic corrections.
23811 Incidentally, the relation $\\{width}[0]=\\{height}[0]=\\{depth}[0]=
23812 \\{italic}[0]=0$ should always hold, so that an index of zero implies a
23813 value of zero. The |width_index| should never be zero unless the
23814 character does not exist in the font, since a character is valid if and
23815 only if it lies between |bc| and |ec| and has a nonzero |width_index|.
23817 @ The |tag| field in a |char_info_word| has four values that explain how to
23818 interpret the |remainder| field.
23820 \yskip\hang|tag=0| (|no_tag|) means that |remainder| is unused.\par
23821 \hang|tag=1| (|lig_tag|) means that this character has a ligature/kerning
23822 program starting at location |remainder| in the |lig_kern| array.\par
23823 \hang|tag=2| (|list_tag|) means that this character is part of a chain of
23824 characters of ascending sizes, and not the largest in the chain. The
23825 |remainder| field gives the character code of the next larger character.\par
23826 \hang|tag=3| (|ext_tag|) means that this character code represents an
23827 extensible character, i.e., a character that is built up of smaller pieces
23828 so that it can be made arbitrarily large. The pieces are specified in
23829 |exten[remainder]|.\par
23831 Characters with |tag=2| and |tag=3| are treated as characters with |tag=0|
23832 unless they are used in special circumstances in math formulas. For example,
23833 \TeX's \.{\\sum} operation looks for a |list_tag|, and the \.{\\left}
23834 operation looks for both |list_tag| and |ext_tag|.
23836 @d no_tag 0 /* vanilla character */
23837 @d lig_tag 1 /* character has a ligature/kerning program */
23838 @d list_tag 2 /* character has a successor in a charlist */
23839 @d ext_tag 3 /* character is extensible */
23841 @ The |lig_kern| array contains instructions in a simple programming language
23842 that explains what to do for special letter pairs. Each word in this array is a
23843 |lig_kern_command| of four bytes.
23845 \yskip\hang first byte: |skip_byte|, indicates that this is the final program
23846 step if the byte is 128 or more, otherwise the next step is obtained by
23847 skipping this number of intervening steps.\par
23848 \hang second byte: |next_char|, ``if |next_char| follows the current character,
23849 then perform the operation and stop, otherwise continue.''\par
23850 \hang third byte: |op_byte|, indicates a ligature step if less than~128,
23851 a kern step otherwise.\par
23852 \hang fourth byte: |remainder|.\par
23855 additional space equal to |kern[256*(op_byte-128)+remainder]| is inserted
23856 between the current character and |next_char|. This amount is
23857 often negative, so that the characters are brought closer together
23858 by kerning; but it might be positive.
23860 There are eight kinds of ligature steps, having |op_byte| codes $4a+2b+c$ where
23861 $0\le a\le b+c$ and $0\le b,c\le1$. The character whose code is
23862 |remainder| is inserted between the current character and |next_char|;
23863 then the current character is deleted if $b=0$, and |next_char| is
23864 deleted if $c=0$; then we pass over $a$~characters to reach the next
23865 current character (which may have a ligature/kerning program of its own).
23867 If the very first instruction of the |lig_kern| array has |skip_byte=255|,
23868 the |next_char| byte is the so-called right boundary character of this font;
23869 the value of |next_char| need not lie between |bc| and~|ec|.
23870 If the very last instruction of the |lig_kern| array has |skip_byte=255|,
23871 there is a special ligature/kerning program for a left boundary character,
23872 beginning at location |256*op_byte+remainder|.
23873 The interpretation is that \TeX\ puts implicit boundary characters
23874 before and after each consecutive string of characters from the same font.
23875 These implicit characters do not appear in the output, but they can affect
23876 ligatures and kerning.
23878 If the very first instruction of a character's |lig_kern| program has
23879 |skip_byte>128|, the program actually begins in location
23880 |256*op_byte+remainder|. This feature allows access to large |lig_kern|
23881 arrays, because the first instruction must otherwise
23882 appear in a location |<=255|.
23884 Any instruction with |skip_byte>128| in the |lig_kern| array must satisfy
23886 $$\hbox{|256*op_byte+remainder<nl|.}$$
23887 If such an instruction is encountered during
23888 normal program execution, it denotes an unconditional halt; no ligature
23889 command is performed.
23892 /* value indicating `\.{STOP}' in a lig/kern program */
23893 @d kern_flag (128) /* op code for a kern step */
23894 @d skip_byte(A) mp->lig_kern[(A)].b0
23895 @d next_char(A) mp->lig_kern[(A)].b1
23896 @d op_byte(A) mp->lig_kern[(A)].b2
23897 @d rem_byte(A) mp->lig_kern[(A)].b3
23899 @ Extensible characters are specified by an |extensible_recipe|, which
23900 consists of four bytes called |top|, |mid|, |bot|, and |rep| (in this
23901 order). These bytes are the character codes of individual pieces used to
23902 build up a large symbol. If |top|, |mid|, or |bot| are zero, they are not
23903 present in the built-up result. For example, an extensible vertical line is
23904 like an extensible bracket, except that the top and bottom pieces are missing.
23906 Let $T$, $M$, $B$, and $R$ denote the respective pieces, or an empty box
23907 if the piece isn't present. Then the extensible characters have the form
23908 $TR^kMR^kB$ from top to bottom, for some |k>=0|, unless $M$ is absent;
23909 in the latter case we can have $TR^kB$ for both even and odd values of~|k|.
23910 The width of the extensible character is the width of $R$; and the
23911 height-plus-depth is the sum of the individual height-plus-depths of the
23912 components used, since the pieces are butted together in a vertical list.
23914 @d ext_top(A) mp->exten[(A)].b0 /* |top| piece in a recipe */
23915 @d ext_mid(A) mp->exten[(A)].b1 /* |mid| piece in a recipe */
23916 @d ext_bot(A) mp->exten[(A)].b2 /* |bot| piece in a recipe */
23917 @d ext_rep(A) mp->exten[(A)].b3 /* |rep| piece in a recipe */
23919 @ The final portion of a \.{TFM} file is the |param| array, which is another
23920 sequence of |fix_word| values.
23922 \yskip\hang|param[1]=slant| is the amount of italic slant, which is used
23923 to help position accents. For example, |slant=.25| means that when you go
23924 up one unit, you also go .25 units to the right. The |slant| is a pure
23925 number; it is the only |fix_word| other than the design size itself that is
23926 not scaled by the design size.
23929 \hang|param[2]=space| is the normal spacing between words in text.
23930 Note that character 040 in the font need not have anything to do with
23933 \hang|param[3]=space_stretch| is the amount of glue stretching between words.
23935 \hang|param[4]=space_shrink| is the amount of glue shrinking between words.
23937 \hang|param[5]=x_height| is the size of one ex in the font; it is also
23938 the height of letters for which accents don't have to be raised or lowered.
23940 \hang|param[6]=quad| is the size of one em in the font.
23942 \hang|param[7]=extra_space| is the amount added to |param[2]| at the
23946 If fewer than seven parameters are present, \TeX\ sets the missing parameters
23951 @d space_stretch_code 3
23952 @d space_shrink_code 4
23955 @d extra_space_code 7
23957 @ So that is what \.{TFM} files hold. One of \MP's duties is to output such
23958 information, and it does this all at once at the end of a job.
23959 In order to prepare for such frenetic activity, it squirrels away the
23960 necessary facts in various arrays as information becomes available.
23962 Character dimensions (\&{charwd}, \&{charht}, \&{chardp}, and \&{charic})
23963 are stored respectively in |tfm_width|, |tfm_height|, |tfm_depth|, and
23964 |tfm_ital_corr|. Other information about a character (e.g., about
23965 its ligatures or successors) is accessible via the |char_tag| and
23966 |char_remainder| arrays. Other information about the font as a whole
23967 is kept in additional arrays called |header_byte|, |lig_kern|,
23968 |kern|, |exten|, and |param|.
23970 @d max_tfm_int 32510
23971 @d undefined_label max_tfm_int /* an undefined local label */
23974 #define TFM_ITEMS 257
23976 eight_bits ec; /* smallest and largest character codes shipped out */
23977 scaled tfm_width[TFM_ITEMS]; /* \&{charwd} values */
23978 scaled tfm_height[TFM_ITEMS]; /* \&{charht} values */
23979 scaled tfm_depth[TFM_ITEMS]; /* \&{chardp} values */
23980 scaled tfm_ital_corr[TFM_ITEMS]; /* \&{charic} values */
23981 boolean char_exists[TFM_ITEMS]; /* has this code been shipped out? */
23982 int char_tag[TFM_ITEMS]; /* |remainder| category */
23983 int char_remainder[TFM_ITEMS]; /* the |remainder| byte */
23984 char *header_byte; /* bytes of the \.{TFM} header */
23985 int header_last; /* last initialized \.{TFM} header byte */
23986 int header_size; /* size of the \.{TFM} header */
23987 four_quarters *lig_kern; /* the ligature/kern table */
23988 short nl; /* the number of ligature/kern steps so far */
23989 scaled *kern; /* distinct kerning amounts */
23990 short nk; /* the number of distinct kerns so far */
23991 four_quarters exten[TFM_ITEMS]; /* extensible character recipes */
23992 short ne; /* the number of extensible characters so far */
23993 scaled *param; /* \&{fontinfo} parameters */
23994 short np; /* the largest \&{fontinfo} parameter specified so far */
23995 short nw;short nh;short nd;short ni; /* sizes of \.{TFM} subtables */
23996 short skip_table[TFM_ITEMS]; /* local label status */
23997 boolean lk_started; /* has there been a lig/kern step in this command yet? */
23998 integer bchar; /* right boundary character */
23999 short bch_label; /* left boundary starting location */
24000 short ll;short lll; /* registers used for lig/kern processing */
24001 short label_loc[257]; /* lig/kern starting addresses */
24002 eight_bits label_char[257]; /* characters for |label_loc| */
24003 short label_ptr; /* highest position occupied in |label_loc| */
24005 @ @<Allocate or initialize ...@>=
24006 mp->header_size = 128; /* just for init */
24007 mp->header_byte = xmalloc(mp->header_size, sizeof(char));
24009 @ @<Dealloc variables@>=
24010 xfree(mp->header_byte);
24011 xfree(mp->lig_kern);
24016 for (k=0;k<= 255;k++ ) {
24017 mp->tfm_width[k]=0; mp->tfm_height[k]=0; mp->tfm_depth[k]=0; mp->tfm_ital_corr[k]=0;
24018 mp->char_exists[k]=false; mp->char_tag[k]=no_tag; mp->char_remainder[k]=0;
24019 mp->skip_table[k]=undefined_label;
24021 memset(mp->header_byte,0,mp->header_size);
24022 mp->bc=255; mp->ec=0; mp->nl=0; mp->nk=0; mp->ne=0; mp->np=0;
24023 mp->internal[mp_boundary_char]=-unity;
24024 mp->bch_label=undefined_label;
24025 mp->label_loc[0]=-1; mp->label_ptr=0;
24027 @ @<Declarations@>=
24028 scaled mp_tfm_check (MP mp,small_number m) ;
24030 @ @<Declare the function called |tfm_check|@>=
24031 scaled mp_tfm_check (MP mp,small_number m) {
24032 if ( abs(mp->internal[m])>=fraction_half ) {
24033 print_err("Enormous "); mp_print(mp, mp->int_name[m]);
24034 @.Enormous charwd...@>
24035 @.Enormous chardp...@>
24036 @.Enormous charht...@>
24037 @.Enormous charic...@>
24038 @.Enormous designsize...@>
24039 mp_print(mp, " has been reduced");
24040 help1("Font metric dimensions must be less than 2048pt.");
24041 mp_put_get_error(mp);
24042 if ( mp->internal[m]>0 ) return (fraction_half-1);
24043 else return (1-fraction_half);
24045 return mp->internal[m];
24049 @ @<Store the width information for character code~|c|@>=
24050 if ( c<mp->bc ) mp->bc=c;
24051 if ( c>mp->ec ) mp->ec=c;
24052 mp->char_exists[c]=true;
24053 mp->tfm_width[c]=mp_tfm_check(mp,mp_char_wd);
24054 mp->tfm_height[c]=mp_tfm_check(mp, mp_char_ht);
24055 mp->tfm_depth[c]=mp_tfm_check(mp, mp_char_dp);
24056 mp->tfm_ital_corr[c]=mp_tfm_check(mp, mp_char_ic)
24058 @ Now let's consider \MP's special \.{TFM}-oriented commands.
24060 @<Cases of |do_statement|...@>=
24061 case tfm_command: mp_do_tfm_command(mp); break;
24063 @ @d char_list_code 0
24064 @d lig_table_code 1
24065 @d extensible_code 2
24066 @d header_byte_code 3
24067 @d font_dimen_code 4
24070 mp_primitive(mp, "charlist",tfm_command,char_list_code);
24071 @:char_list_}{\&{charlist} primitive@>
24072 mp_primitive(mp, "ligtable",tfm_command,lig_table_code);
24073 @:lig_table_}{\&{ligtable} primitive@>
24074 mp_primitive(mp, "extensible",tfm_command,extensible_code);
24075 @:extensible_}{\&{extensible} primitive@>
24076 mp_primitive(mp, "headerbyte",tfm_command,header_byte_code);
24077 @:header_byte_}{\&{headerbyte} primitive@>
24078 mp_primitive(mp, "fontdimen",tfm_command,font_dimen_code);
24079 @:font_dimen_}{\&{fontdimen} primitive@>
24081 @ @<Cases of |print_cmd...@>=
24084 case char_list_code:mp_print(mp, "charlist"); break;
24085 case lig_table_code:mp_print(mp, "ligtable"); break;
24086 case extensible_code:mp_print(mp, "extensible"); break;
24087 case header_byte_code:mp_print(mp, "headerbyte"); break;
24088 default: mp_print(mp, "fontdimen"); break;
24092 @ @<Declare action procedures for use by |do_statement|@>=
24093 eight_bits mp_get_code (MP mp) ;
24095 @ @c eight_bits mp_get_code (MP mp) { /* scans a character code value */
24096 integer c; /* the code value found */
24097 mp_get_x_next(mp); mp_scan_expression(mp);
24098 if ( mp->cur_type==mp_known ) {
24099 c=mp_round_unscaled(mp, mp->cur_exp);
24100 if ( c>=0 ) if ( c<256 ) return c;
24101 } else if ( mp->cur_type==mp_string_type ) {
24102 if ( length(mp->cur_exp)==1 ) {
24103 c=mp->str_pool[mp->str_start[mp->cur_exp]];
24107 exp_err("Invalid code has been replaced by 0");
24108 @.Invalid code...@>
24109 help2("I was looking for a number between 0 and 255, or for a")
24110 ("string of length 1. Didn't find it; will use 0 instead.");
24111 mp_put_get_flush_error(mp, 0); c=0;
24115 @ @<Declare action procedures for use by |do_statement|@>=
24116 void mp_set_tag (MP mp,halfword c, small_number t, halfword r) ;
24118 @ @c void mp_set_tag (MP mp,halfword c, small_number t, halfword r) {
24119 if ( mp->char_tag[c]==no_tag ) {
24120 mp->char_tag[c]=t; mp->char_remainder[c]=r;
24122 incr(mp->label_ptr); mp->label_loc[mp->label_ptr]=r;
24123 mp->label_char[mp->label_ptr]=c;
24126 @<Complain about a character tag conflict@>;
24130 @ @<Complain about a character tag conflict@>=
24132 print_err("Character ");
24133 if ( (c>' ')&&(c<127) ) mp_print_char(mp,c);
24134 else if ( c==256 ) mp_print(mp, "||");
24135 else { mp_print(mp, "code "); mp_print_int(mp, c); };
24136 mp_print(mp, " is already ");
24137 @.Character c is already...@>
24138 switch (mp->char_tag[c]) {
24139 case lig_tag: mp_print(mp, "in a ligtable"); break;
24140 case list_tag: mp_print(mp, "in a charlist"); break;
24141 case ext_tag: mp_print(mp, "extensible"); break;
24142 } /* there are no other cases */
24143 help2("It's not legal to label a character more than once.")
24144 ("So I'll not change anything just now.");
24145 mp_put_get_error(mp);
24148 @ @<Declare action procedures for use by |do_statement|@>=
24149 void mp_do_tfm_command (MP mp) ;
24151 @ @c void mp_do_tfm_command (MP mp) {
24152 int c,cc; /* character codes */
24153 int k; /* index into the |kern| array */
24154 int j; /* index into |header_byte| or |param| */
24155 switch (mp->cur_mod) {
24156 case char_list_code:
24158 /* we will store a list of character successors */
24159 while ( mp->cur_cmd==colon ) {
24160 cc=mp_get_code(mp); mp_set_tag(mp, c,list_tag,cc); c=cc;
24163 case lig_table_code:
24164 if (mp->lig_kern==NULL)
24165 mp->lig_kern = xmalloc((max_tfm_int+1),sizeof(four_quarters));
24166 if (mp->kern==NULL)
24167 mp->kern = xmalloc((max_tfm_int+1),sizeof(scaled));
24168 @<Store a list of ligature/kern steps@>;
24170 case extensible_code:
24171 @<Define an extensible recipe@>;
24173 case header_byte_code:
24174 case font_dimen_code:
24175 c=mp->cur_mod; mp_get_x_next(mp);
24176 mp_scan_expression(mp);
24177 if ( (mp->cur_type!=mp_known)||(mp->cur_exp<half_unit) ) {
24178 exp_err("Improper location");
24179 @.Improper location@>
24180 help2("I was looking for a known, positive number.")
24181 ("For safety's sake I'll ignore the present command.");
24182 mp_put_get_error(mp);
24184 j=mp_round_unscaled(mp, mp->cur_exp);
24185 if ( mp->cur_cmd!=colon ) {
24186 mp_missing_err(mp, ":");
24188 help1("A colon should follow a headerbyte or fontinfo location.");
24191 if ( c==header_byte_code ) {
24192 @<Store a list of header bytes@>;
24194 if (mp->param==NULL)
24195 mp->param = xmalloc((max_tfm_int+1),sizeof(scaled));
24196 @<Store a list of font dimensions@>;
24200 } /* there are no other cases */
24203 @ @<Store a list of ligature/kern steps@>=
24205 mp->lk_started=false;
24208 if ((mp->cur_cmd==skip_to)&& mp->lk_started )
24209 @<Process a |skip_to| command and |goto done|@>;
24210 if ( mp->cur_cmd==bchar_label ) { c=256; mp->cur_cmd=colon; }
24211 else { mp_back_input(mp); c=mp_get_code(mp); };
24212 if ((mp->cur_cmd==colon)||(mp->cur_cmd==double_colon)) {
24213 @<Record a label in a lig/kern subprogram and |goto continue|@>;
24215 if ( mp->cur_cmd==lig_kern_token ) {
24216 @<Compile a ligature/kern command@>;
24218 print_err("Illegal ligtable step");
24219 @.Illegal ligtable step@>
24220 help1("I was looking for `=:' or `kern' here.");
24221 mp_back_error(mp); next_char(mp->nl)=qi(0);
24222 op_byte(mp->nl)=qi(0); rem_byte(mp->nl)=qi(0);
24223 skip_byte(mp->nl)=stop_flag+1; /* this specifies an unconditional stop */
24225 if ( mp->nl==max_tfm_int) mp_fatal_error(mp, "ligtable too large");
24227 if ( mp->cur_cmd==comma ) goto CONTINUE;
24228 if ( skip_byte(mp->nl-1)<stop_flag ) skip_byte(mp->nl-1)=stop_flag;
24233 mp_primitive(mp, "=:",lig_kern_token,0);
24234 @:=:_}{\.{=:} primitive@>
24235 mp_primitive(mp, "=:|",lig_kern_token,1);
24236 @:=:/_}{\.{=:\char'174} primitive@>
24237 mp_primitive(mp, "=:|>",lig_kern_token,5);
24238 @:=:/>_}{\.{=:\char'174>} primitive@>
24239 mp_primitive(mp, "|=:",lig_kern_token,2);
24240 @:=:/_}{\.{\char'174=:} primitive@>
24241 mp_primitive(mp, "|=:>",lig_kern_token,6);
24242 @:=:/>_}{\.{\char'174=:>} primitive@>
24243 mp_primitive(mp, "|=:|",lig_kern_token,3);
24244 @:=:/_}{\.{\char'174=:\char'174} primitive@>
24245 mp_primitive(mp, "|=:|>",lig_kern_token,7);
24246 @:=:/>_}{\.{\char'174=:\char'174>} primitive@>
24247 mp_primitive(mp, "|=:|>>",lig_kern_token,11);
24248 @:=:/>_}{\.{\char'174=:\char'174>>} primitive@>
24249 mp_primitive(mp, "kern",lig_kern_token,128);
24250 @:kern_}{\&{kern} primitive@>
24252 @ @<Cases of |print_cmd...@>=
24253 case lig_kern_token:
24255 case 0:mp_print(mp, "=:"); break;
24256 case 1:mp_print(mp, "=:|"); break;
24257 case 2:mp_print(mp, "|=:"); break;
24258 case 3:mp_print(mp, "|=:|"); break;
24259 case 5:mp_print(mp, "=:|>"); break;
24260 case 6:mp_print(mp, "|=:>"); break;
24261 case 7:mp_print(mp, "|=:|>"); break;
24262 case 11:mp_print(mp, "|=:|>>"); break;
24263 default: mp_print(mp, "kern"); break;
24267 @ Local labels are implemented by maintaining the |skip_table| array,
24268 where |skip_table[c]| is either |undefined_label| or the address of the
24269 most recent lig/kern instruction that skips to local label~|c|. In the
24270 latter case, the |skip_byte| in that instruction will (temporarily)
24271 be zero if there were no prior skips to this label, or it will be the
24272 distance to the prior skip.
24274 We may need to cancel skips that span more than 127 lig/kern steps.
24276 @d cancel_skips(A) mp->ll=(A);
24278 mp->lll=qo(skip_byte(mp->ll));
24279 skip_byte(mp->ll)=stop_flag; mp->ll=mp->ll-mp->lll;
24280 } while (mp->lll!=0)
24281 @d skip_error(A) { print_err("Too far to skip");
24282 @.Too far to skip@>
24283 help1("At most 127 lig/kern steps can separate skipto1 from 1::.");
24284 mp_error(mp); cancel_skips((A));
24287 @<Process a |skip_to| command and |goto done|@>=
24290 if ( mp->nl-mp->skip_table[c]>128 ) {
24291 skip_error(mp->skip_table[c]); mp->skip_table[c]=undefined_label;
24293 if ( mp->skip_table[c]==undefined_label ) skip_byte(mp->nl-1)=qi(0);
24294 else skip_byte(mp->nl-1)=qi(mp->nl-mp->skip_table[c]-1);
24295 mp->skip_table[c]=mp->nl-1; goto DONE;
24298 @ @<Record a label in a lig/kern subprogram and |goto continue|@>=
24300 if ( mp->cur_cmd==colon ) {
24301 if ( c==256 ) mp->bch_label=mp->nl;
24302 else mp_set_tag(mp, c,lig_tag,mp->nl);
24303 } else if ( mp->skip_table[c]<undefined_label ) {
24304 mp->ll=mp->skip_table[c]; mp->skip_table[c]=undefined_label;
24306 mp->lll=qo(skip_byte(mp->ll));
24307 if ( mp->nl-mp->ll>128 ) {
24308 skip_error(mp->ll); goto CONTINUE;
24310 skip_byte(mp->ll)=qi(mp->nl-mp->ll-1); mp->ll=mp->ll-mp->lll;
24311 } while (mp->lll!=0);
24316 @ @<Compile a ligature/kern...@>=
24318 next_char(mp->nl)=qi(c); skip_byte(mp->nl)=qi(0);
24319 if ( mp->cur_mod<128 ) { /* ligature op */
24320 op_byte(mp->nl)=qi(mp->cur_mod); rem_byte(mp->nl)=qi(mp_get_code(mp));
24322 mp_get_x_next(mp); mp_scan_expression(mp);
24323 if ( mp->cur_type!=mp_known ) {
24324 exp_err("Improper kern");
24326 help2("The amount of kern should be a known numeric value.")
24327 ("I'm zeroing this one. Proceed, with fingers crossed.");
24328 mp_put_get_flush_error(mp, 0);
24330 mp->kern[mp->nk]=mp->cur_exp;
24332 while ( mp->kern[k]!=mp->cur_exp ) incr(k);
24334 if ( mp->nk==max_tfm_int ) mp_fatal_error(mp, "too many TFM kerns");
24337 op_byte(mp->nl)=kern_flag+(k / 256);
24338 rem_byte(mp->nl)=qi((k % 256));
24340 mp->lk_started=true;
24343 @ @d missing_extensible_punctuation(A)
24344 { mp_missing_err(mp, (A));
24345 @.Missing `\char`\#'@>
24346 help1("I'm processing `extensible c: t,m,b,r'."); mp_back_error(mp);
24349 @<Define an extensible recipe@>=
24351 if ( mp->ne==256 ) mp_fatal_error(mp, "too many extensible recipies");
24352 c=mp_get_code(mp); mp_set_tag(mp, c,ext_tag,mp->ne);
24353 if ( mp->cur_cmd!=colon ) missing_extensible_punctuation(":");
24354 ext_top(mp->ne)=qi(mp_get_code(mp));
24355 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
24356 ext_mid(mp->ne)=qi(mp_get_code(mp));
24357 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
24358 ext_bot(mp->ne)=qi(mp_get_code(mp));
24359 if ( mp->cur_cmd!=comma ) missing_extensible_punctuation(",");
24360 ext_rep(mp->ne)=qi(mp_get_code(mp));
24364 @ The header could contain ASCII zeroes, so can't use |strdup|.
24366 @<Store a list of header bytes@>=
24368 if ( j>=mp->header_size ) {
24369 int l = mp->header_size + (mp->header_size >> 2);
24370 char *t = xmalloc(l,sizeof(char));
24372 memcpy(t,mp->header_byte,mp->header_size);
24373 xfree (mp->header_byte);
24374 mp->header_byte = t;
24375 mp->header_size = l;
24377 mp->header_byte[j]=mp_get_code(mp);
24378 incr(j); incr(mp->header_last);
24379 } while (mp->cur_cmd==comma)
24381 @ @<Store a list of font dimensions@>=
24383 if ( j>max_tfm_int ) mp_fatal_error(mp, "too many fontdimens");
24384 while ( j>mp->np ) { incr(mp->np); mp->param[mp->np]=0; };
24385 mp_get_x_next(mp); mp_scan_expression(mp);
24386 if ( mp->cur_type!=mp_known ){
24387 exp_err("Improper font parameter");
24388 @.Improper font parameter@>
24389 help1("I'm zeroing this one. Proceed, with fingers crossed.");
24390 mp_put_get_flush_error(mp, 0);
24392 mp->param[j]=mp->cur_exp; incr(j);
24393 } while (mp->cur_cmd==comma)
24395 @ OK: We've stored all the data that is needed for the \.{TFM} file.
24396 All that remains is to output it in the correct format.
24398 An interesting problem needs to be solved in this connection, because
24399 the \.{TFM} format allows at most 256~widths, 16~heights, 16~depths,
24400 and 64~italic corrections. If the data has more distinct values than
24401 this, we want to meet the necessary restrictions by perturbing the
24402 given values as little as possible.
24404 \MP\ solves this problem in two steps. First the values of a given
24405 kind (widths, heights, depths, or italic corrections) are sorted;
24406 then the list of sorted values is perturbed, if necessary.
24408 The sorting operation is facilitated by having a special node of
24409 essentially infinite |value| at the end of the current list.
24411 @<Initialize table entries...@>=
24412 value(inf_val)=fraction_four;
24414 @ Straight linear insertion is good enough for sorting, since the lists
24415 are usually not terribly long. As we work on the data, the current list
24416 will start at |link(temp_head)| and end at |inf_val|; the nodes in this
24417 list will be in increasing order of their |value| fields.
24419 Given such a list, the |sort_in| function takes a value and returns a pointer
24420 to where that value can be found in the list. The value is inserted in
24421 the proper place, if necessary.
24423 At the time we need to do these operations, most of \MP's work has been
24424 completed, so we will have plenty of memory to play with. The value nodes
24425 that are allocated for sorting will never be returned to free storage.
24427 @d clear_the_list link(temp_head)=inf_val
24429 @c pointer mp_sort_in (MP mp,scaled v) {
24430 pointer p,q,r; /* list manipulation registers */
24434 if ( v<=value(q) ) break;
24437 if ( v<value(q) ) {
24438 r=mp_get_node(mp, value_node_size); value(r)=v; link(r)=q; link(p)=r;
24443 @ Now we come to the interesting part, where we reduce the list if necessary
24444 until it has the required size. The |min_cover| routine is basic to this
24445 process; it computes the minimum number~|m| such that the values of the
24446 current sorted list can be covered by |m|~intervals of width~|d|. It
24447 also sets the global value |perturbation| to the smallest value $d'>d$
24448 such that the covering found by this algorithm would be different.
24450 In particular, |min_cover(0)| returns the number of distinct values in the
24451 current list and sets |perturbation| to the minimum distance between
24454 @c integer mp_min_cover (MP mp,scaled d) {
24455 pointer p; /* runs through the current list */
24456 scaled l; /* the least element covered by the current interval */
24457 integer m; /* lower bound on the size of the minimum cover */
24458 m=0; p=link(temp_head); mp->perturbation=el_gordo;
24459 while ( p!=inf_val ){
24460 incr(m); l=value(p);
24461 do { p=link(p); } while (value(p)<=l+d);
24462 if ( value(p)-l<mp->perturbation )
24463 mp->perturbation=value(p)-l;
24469 scaled perturbation; /* quantity related to \.{TFM} rounding */
24470 integer excess; /* the list is this much too long */
24472 @ The smallest |d| such that a given list can be covered with |m| intervals
24473 is determined by the |threshold| routine, which is sort of an inverse
24474 to |min_cover|. The idea is to increase the interval size rapidly until
24475 finding the range, then to go sequentially until the exact borderline has
24478 @c scaled mp_threshold (MP mp,integer m) {
24479 scaled d; /* lower bound on the smallest interval size */
24480 mp->excess=mp_min_cover(mp, 0)-m;
24481 if ( mp->excess<=0 ) {
24485 d=mp->perturbation;
24486 } while (mp_min_cover(mp, d+d)>m);
24487 while ( mp_min_cover(mp, d)>m )
24488 d=mp->perturbation;
24493 @ The |skimp| procedure reduces the current list to at most |m| entries,
24494 by changing values if necessary. It also sets |info(p):=k| if |value(p)|
24495 is the |k|th distinct value on the resulting list, and it sets
24496 |perturbation| to the maximum amount by which a |value| field has
24497 been changed. The size of the resulting list is returned as the
24500 @c integer mp_skimp (MP mp,integer m) {
24501 scaled d; /* the size of intervals being coalesced */
24502 pointer p,q,r; /* list manipulation registers */
24503 scaled l; /* the least value in the current interval */
24504 scaled v; /* a compromise value */
24505 d=mp_threshold(mp, m); mp->perturbation=0;
24506 q=temp_head; m=0; p=link(temp_head);
24507 while ( p!=inf_val ) {
24508 incr(m); l=value(p); info(p)=m;
24509 if ( value(link(p))<=l+d ) {
24510 @<Replace an interval of values by its midpoint@>;
24517 @ @<Replace an interval...@>=
24520 p=link(p); info(p)=m;
24521 decr(mp->excess); if ( mp->excess==0 ) d=0;
24522 } while (value(link(p))<=l+d);
24523 v=l+halfp(value(p)-l);
24524 if ( value(p)-v>mp->perturbation )
24525 mp->perturbation=value(p)-v;
24528 r=link(r); value(r)=v;
24530 link(q)=p; /* remove duplicate values from the current list */
24533 @ A warning message is issued whenever something is perturbed by
24534 more than 1/16\thinspace pt.
24536 @c void mp_tfm_warning (MP mp,small_number m) {
24537 mp_print_nl(mp, "(some ");
24538 mp_print(mp, mp->int_name[m]);
24539 @.some charwds...@>
24540 @.some chardps...@>
24541 @.some charhts...@>
24542 @.some charics...@>
24543 mp_print(mp, " values had to be adjusted by as much as ");
24544 mp_print_scaled(mp, mp->perturbation); mp_print(mp, "pt)");
24547 @ Here's an example of how we use these routines.
24548 The width data needs to be perturbed only if there are 256 distinct
24549 widths, but \MP\ must check for this case even though it is
24552 An integer variable |k| will be defined when we use this code.
24553 The |dimen_head| array will contain pointers to the sorted
24554 lists of dimensions.
24556 @<Massage the \.{TFM} widths@>=
24558 for (k=mp->bc;k<=mp->ec;k++) {
24559 if ( mp->char_exists[k] )
24560 mp->tfm_width[k]=mp_sort_in(mp, mp->tfm_width[k]);
24562 mp->nw=mp_skimp(mp, 255)+1; mp->dimen_head[1]=link(temp_head);
24563 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_wd)
24566 pointer dimen_head[5]; /* lists of \.{TFM} dimensions */
24568 @ Heights, depths, and italic corrections are different from widths
24569 not only because their list length is more severely restricted, but
24570 also because zero values do not need to be put into the lists.
24572 @<Massage the \.{TFM} heights, depths, and italic corrections@>=
24574 for (k=mp->bc;k<=mp->ec;k++) {
24575 if ( mp->char_exists[k] ) {
24576 if ( mp->tfm_height[k]==0 ) mp->tfm_height[k]=zero_val;
24577 else mp->tfm_height[k]=mp_sort_in(mp, mp->tfm_height[k]);
24580 mp->nh=mp_skimp(mp, 15)+1; mp->dimen_head[2]=link(temp_head);
24581 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_ht);
24583 for (k=mp->bc;k<=mp->ec;k++) {
24584 if ( mp->char_exists[k] ) {
24585 if ( mp->tfm_depth[k]==0 ) mp->tfm_depth[k]=zero_val;
24586 else mp->tfm_depth[k]=mp_sort_in(mp, mp->tfm_depth[k]);
24589 mp->nd=mp_skimp(mp, 15)+1; mp->dimen_head[3]=link(temp_head);
24590 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_dp);
24592 for (k=mp->bc;k<=mp->ec;k++) {
24593 if ( mp->char_exists[k] ) {
24594 if ( mp->tfm_ital_corr[k]==0 ) mp->tfm_ital_corr[k]=zero_val;
24595 else mp->tfm_ital_corr[k]=mp_sort_in(mp, mp->tfm_ital_corr[k]);
24598 mp->ni=mp_skimp(mp, 63)+1; mp->dimen_head[4]=link(temp_head);
24599 if ( mp->perturbation>=010000 ) mp_tfm_warning(mp, mp_char_ic)
24601 @ @<Initialize table entries...@>=
24602 value(zero_val)=0; info(zero_val)=0;
24604 @ Bytes 5--8 of the header are set to the design size, unless the user has
24605 some crazy reason for specifying them differently.
24608 Error messages are not allowed at the time this procedure is called,
24609 so a warning is printed instead.
24611 The value of |max_tfm_dimen| is calculated so that
24612 $$\hbox{|make_scaled(16*max_tfm_dimen,internal[mp_design_size])|}
24613 < \\{three\_bytes}.$$
24615 @d three_bytes 0100000000 /* $2^{24}$ */
24618 void mp_fix_design_size (MP mp) {
24619 scaled d; /* the design size */
24620 d=mp->internal[mp_design_size];
24621 if ( (d<unity)||(d>=fraction_half) ) {
24623 mp_print_nl(mp, "(illegal design size has been changed to 128pt)");
24624 @.illegal design size...@>
24625 d=040000000; mp->internal[mp_design_size]=d;
24627 if ( mp->header_byte[4]<0 ) if ( mp->header_byte[5]<0 )
24628 if ( mp->header_byte[6]<0 ) if ( mp->header_byte[7]<0 ) {
24629 mp->header_byte[4]=d / 04000000;
24630 mp->header_byte[5]=(d / 4096) % 256;
24631 mp->header_byte[6]=(d / 16) % 256;
24632 mp->header_byte[7]=(d % 16)*16;
24634 mp->max_tfm_dimen=16*mp->internal[mp_design_size]-1-mp->internal[mp_design_size] / 010000000;
24635 if ( mp->max_tfm_dimen>=fraction_half ) mp->max_tfm_dimen=fraction_half-1;
24638 @ The |dimen_out| procedure computes a |fix_word| relative to the
24639 design size. If the data was out of range, it is corrected and the
24640 global variable |tfm_changed| is increased by~one.
24642 @c integer mp_dimen_out (MP mp,scaled x) {
24643 if ( abs(x)>mp->max_tfm_dimen ) {
24644 incr(mp->tfm_changed);
24645 if ( x>0 ) x=mp->max_tfm_dimen; else x=-mp->max_tfm_dimen;
24647 x=mp_make_scaled(mp, x*16,mp->internal[mp_design_size]);
24652 scaled max_tfm_dimen; /* bound on widths, heights, kerns, etc. */
24653 integer tfm_changed; /* the number of data entries that were out of bounds */
24655 @ If the user has not specified any of the first four header bytes,
24656 the |fix_check_sum| procedure replaces them by a ``check sum'' computed
24657 from the |tfm_width| data relative to the design size.
24660 @c void mp_fix_check_sum (MP mp) {
24661 eight_bits k; /* runs through character codes */
24662 eight_bits B1,B2,B3,B4; /* bytes of the check sum */
24663 integer x; /* hash value used in check sum computation */
24664 if ( mp->header_byte[0]==0 && mp->header_byte[1]==0 &&
24665 mp->header_byte[2]==0 && mp->header_byte[3]==0 ) {
24666 @<Compute a check sum in |(b1,b2,b3,b4)|@>;
24667 mp->header_byte[0]=B1; mp->header_byte[1]=B2;
24668 mp->header_byte[2]=B3; mp->header_byte[3]=B4;
24673 @ @<Compute a check sum in |(b1,b2,b3,b4)|@>=
24674 B1=mp->bc; B2=mp->ec; B3=mp->bc; B4=mp->ec; mp->tfm_changed=0;
24675 for (k=mp->bc;k<=mp->ec;k++) {
24676 if ( mp->char_exists[k] ) {
24677 x=mp_dimen_out(mp, value(mp->tfm_width[k]))+(k+4)*020000000; /* this is positive */
24678 B1=(B1+B1+x) % 255;
24679 B2=(B2+B2+x) % 253;
24680 B3=(B3+B3+x) % 251;
24681 B4=(B4+B4+x) % 247;
24685 @ Finally we're ready to actually write the \.{TFM} information.
24686 Here are some utility routines for this purpose.
24688 @d tfm_out(A) do { /* output one byte to |tfm_file| */
24689 unsigned char s=(A);
24690 (mp->write_binary_file)(mp,mp->tfm_file,(void *)&s,1);
24693 @c void mp_tfm_two (MP mp,integer x) { /* output two bytes to |tfm_file| */
24694 tfm_out(x / 256); tfm_out(x % 256);
24696 void mp_tfm_four (MP mp,integer x) { /* output four bytes to |tfm_file| */
24697 if ( x>=0 ) tfm_out(x / three_bytes);
24699 x=x+010000000000; /* use two's complement for negative values */
24701 tfm_out((x / three_bytes) + 128);
24703 x=x % three_bytes; tfm_out(x / unity);
24704 x=x % unity; tfm_out(x / 0400);
24707 void mp_tfm_qqqq (MP mp,four_quarters x) { /* output four quarterwords to |tfm_file| */
24708 tfm_out(qo(x.b0)); tfm_out(qo(x.b1));
24709 tfm_out(qo(x.b2)); tfm_out(qo(x.b3));
24712 @ @<Finish the \.{TFM} file@>=
24713 if ( mp->job_name==NULL ) mp_open_log_file(mp);
24714 mp_pack_job_name(mp, ".tfm");
24715 while ( ! mp_b_open_out(mp, &mp->tfm_file, mp_filetype_metrics) )
24716 mp_prompt_file_name(mp, "file name for font metrics",".tfm");
24717 mp->metric_file_name=xstrdup(mp->name_of_file);
24718 @<Output the subfile sizes and header bytes@>;
24719 @<Output the character information bytes, then
24720 output the dimensions themselves@>;
24721 @<Output the ligature/kern program@>;
24722 @<Output the extensible character recipes and the font metric parameters@>;
24723 if ( mp->internal[mp_tracing_stats]>0 )
24724 @<Log the subfile sizes of the \.{TFM} file@>;
24725 mp_print_nl(mp, "Font metrics written on ");
24726 mp_print(mp, mp->metric_file_name); mp_print_char(mp, '.');
24727 @.Font metrics written...@>
24728 (mp->close_file)(mp,mp->tfm_file)
24730 @ Integer variables |lh|, |k|, and |lk_offset| will be defined when we use
24733 @<Output the subfile sizes and header bytes@>=
24735 LH=(k+3) / 4; /* this is the number of header words */
24736 if ( mp->bc>mp->ec ) mp->bc=1; /* if there are no characters, |ec=0| and |bc=1| */
24737 @<Compute the ligature/kern program offset and implant the
24738 left boundary label@>;
24739 mp_tfm_two(mp,6+LH+(mp->ec-mp->bc+1)+mp->nw+mp->nh+mp->nd+mp->ni+mp->nl
24740 +lk_offset+mp->nk+mp->ne+mp->np);
24741 /* this is the total number of file words that will be output */
24742 mp_tfm_two(mp, LH); mp_tfm_two(mp, mp->bc); mp_tfm_two(mp, mp->ec);
24743 mp_tfm_two(mp, mp->nw); mp_tfm_two(mp, mp->nh);
24744 mp_tfm_two(mp, mp->nd); mp_tfm_two(mp, mp->ni); mp_tfm_two(mp, mp->nl+lk_offset);
24745 mp_tfm_two(mp, mp->nk); mp_tfm_two(mp, mp->ne);
24746 mp_tfm_two(mp, mp->np);
24747 for (k=0;k< 4*LH;k++) {
24748 tfm_out(mp->header_byte[k]);
24751 @ @<Output the character information bytes...@>=
24752 for (k=mp->bc;k<=mp->ec;k++) {
24753 if ( ! mp->char_exists[k] ) {
24754 mp_tfm_four(mp, 0);
24756 tfm_out(info(mp->tfm_width[k])); /* the width index */
24757 tfm_out((info(mp->tfm_height[k]))*16+info(mp->tfm_depth[k]));
24758 tfm_out((info(mp->tfm_ital_corr[k]))*4+mp->char_tag[k]);
24759 tfm_out(mp->char_remainder[k]);
24763 for (k=1;k<=4;k++) {
24764 mp_tfm_four(mp, 0); p=mp->dimen_head[k];
24765 while ( p!=inf_val ) {
24766 mp_tfm_four(mp, mp_dimen_out(mp, value(p))); p=link(p);
24771 @ We need to output special instructions at the beginning of the
24772 |lig_kern| array in order to specify the right boundary character
24773 and/or to handle starting addresses that exceed 255. The |label_loc|
24774 and |label_char| arrays have been set up to record all the
24775 starting addresses; we have $-1=|label_loc|[0]<|label_loc|[1]\le\cdots
24776 \le|label_loc|[|label_ptr]|$.
24778 @<Compute the ligature/kern program offset...@>=
24779 mp->bchar=mp_round_unscaled(mp, mp->internal[mp_boundary_char]);
24780 if ((mp->bchar<0)||(mp->bchar>255))
24781 { mp->bchar=-1; mp->lk_started=false; lk_offset=0; }
24782 else { mp->lk_started=true; lk_offset=1; };
24783 @<Find the minimum |lk_offset| and adjust all remainders@>;
24784 if ( mp->bch_label<undefined_label )
24785 { skip_byte(mp->nl)=qi(255); next_char(mp->nl)=qi(0);
24786 op_byte(mp->nl)=qi(((mp->bch_label+lk_offset)/ 256));
24787 rem_byte(mp->nl)=qi(((mp->bch_label+lk_offset)% 256));
24788 incr(mp->nl); /* possibly |nl=lig_table_size+1| */
24791 @ @<Find the minimum |lk_offset|...@>=
24792 k=mp->label_ptr; /* pointer to the largest unallocated label */
24793 if ( mp->label_loc[k]+lk_offset>255 ) {
24794 lk_offset=0; mp->lk_started=false; /* location 0 can do double duty */
24796 mp->char_remainder[mp->label_char[k]]=lk_offset;
24797 while ( mp->label_loc[k-1]==mp->label_loc[k] ) {
24798 decr(k); mp->char_remainder[mp->label_char[k]]=lk_offset;
24800 incr(lk_offset); decr(k);
24801 } while (! (lk_offset+mp->label_loc[k]<256));
24802 /* N.B.: |lk_offset=256| satisfies this when |k=0| */
24804 if ( lk_offset>0 ) {
24806 mp->char_remainder[mp->label_char[k]]
24807 =mp->char_remainder[mp->label_char[k]]+lk_offset;
24812 @ @<Output the ligature/kern program@>=
24813 for (k=0;k<= 255;k++ ) {
24814 if ( mp->skip_table[k]<undefined_label ) {
24815 mp_print_nl(mp, "(local label "); mp_print_int(mp, k); mp_print(mp, ":: was missing)");
24816 @.local label l:: was missing@>
24817 cancel_skips(mp->skip_table[k]);
24820 if ( mp->lk_started ) { /* |lk_offset=1| for the special |bchar| */
24821 tfm_out(255); tfm_out(mp->bchar); mp_tfm_two(mp, 0);
24823 for (k=1;k<=lk_offset;k++) {/* output the redirection specs */
24824 mp->ll=mp->label_loc[mp->label_ptr];
24825 if ( mp->bchar<0 ) { tfm_out(254); tfm_out(0); }
24826 else { tfm_out(255); tfm_out(mp->bchar); };
24827 mp_tfm_two(mp, mp->ll+lk_offset);
24829 decr(mp->label_ptr);
24830 } while (! (mp->label_loc[mp->label_ptr]<mp->ll));
24833 for (k=0;k<=mp->nl-1;k++) mp_tfm_qqqq(mp, mp->lig_kern[k]);
24834 for (k=0;k<=mp->nk-1;k++) mp_tfm_four(mp, mp_dimen_out(mp, mp->kern[k]))
24836 @ @<Output the extensible character recipes...@>=
24837 for (k=0;k<=mp->ne-1;k++)
24838 mp_tfm_qqqq(mp, mp->exten[k]);
24839 for (k=1;k<=mp->np;k++) {
24841 if ( abs(mp->param[1])<fraction_half ) {
24842 mp_tfm_four(mp, mp->param[1]*16);
24844 incr(mp->tfm_changed);
24845 if ( mp->param[1]>0 ) mp_tfm_four(mp, el_gordo);
24846 else mp_tfm_four(mp, -el_gordo);
24849 mp_tfm_four(mp, mp_dimen_out(mp, mp->param[k]));
24852 if ( mp->tfm_changed>0 ) {
24853 if ( mp->tfm_changed==1 ) mp_print_nl(mp, "(a font metric dimension");
24854 @.a font metric dimension...@>
24856 mp_print_nl(mp, "("); mp_print_int(mp, mp->tfm_changed);
24857 @.font metric dimensions...@>
24858 mp_print(mp, " font metric dimensions");
24860 mp_print(mp, " had to be decreased)");
24863 @ @<Log the subfile sizes of the \.{TFM} file@>=
24867 if ( mp->bch_label<undefined_label ) decr(mp->nl);
24868 mp_snprintf(s,128,"(You used %iw,%ih,%id,%ii,%il,%ik,%ie,%ip metric file positions)",
24869 mp->nw, mp->nh, mp->nd, mp->ni, mp->nl, mp->nk, mp->ne,mp->np);
24873 @* \[43] Reading font metric data.
24875 \MP\ isn't a typesetting program but it does need to find the bounding box
24876 of a sequence of typeset characters. Thus it needs to read \.{TFM} files as
24877 well as write them.
24882 @ All the width, height, and depth information is stored in an array called
24883 |font_info|. This array is allocated sequentially and each font is stored
24884 as a series of |char_info| words followed by the width, height, and depth
24885 tables. Since |font_name| entries are permanent, their |str_ref| values are
24886 set to |max_str_ref|.
24889 typedef unsigned int font_number; /* |0..font_max| */
24891 @ The |font_info| array is indexed via a group directory arrays.
24892 For example, the |char_info| data for character~|c| in font~|f| will be
24893 in |font_info[char_base[f]+c].qqqq|.
24896 font_number font_max; /* maximum font number for included text fonts */
24897 size_t font_mem_size; /* number of words for \.{TFM} information for text fonts */
24898 memory_word *font_info; /* height, width, and depth data */
24899 char **font_enc_name; /* encoding names, if any */
24900 boolean *font_ps_name_fixed; /* are the postscript names fixed already? */
24901 int next_fmem; /* next unused entry in |font_info| */
24902 font_number last_fnum; /* last font number used so far */
24903 scaled *font_dsize; /* 16 times the ``design'' size in \ps\ points */
24904 char **font_name; /* name as specified in the \&{infont} command */
24905 char **font_ps_name; /* PostScript name for use when |internal[mp_prologues]>0| */
24906 font_number last_ps_fnum; /* last valid |font_ps_name| index */
24907 eight_bits *font_bc;
24908 eight_bits *font_ec; /* first and last character code */
24909 int *char_base; /* base address for |char_info| */
24910 int *width_base; /* index for zeroth character width */
24911 int *height_base; /* index for zeroth character height */
24912 int *depth_base; /* index for zeroth character depth */
24913 pointer *font_sizes;
24915 @ @<Allocate or initialize ...@>=
24916 mp->font_mem_size = 10000;
24917 mp->font_info = xmalloc ((mp->font_mem_size+1),sizeof(memory_word));
24918 memset (mp->font_info,0,sizeof(memory_word)*(mp->font_mem_size+1));
24919 mp->last_fnum = null_font;
24921 @ @<Dealloc variables@>=
24922 for (k=1;k<=(int)mp->last_fnum;k++) {
24923 xfree(mp->font_enc_name[k]);
24924 xfree(mp->font_name[k]);
24925 xfree(mp->font_ps_name[k]);
24927 xfree(mp->font_info);
24928 xfree(mp->font_enc_name);
24929 xfree(mp->font_ps_name_fixed);
24930 xfree(mp->font_dsize);
24931 xfree(mp->font_name);
24932 xfree(mp->font_ps_name);
24933 xfree(mp->font_bc);
24934 xfree(mp->font_ec);
24935 xfree(mp->char_base);
24936 xfree(mp->width_base);
24937 xfree(mp->height_base);
24938 xfree(mp->depth_base);
24939 xfree(mp->font_sizes);
24943 void mp_reallocate_fonts (MP mp, font_number l) {
24945 XREALLOC(mp->font_enc_name, l, char *);
24946 XREALLOC(mp->font_ps_name_fixed, l, boolean);
24947 XREALLOC(mp->font_dsize, l, scaled);
24948 XREALLOC(mp->font_name, l, char *);
24949 XREALLOC(mp->font_ps_name, l, char *);
24950 XREALLOC(mp->font_bc, l, eight_bits);
24951 XREALLOC(mp->font_ec, l, eight_bits);
24952 XREALLOC(mp->char_base, l, int);
24953 XREALLOC(mp->width_base, l, int);
24954 XREALLOC(mp->height_base, l, int);
24955 XREALLOC(mp->depth_base, l, int);
24956 XREALLOC(mp->font_sizes, l, pointer);
24957 for (f=(mp->last_fnum+1);f<=l;f++) {
24958 mp->font_enc_name[f]=NULL;
24959 mp->font_ps_name_fixed[f] = false;
24960 mp->font_name[f]=NULL;
24961 mp->font_ps_name[f]=NULL;
24962 mp->font_sizes[f]=null;
24967 @ @<Declare |mp_reallocate| functions@>=
24968 void mp_reallocate_fonts (MP mp, font_number l);
24971 @ A |null_font| containing no characters is useful for error recovery. Its
24972 |font_name| entry starts out empty but is reset each time an erroneous font is
24973 found. This helps to cut down on the number of duplicate error messages without
24974 wasting a lot of space.
24976 @d null_font 0 /* the |font_number| for an empty font */
24978 @<Set initial...@>=
24979 mp->font_dsize[null_font]=0;
24980 mp->font_bc[null_font]=1;
24981 mp->font_ec[null_font]=0;
24982 mp->char_base[null_font]=0;
24983 mp->width_base[null_font]=0;
24984 mp->height_base[null_font]=0;
24985 mp->depth_base[null_font]=0;
24987 mp->last_fnum=null_font;
24988 mp->last_ps_fnum=null_font;
24989 mp->font_name[null_font]=(char *)"nullfont";
24990 mp->font_ps_name[null_font]=(char *)"";
24991 mp->font_ps_name_fixed[null_font] = false;
24992 mp->font_enc_name[null_font]=NULL;
24993 mp->font_sizes[null_font]=null;
24995 @ Each |char_info| word is of type |four_quarters|. The |b0| field contains
24996 the |width index|; the |b1| field contains the height
24997 index; the |b2| fields contains the depth index, and the |b3| field used only
24998 for temporary storage. (It is used to keep track of which characters occur in
24999 an edge structure that is being shipped out.)
25000 The corresponding words in the width, height, and depth tables are stored as
25001 |scaled| values in units of \ps\ points.
25003 With the macros below, the |char_info| word for character~|c| in font~|f| is
25004 |char_info(f,c)| and the width is
25005 $$\hbox{|char_width(f,char_info(f,c)).sc|.}$$
25007 @d char_info(A,B) mp->font_info[mp->char_base[(A)]+(B)].qqqq
25008 @d char_width(A,B) mp->font_info[mp->width_base[(A)]+(B).b0].sc
25009 @d char_height(A,B) mp->font_info[mp->height_base[(A)]+(B).b1].sc
25010 @d char_depth(A,B) mp->font_info[mp->depth_base[(A)]+(B).b2].sc
25011 @d ichar_exists(A) ((A).b0>0)
25013 @ The |font_ps_name| for a built-in font should be what PostScript expects.
25014 A preliminary name is obtained here from the \.{TFM} name as given in the
25015 |fname| argument. This gets updated later from an external table if necessary.
25017 @<Declare text measuring subroutines@>=
25018 @<Declare subroutines for parsing file names@>
25019 font_number mp_read_font_info (MP mp, char *fname) {
25020 boolean file_opened; /* has |tfm_infile| been opened? */
25021 font_number n; /* the number to return */
25022 halfword lf,tfm_lh,bc,ec,nw,nh,nd; /* subfile size parameters */
25023 size_t whd_size; /* words needed for heights, widths, and depths */
25024 int i,ii; /* |font_info| indices */
25025 int jj; /* counts bytes to be ignored */
25026 scaled z; /* used to compute the design size */
25028 /* height, width, or depth as a fraction of design size times $2^{-8}$ */
25029 eight_bits h_and_d; /* height and depth indices being unpacked */
25030 unsigned char tfbyte; /* a byte read from the file */
25032 @<Open |tfm_infile| for input@>;
25033 @<Read data from |tfm_infile|; if there is no room, say so and |goto done|;
25034 otherwise |goto bad_tfm| or |goto done| as appropriate@>;
25036 @<Complain that the \.{TFM} file is bad@>;
25038 if ( file_opened ) (mp->close_file)(mp,mp->tfm_infile);
25039 if ( n!=null_font ) {
25040 mp->font_ps_name[n]=mp_xstrdup(mp,fname);
25041 mp->font_name[n]=mp_xstrdup(mp,fname);
25046 @ \MP\ doesn't bother to check the entire \.{TFM} file for errors or explain
25047 precisely what is wrong if it does find a problem. Programs called \.{TFtoPL}
25048 @.TFtoPL@> @.PLtoTF@>
25049 and \.{PLtoTF} can be used to debug \.{TFM} files.
25051 @<Complain that the \.{TFM} file is bad@>=
25052 print_err("Font ");
25053 mp_print(mp, fname);
25054 if ( file_opened ) mp_print(mp, " not usable: TFM file is bad");
25055 else mp_print(mp, " not usable: TFM file not found");
25056 help3("I wasn't able to read the size data for this font so this")
25057 ("`infont' operation won't produce anything. If the font name")
25058 ("is right, you might ask an expert to make a TFM file");
25060 mp->help_line[0]="is right, try asking an expert to fix the TFM file";
25063 @ @<Read data from |tfm_infile|; if there is no room, say so...@>=
25064 @<Read the \.{TFM} size fields@>;
25065 @<Use the size fields to allocate space in |font_info|@>;
25066 @<Read the \.{TFM} header@>;
25067 @<Read the character data and the width, height, and depth tables and
25070 @ A bad \.{TFM} file can be shorter than it claims to be. The code given here
25071 might try to read past the end of the file if this happens. Changes will be
25072 needed if it causes a system error to refer to |tfm_infile^| or call
25073 |get_tfm_infile| when |eof(tfm_infile)| is true. For example, the definition
25074 @^system dependencies@>
25075 of |tfget| could be changed to
25076 ``|begin get(tfm_infile); if eof(tfm_infile) then goto bad_tfm; end|.''
25080 void *tfbyte_ptr = &tfbyte;
25081 (mp->read_binary_file)(mp,mp->tfm_infile,&tfbyte_ptr,&wanted);
25082 if (wanted==0) goto BAD_TFM;
25084 @d read_two(A) { (A)=tfbyte;
25085 if ( (A)>127 ) goto BAD_TFM;
25086 tfget; (A)=(A)*0400+tfbyte;
25088 @d tf_ignore(A) { for (jj=(A);jj>=1;jj--) tfget; }
25090 @<Read the \.{TFM} size fields@>=
25091 tfget; read_two(lf);
25092 tfget; read_two(tfm_lh);
25093 tfget; read_two(bc);
25094 tfget; read_two(ec);
25095 if ( (bc>1+ec)||(ec>255) ) goto BAD_TFM;
25096 tfget; read_two(nw);
25097 tfget; read_two(nh);
25098 tfget; read_two(nd);
25099 whd_size=(ec+1-bc)+nw+nh+nd;
25100 if ( lf<(int)(6+tfm_lh+whd_size) ) goto BAD_TFM;
25103 @ Offsets are added to |char_base[n]| and |width_base[n]| so that is not
25104 necessary to apply the |so| and |qo| macros when looking up the width of a
25105 character in the string pool. In order to ensure nonnegative |char_base|
25106 values when |bc>0|, it may be necessary to reserve a few unused |font_info|
25109 @<Use the size fields to allocate space in |font_info|@>=
25110 if ( mp->next_fmem<bc) mp->next_fmem=bc; /* ensure nonnegative |char_base| */
25111 if (mp->last_fnum==mp->font_max)
25112 mp_reallocate_fonts(mp,(mp->font_max+(mp->font_max>>2)));
25113 while (mp->next_fmem+whd_size>=mp->font_mem_size) {
25114 size_t l = mp->font_mem_size+(mp->font_mem_size>>2);
25115 memory_word *font_info;
25116 font_info = xmalloc ((l+1),sizeof(memory_word));
25117 memset (font_info,0,sizeof(memory_word)*(l+1));
25118 memcpy (font_info,mp->font_info,sizeof(memory_word)*(mp->font_mem_size+1));
25119 xfree(mp->font_info);
25120 mp->font_info = font_info;
25121 mp->font_mem_size = l;
25123 incr(mp->last_fnum);
25127 mp->char_base[n]=mp->next_fmem-bc;
25128 mp->width_base[n]=mp->next_fmem+ec-bc+1;
25129 mp->height_base[n]=mp->width_base[n]+nw;
25130 mp->depth_base[n]=mp->height_base[n]+nh;
25131 mp->next_fmem=mp->next_fmem+whd_size;
25134 @ @<Read the \.{TFM} header@>=
25135 if ( tfm_lh<2 ) goto BAD_TFM;
25137 tfget; read_two(z);
25138 tfget; z=z*0400+tfbyte;
25139 tfget; z=z*0400+tfbyte; /* now |z| is 16 times the design size */
25140 mp->font_dsize[n]=mp_take_fraction(mp, z,267432584);
25141 /* times ${72\over72.27}2^{28}$ to convert from \TeX\ points */
25142 tf_ignore(4*(tfm_lh-2))
25144 @ @<Read the character data and the width, height, and depth tables...@>=
25145 ii=mp->width_base[n];
25146 i=mp->char_base[n]+bc;
25148 tfget; mp->font_info[i].qqqq.b0=qi(tfbyte);
25149 tfget; h_and_d=tfbyte;
25150 mp->font_info[i].qqqq.b1=h_and_d / 16;
25151 mp->font_info[i].qqqq.b2=h_and_d % 16;
25155 while ( i<mp->next_fmem ) {
25156 @<Read a four byte dimension, scale it by the design size, store it in
25157 |font_info[i]|, and increment |i|@>;
25161 @ The raw dimension read into |d| should have magnitude at most $2^{24}$ when
25162 interpreted as an integer, and this includes a scale factor of $2^{20}$. Thus
25163 we can multiply it by sixteen and think of it as a |fraction| that has been
25164 divided by sixteen. This cancels the extra scale factor contained in
25167 @<Read a four byte dimension, scale it by the design size, store it in...@>=
25170 if ( d>=0200 ) d=d-0400;
25171 tfget; d=d*0400+tfbyte;
25172 tfget; d=d*0400+tfbyte;
25173 tfget; d=d*0400+tfbyte;
25174 mp->font_info[i].sc=mp_take_fraction(mp, d*16,mp->font_dsize[n]);
25178 @ This function does no longer use the file name parser, because |fname| is
25179 a C string already.
25180 @<Open |tfm_infile| for input@>=
25182 mp_ptr_scan_file(mp, fname);
25183 if ( strlen(mp->cur_area)==0 ) { xfree(mp->cur_area); }
25184 if ( strlen(mp->cur_ext)==0 ) { xfree(mp->cur_ext); mp->cur_ext=xstrdup(".tfm"); }
25186 mp->tfm_infile = (mp->open_file)(mp, mp->name_of_file, "r",mp_filetype_metrics);
25187 if ( !mp->tfm_infile ) goto BAD_TFM;
25190 @ When we have a font name and we don't know whether it has been loaded yet,
25191 we scan the |font_name| array before calling |read_font_info|.
25193 @<Declare text measuring subroutines@>=
25194 font_number mp_find_font (MP mp, char *f) {
25196 for (n=0;n<=mp->last_fnum;n++) {
25197 if (mp_xstrcmp(f,mp->font_name[n])==0 ) {
25202 n = mp_read_font_info(mp, f);
25207 @ This is an interface function for getting the width of character,
25208 as a double in ps units
25210 @c double mp_get_char_dimension (MP mp, char *fname, int c, int t) {
25215 for (n=0;n<=mp->last_fnum;n++) {
25216 if (mp_xstrcmp(fname,mp->font_name[n])==0 ) {
25223 cc = char_info(f,c);
25224 if (! ichar_exists(cc) )
25227 w = char_width(f,cc);
25229 w = char_height(f,cc);
25231 w = char_depth(f,cc);
25232 return w/655.35*(72.27/72);
25235 @ @<Exported function ...@>=
25236 double mp_get_char_dimension (MP mp, char *fname, int n, int t);
25239 @ One simple application of |find_font| is the implementation of the |font_size|
25240 operator that gets the design size for a given font name.
25242 @<Find the design size of the font whose name is |cur_exp|@>=
25243 mp_flush_cur_exp(mp, (mp->font_dsize[mp_find_font(mp, str(mp->cur_exp))]+8) / 16)
25245 @ If we discover that the font doesn't have a requested character, we omit it
25246 from the bounding box computation and expect the \ps\ interpreter to drop it.
25247 This routine issues a warning message if the user has asked for it.
25249 @<Declare text measuring subroutines@>=
25250 void mp_lost_warning (MP mp,font_number f, pool_pointer k) {
25251 if ( mp->internal[mp_tracing_lost_chars]>0 ) {
25252 mp_begin_diagnostic(mp);
25253 if ( mp->selector==log_only ) incr(mp->selector);
25254 mp_print_nl(mp, "Missing character: There is no ");
25255 @.Missing character@>
25256 mp_print_str(mp, mp->str_pool[k]);
25257 mp_print(mp, " in font ");
25258 mp_print(mp, mp->font_name[f]); mp_print_char(mp, '!');
25259 mp_end_diagnostic(mp, false);
25263 @ The whole purpose of saving the height, width, and depth information is to be
25264 able to find the bounding box of an item of text in an edge structure. The
25265 |set_text_box| procedure takes a text node and adds this information.
25267 @<Declare text measuring subroutines@>=
25268 void mp_set_text_box (MP mp,pointer p) {
25269 font_number f; /* |font_n(p)| */
25270 ASCII_code bc,ec; /* range of valid characters for font |f| */
25271 pool_pointer k,kk; /* current character and character to stop at */
25272 four_quarters cc; /* the |char_info| for the current character */
25273 scaled h,d; /* dimensions of the current character */
25275 height_val(p)=-el_gordo;
25276 depth_val(p)=-el_gordo;
25280 kk=str_stop(text_p(p));
25281 k=mp->str_start[text_p(p)];
25283 @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>;
25285 @<Set the height and depth to zero if the bounding box is empty@>;
25288 @ @<Adjust |p|'s bounding box to contain |str_pool[k]|; advance |k|@>=
25290 if ( (mp->str_pool[k]<bc)||(mp->str_pool[k]>ec) ) {
25291 mp_lost_warning(mp, f,k);
25293 cc=char_info(f,mp->str_pool[k]);
25294 if ( ! ichar_exists(cc) ) {
25295 mp_lost_warning(mp, f,k);
25297 width_val(p)=width_val(p)+char_width(f,cc);
25298 h=char_height(f,cc);
25299 d=char_depth(f,cc);
25300 if ( h>height_val(p) ) height_val(p)=h;
25301 if ( d>depth_val(p) ) depth_val(p)=d;
25307 @ Let's hope modern compilers do comparisons correctly when the difference would
25310 @<Set the height and depth to zero if the bounding box is empty@>=
25311 if ( height_val(p)<-depth_val(p) ) {
25316 @ The new primitives fontmapfile and fontmapline.
25318 @<Declare action procedures for use by |do_statement|@>=
25319 void mp_do_mapfile (MP mp) ;
25320 void mp_do_mapline (MP mp) ;
25322 @ @c void mp_do_mapfile (MP mp) {
25323 mp_get_x_next(mp); mp_scan_expression(mp);
25324 if ( mp->cur_type!=mp_string_type ) {
25325 @<Complain about improper map operation@>;
25327 mp_map_file(mp,mp->cur_exp);
25330 void mp_do_mapline (MP mp) {
25331 mp_get_x_next(mp); mp_scan_expression(mp);
25332 if ( mp->cur_type!=mp_string_type ) {
25333 @<Complain about improper map operation@>;
25335 mp_map_line(mp,mp->cur_exp);
25339 @ @<Complain about improper map operation@>=
25341 exp_err("Unsuitable expression");
25342 help1("Only known strings can be map files or map lines.");
25343 mp_put_get_error(mp);
25346 @ To print |scaled| value to PDF output we need some subroutines to ensure
25349 @d max_integer 0x7FFFFFFF /* $2^{31}-1$ */
25352 scaled one_bp; /* scaled value corresponds to 1bp */
25353 scaled one_hundred_bp; /* scaled value corresponds to 100bp */
25354 scaled one_hundred_inch; /* scaled value corresponds to 100in */
25355 integer ten_pow[10]; /* $10^0..10^9$ */
25356 integer scaled_out; /* amount of |scaled| that was taken out in |divide_scaled| */
25359 mp->one_bp = 65782; /* 65781.76 */
25360 mp->one_hundred_bp = 6578176;
25361 mp->one_hundred_inch = 473628672;
25362 mp->ten_pow[0] = 1;
25363 for (i = 1;i<= 9; i++ ) {
25364 mp->ten_pow[i] = 10*mp->ten_pow[i - 1];
25367 @ The following function divides |s| by |m|. |dd| is number of decimal digits.
25369 @c scaled mp_divide_scaled (MP mp,scaled s, scaled m, integer dd) {
25373 if ( s < 0 ) { sign = -sign; s = -s; }
25374 if ( m < 0 ) { sign = -sign; m = -m; }
25376 mp_confusion(mp, "arithmetic: divided by zero");
25377 else if ( m >= (max_integer / 10) )
25378 mp_confusion(mp, "arithmetic: number too big");
25381 for (i = 1;i<=dd;i++) {
25382 q = 10*q + (10*r) / m;
25385 if ( 2*r >= m ) { incr(q); r = r - m; }
25386 mp->scaled_out = sign*(s - (r / mp->ten_pow[dd]));
25390 @* \[44] Shipping pictures out.
25391 The |ship_out| procedure, to be described below, is given a pointer to
25392 an edge structure. Its mission is to output a file containing the \ps\
25393 description of an edge structure.
25395 @ Each time an edge structure is shipped out we write a new \ps\ output
25396 file named according to the current \&{charcode}.
25397 @:char_code_}{\&{charcode} primitive@>
25399 This is the only backend function that remains in the main |mpost.w| file.
25400 There are just too many variable accesses needed for status reporting
25401 etcetera to make it worthwile to move the code to |psout.w|.
25403 @<Internal library declarations@>=
25404 void mp_open_output_file (MP mp) ;
25407 char *mp_set_output_file_name (MP mp, integer c) {
25408 char *ss = NULL; /* filename extension proposal */
25409 char *nn = NULL; /* temp string for str() */
25410 int old_setting; /* previous |selector| setting */
25411 pool_pointer i; /* indexes into |filename_template| */
25412 integer cc; /* a temporary integer for template building */
25413 integer f,g=0; /* field widths */
25414 if ( mp->job_name==NULL ) mp_open_log_file(mp);
25415 if ( mp->filename_template==0 ) {
25416 char *s; /* a file extension derived from |c| */
25420 @<Use |c| to compute the file extension |s|@>;
25421 mp_pack_job_name(mp, s);
25422 ss = mp->name_of_file ;
25423 } else { /* initializations */
25424 str_number s, n; /* a file extension derived from |c| */
25425 old_setting=mp->selector;
25426 mp->selector=new_string;
25428 i = mp->str_start[mp->filename_template];
25429 n = rts(""); /* initialize */
25430 while ( i<str_stop(mp->filename_template) ) {
25431 if ( mp->str_pool[i]=='%' ) {
25434 if ( i<str_stop(mp->filename_template) ) {
25435 if ( mp->str_pool[i]=='j' ) {
25436 mp_print(mp, mp->job_name);
25437 } else if ( mp->str_pool[i]=='d' ) {
25438 cc= mp_round_unscaled(mp, mp->internal[mp_day]);
25439 print_with_leading_zeroes(cc);
25440 } else if ( mp->str_pool[i]=='m' ) {
25441 cc= mp_round_unscaled(mp, mp->internal[mp_month]);
25442 print_with_leading_zeroes(cc);
25443 } else if ( mp->str_pool[i]=='y' ) {
25444 cc= mp_round_unscaled(mp, mp->internal[mp_year]);
25445 print_with_leading_zeroes(cc);
25446 } else if ( mp->str_pool[i]=='H' ) {
25447 cc= mp_round_unscaled(mp, mp->internal[mp_time]) / 60;
25448 print_with_leading_zeroes(cc);
25449 } else if ( mp->str_pool[i]=='M' ) {
25450 cc= mp_round_unscaled(mp, mp->internal[mp_time]) % 60;
25451 print_with_leading_zeroes(cc);
25452 } else if ( mp->str_pool[i]=='c' ) {
25453 if ( c<0 ) mp_print(mp, "ps");
25454 else print_with_leading_zeroes(c);
25455 } else if ( (mp->str_pool[i]>='0') &&
25456 (mp->str_pool[i]<='9') ) {
25458 f = (f*10) + mp->str_pool[i]-'0';
25461 mp_print_str(mp, mp->str_pool[i]);
25465 if ( mp->str_pool[i]=='.' )
25467 n = mp_make_string(mp);
25468 mp_print_str(mp, mp->str_pool[i]);
25472 s = mp_make_string(mp);
25473 mp->selector= old_setting;
25474 if (length(n)==0) {
25480 mp_pack_file_name(mp, nn,"",ss);
25488 char * mp_get_output_file_name (MP mp) {
25490 char *saved_name; /* saved |name_of_file| */
25491 saved_name = xstrdup(mp->name_of_file);
25492 f = xstrdup(mp_set_output_file_name(mp, mp_round_unscaled(mp, mp->internal[mp_char_code])));
25493 mp_pack_file_name(mp, saved_name,NULL,NULL);
25498 void mp_open_output_file (MP mp) {
25499 char *ss; /* filename extension proposal */
25500 integer c; /* \&{charcode} rounded to the nearest integer */
25501 c=mp_round_unscaled(mp, mp->internal[mp_char_code]);
25502 ss = mp_set_output_file_name(mp, c);
25503 while ( ! mp_a_open_out(mp, (void *)&mp->ps_file, mp_filetype_postscript) )
25504 mp_prompt_file_name(mp, "file name for output",ss);
25506 @<Store the true output file name if appropriate@>;
25509 @ The file extension created here could be up to five characters long in
25510 extreme cases so it may have to be shortened on some systems.
25511 @^system dependencies@>
25513 @<Use |c| to compute the file extension |s|@>=
25516 mp_snprintf(s,7,".%i",(int)c);
25519 @ The user won't want to see all the output file names so we only save the
25520 first and last ones and a count of how many there were. For this purpose
25521 files are ordered primarily by \&{charcode} and secondarily by order of
25523 @:char_code_}{\&{charcode} primitive@>
25525 @<Store the true output file name if appropriate@>=
25526 if ((c<mp->first_output_code)&&(mp->first_output_code>=0)) {
25527 mp->first_output_code=c;
25528 xfree(mp->first_file_name);
25529 mp->first_file_name=xstrdup(mp->name_of_file);
25531 if ( c>=mp->last_output_code ) {
25532 mp->last_output_code=c;
25533 xfree(mp->last_file_name);
25534 mp->last_file_name=xstrdup(mp->name_of_file);
25538 char * first_file_name;
25539 char * last_file_name; /* full file names */
25540 integer first_output_code;integer last_output_code; /* rounded \&{charcode} values */
25541 @:char_code_}{\&{charcode} primitive@>
25542 integer total_shipped; /* total number of |ship_out| operations completed */
25545 mp->first_file_name=xstrdup("");
25546 mp->last_file_name=xstrdup("");
25547 mp->first_output_code=32768;
25548 mp->last_output_code=-32768;
25549 mp->total_shipped=0;
25551 @ @<Dealloc variables@>=
25552 xfree(mp->first_file_name);
25553 xfree(mp->last_file_name);
25555 @ @<Begin the progress report for the output of picture~|c|@>=
25556 if ( (int)mp->term_offset>mp->max_print_line-6 ) mp_print_ln(mp);
25557 else if ( (mp->term_offset>0)||(mp->file_offset>0) ) mp_print_char(mp, ' ');
25558 mp_print_char(mp, '[');
25559 if ( c>=0 ) mp_print_int(mp, c)
25561 @ @<End progress report@>=
25562 mp_print_char(mp, ']');
25564 incr(mp->total_shipped)
25566 @ @<Explain what output files were written@>=
25567 if ( mp->total_shipped>0 ) {
25568 mp_print_nl(mp, "");
25569 mp_print_int(mp, mp->total_shipped);
25570 if (mp->noninteractive) {
25571 mp_print(mp, " figure");
25572 if ( mp->total_shipped>1 ) mp_print_char(mp, 's');
25573 mp_print(mp, " created.");
25575 mp_print(mp, " output file");
25576 if ( mp->total_shipped>1 ) mp_print_char(mp, 's');
25577 mp_print(mp, " written: ");
25578 mp_print(mp, mp->first_file_name);
25579 if ( mp->total_shipped>1 ) {
25580 if ( 31+strlen(mp->first_file_name)+
25581 strlen(mp->last_file_name)> (unsigned)mp->max_print_line)
25583 mp_print(mp, " .. ");
25584 mp_print(mp, mp->last_file_name);
25589 @ @<Internal library declarations@>=
25590 boolean mp_has_font_size(MP mp, font_number f );
25593 boolean mp_has_font_size(MP mp, font_number f ) {
25594 return (mp->font_sizes[f]!=null);
25597 @ The \&{special} command saves up lines of text to be printed during the next
25598 |ship_out| operation. The saved items are stored as a list of capsule tokens.
25601 pointer last_pending; /* the last token in a list of pending specials */
25604 mp->last_pending=spec_head;
25606 @ @<Cases of |do_statement|...@>=
25607 case special_command:
25608 if ( mp->cur_mod==0 ) mp_do_special(mp); else
25609 if ( mp->cur_mod==1 ) mp_do_mapfile(mp); else
25613 @ @<Declare action procedures for use by |do_statement|@>=
25614 void mp_do_special (MP mp) ;
25616 @ @c void mp_do_special (MP mp) {
25617 mp_get_x_next(mp); mp_scan_expression(mp);
25618 if ( mp->cur_type!=mp_string_type ) {
25619 @<Complain about improper special operation@>;
25621 link(mp->last_pending)=mp_stash_cur_exp(mp);
25622 mp->last_pending=link(mp->last_pending);
25623 link(mp->last_pending)=null;
25627 @ @<Complain about improper special operation@>=
25629 exp_err("Unsuitable expression");
25630 help1("Only known strings are allowed for output as specials.");
25631 mp_put_get_error(mp);
25634 @ On the export side, we need an extra object type for special strings.
25636 @<Graphical object codes@>=
25639 @ @<Export pending specials@>=
25641 while ( p!=null ) {
25642 mp_special_object *tp;
25643 tp = (mp_special_object *)mp_new_graphic_object(mp,mp_special_code);
25644 gr_pre_script(tp) = str(value(p));
25645 if (hh->body==NULL) hh->body = (mp_graphic_object *)tp;
25646 else gr_link(hp) = (mp_graphic_object *)tp;
25647 hp = (mp_graphic_object *)tp;
25650 mp_flush_token_list(mp, link(spec_head));
25651 link(spec_head)=null;
25652 mp->last_pending=spec_head
25654 @ We are now ready for the main output procedure. Note that the |selector|
25655 setting is saved in a global variable so that |begin_diagnostic| can access it.
25657 @<Declare the \ps\ output procedures@>=
25658 void mp_ship_out (MP mp, pointer h) ;
25660 @ Once again, the |gr_XXXX| macros are defined in |mppsout.h|
25662 @d export_color(q,p)
25663 if ( color_model(p)==mp_uninitialized_model ) {
25664 gr_color_model(q) = (mp->internal[mp_default_color_model]>>16);
25665 gr_cyan_val(q) = 0;
25666 gr_magenta_val(q) = 0;
25667 gr_yellow_val(q) = 0;
25668 gr_black_val(q) = (gr_color_model(q)==mp_cmyk_model ? unity : 0);
25670 gr_color_model(q) = color_model(p);
25671 gr_cyan_val(q) = cyan_val(p);
25672 gr_magenta_val(q) = magenta_val(p);
25673 gr_yellow_val(q) = yellow_val(p);
25674 gr_black_val(q) = black_val(p);
25677 @d export_scripts(q,p)
25678 if (pre_script(p)!=null) gr_pre_script(q) = str(pre_script(p));
25679 if (post_script(p)!=null) gr_post_script(q) = str(post_script(p));
25682 struct mp_edge_object *mp_gr_export(MP mp, pointer h) {
25683 pointer p; /* the current graphical object */
25684 integer t; /* a temporary value */
25685 integer c; /* a rounded charcode */
25686 scaled d_width; /* the current pen width */
25687 mp_edge_object *hh; /* the first graphical object */
25688 struct mp_graphic_object *hq; /* something |hp| points to */
25689 struct mp_text_object *tt;
25690 struct mp_fill_object *tf;
25691 struct mp_stroked_object *ts;
25692 struct mp_clip_object *tc;
25693 struct mp_bounds_object *tb;
25694 struct mp_graphic_object *hp = NULL; /* the current graphical object */
25695 mp_set_bbox(mp, h, true);
25696 hh = mp_xmalloc(mp,1,sizeof(mp_edge_object));
25700 hh->_minx = minx_val(h);
25701 hh->_miny = miny_val(h);
25702 hh->_maxx = maxx_val(h);
25703 hh->_maxy = maxy_val(h);
25704 hh->_filename = mp_get_output_file_name(mp);
25705 c = mp_round_unscaled(mp,mp->internal[mp_char_code]);
25707 hh->_width = mp->internal[mp_char_wd];
25708 hh->_height = mp->internal[mp_char_ht];
25709 hh->_depth = mp->internal[mp_char_dp];
25710 hh->_ital_corr = mp->internal[mp_char_ic];
25711 @<Export pending specials@>;
25712 p=link(dummy_loc(h));
25713 while ( p!=null ) {
25714 hq = mp_new_graphic_object(mp,type(p));
25717 tf = (mp_fill_object *)hq;
25718 gr_pen_p(tf) = mp_export_knot_list(mp,pen_p(p));
25719 d_width = mp_get_pen_scale(mp, pen_p(p));
25720 if ((pen_p(p)==null) || pen_is_elliptical(pen_p(p))) {
25721 gr_path_p(tf) = mp_export_knot_list(mp,path_p(p));
25724 pc = mp_copy_path(mp, path_p(p));
25725 pp = mp_make_envelope(mp, pc, pen_p(p),ljoin_val(p),0,miterlim_val(p));
25726 gr_path_p(tf) = mp_export_knot_list(mp,pp);
25727 mp_toss_knot_list(mp, pp);
25728 pc = mp_htap_ypoc(mp, path_p(p));
25729 pp = mp_make_envelope(mp, pc, pen_p(p),ljoin_val(p),0,miterlim_val(p));
25730 gr_htap_p(tf) = mp_export_knot_list(mp,pp);
25731 mp_toss_knot_list(mp, pp);
25733 export_color(tf,p) ;
25734 export_scripts(tf,p);
25735 gr_ljoin_val(tf) = ljoin_val(p);
25736 gr_miterlim_val(tf) = miterlim_val(p);
25738 case mp_stroked_code:
25739 ts = (mp_stroked_object *)hq;
25740 gr_pen_p(ts) = mp_export_knot_list(mp,pen_p(p));
25741 d_width = mp_get_pen_scale(mp, pen_p(p));
25742 if (pen_is_elliptical(pen_p(p))) {
25743 gr_path_p(ts) = mp_export_knot_list(mp,path_p(p));
25746 pc=mp_copy_path(mp, path_p(p));
25748 if ( left_type(pc)!=mp_endpoint ) {
25749 left_type(mp_insert_knot(mp, pc,x_coord(pc),y_coord(pc)))=mp_endpoint;
25750 right_type(pc)=mp_endpoint;
25754 pc=mp_make_envelope(mp,pc,pen_p(p),ljoin_val(p),t,miterlim_val(p));
25755 gr_path_p(ts) = mp_export_knot_list(mp,pc);
25756 mp_toss_knot_list(mp, pc);
25758 export_color(ts,p) ;
25759 export_scripts(ts,p);
25760 gr_ljoin_val(ts) = ljoin_val(p);
25761 gr_miterlim_val(ts) = miterlim_val(p);
25762 gr_lcap_val(ts) = lcap_val(p);
25763 gr_dash_p(ts) = mp_export_dashes(mp,p,&d_width);
25766 tt = (mp_text_object *)hq;
25767 gr_text_p(tt) = str(text_p(p));
25768 gr_font_n(tt) = font_n(p);
25769 gr_font_name(tt) = mp_xstrdup(mp,mp->font_name[font_n(p)]);
25770 gr_font_dsize(tt) = mp->font_dsize[font_n(p)];
25771 export_color(tt,p) ;
25772 export_scripts(tt,p);
25773 gr_width_val(tt) = width_val(p);
25774 gr_height_val(tt) = height_val(p);
25775 gr_depth_val(tt) = depth_val(p);
25776 gr_tx_val(tt) = tx_val(p);
25777 gr_ty_val(tt) = ty_val(p);
25778 gr_txx_val(tt) = txx_val(p);
25779 gr_txy_val(tt) = txy_val(p);
25780 gr_tyx_val(tt) = tyx_val(p);
25781 gr_tyy_val(tt) = tyy_val(p);
25783 case mp_start_clip_code:
25784 tc = (mp_clip_object *)hq;
25785 gr_path_p(tc) = mp_export_knot_list(mp,path_p(p));
25787 case mp_start_bounds_code:
25788 tb = (mp_bounds_object *)hq;
25789 gr_path_p(tb) = mp_export_knot_list(mp,path_p(p));
25791 case mp_stop_clip_code:
25792 case mp_stop_bounds_code:
25793 /* nothing to do here */
25796 if (hh->body==NULL) hh->body=hq; else gr_link(hp) = hq;
25803 @ @<Exported function ...@>=
25804 struct mp_edge_object *mp_gr_export(MP mp, int h);
25806 @ This function is now nearly trivial.
25809 void mp_ship_out (MP mp, pointer h) { /* output edge structure |h| */
25810 integer c; /* \&{charcode} rounded to the nearest integer */
25811 c=mp_round_unscaled(mp, mp->internal[mp_char_code]);
25812 @<Begin the progress report for the output of picture~|c|@>;
25813 (mp->shipout_backend) (mp, h);
25814 @<End progress report@>;
25815 if ( mp->internal[mp_tracing_output]>0 )
25816 mp_print_edges(mp, h," (just shipped out)",true);
25819 @ @<Declarations@>=
25820 void mp_shipout_backend (MP mp, pointer h);
25823 void mp_shipout_backend (MP mp, pointer h) {
25824 mp_edge_object *hh; /* the first graphical object */
25825 hh = mp_gr_export(mp,h);
25826 (void)mp_gr_ship_out (hh,
25827 (mp->internal[mp_prologues]>>16),
25828 (mp->internal[mp_procset]>>16),
25830 mp_gr_toss_objects(hh);
25833 @ @<Exported types@>=
25834 typedef void (*mp_backend_writer)(MP, int);
25836 @ @<Option variables@>=
25837 mp_backend_writer shipout_backend;
25839 @ Now that we've finished |ship_out|, let's look at the other commands
25840 by which a user can send things to the \.{GF} file.
25842 @ @<Determine if a character has been shipped out@>=
25844 mp->cur_exp=mp_round_unscaled(mp, mp->cur_exp) % 256;
25845 if ( mp->cur_exp<0 ) mp->cur_exp=mp->cur_exp+256;
25846 boolean_reset(mp->char_exists[mp->cur_exp]);
25847 mp->cur_type=mp_boolean_type;
25853 @ @<Allocate or initialize ...@>=
25854 mp_backend_initialize(mp);
25857 mp_backend_free(mp);
25860 @* \[45] Dumping and undumping the tables.
25861 After \.{INIMP} has seen a collection of macros, it
25862 can write all the necessary information on an auxiliary file so
25863 that production versions of \MP\ are able to initialize their
25864 memory at high speed. The present section of the program takes
25865 care of such output and input. We shall consider simultaneously
25866 the processes of storing and restoring,
25867 so that the inverse relation between them is clear.
25870 The global variable |mem_ident| is a string that is printed right
25871 after the |banner| line when \MP\ is ready to start. For \.{INIMP} this
25872 string says simply `\.{(INIMP)}'; for other versions of \MP\ it says,
25873 for example, `\.{(mem=plain 1990.4.14)}', showing the year,
25874 month, and day that the mem file was created. We have |mem_ident=0|
25875 before \MP's tables are loaded.
25881 mp->mem_ident=NULL;
25883 @ @<Initialize table entries...@>=
25884 mp->mem_ident=xstrdup(" (INIMP)");
25886 @ @<Declare act...@>=
25887 void mp_store_mem_file (MP mp) ;
25889 @ @c void mp_store_mem_file (MP mp) {
25890 integer k; /* all-purpose index */
25891 pointer p,q; /* all-purpose pointers */
25892 integer x; /* something to dump */
25893 four_quarters w; /* four ASCII codes */
25895 @<Create the |mem_ident|, open the mem file,
25896 and inform the user that dumping has begun@>;
25897 @<Dump constants for consistency check@>;
25898 @<Dump the string pool@>;
25899 @<Dump the dynamic memory@>;
25900 @<Dump the table of equivalents and the hash table@>;
25901 @<Dump a few more things and the closing check word@>;
25902 @<Close the mem file@>;
25905 @ Corresponding to the procedure that dumps a mem file, we also have a function
25906 that reads~one~in. The function returns |false| if the dumped mem is
25907 incompatible with the present \MP\ table sizes, etc.
25909 @d too_small(A) { wake_up_terminal;
25910 wterm_ln("---! Must increase the "); wterm((A));
25911 @.Must increase the x@>
25916 boolean mp_load_mem_file (MP mp) {
25917 integer k; /* all-purpose index */
25918 pointer p,q; /* all-purpose pointers */
25919 integer x; /* something undumped */
25920 str_number s; /* some temporary string */
25921 four_quarters w; /* four ASCII codes */
25923 /* |@<Undump constants for consistency check@>;| read earlier */
25924 @<Undump the string pool@>;
25925 @<Undump the dynamic memory@>;
25926 @<Undump the table of equivalents and the hash table@>;
25927 @<Undump a few more things and the closing check word@>;
25928 return true; /* it worked! */
25931 wterm_ln("(Fatal mem file error; I'm stymied)\n");
25932 @.Fatal mem file error@>
25936 @ @<Declarations@>=
25937 boolean mp_load_mem_file (MP mp) ;
25939 @ Mem files consist of |memory_word| items, and we use the following
25940 macros to dump words of different types:
25942 @d dump_wd(A) { WW=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
25943 @d dump_int(A) { int cint=(A); (mp->write_binary_file)(mp,mp->mem_file,&cint,sizeof(cint)); }
25944 @d dump_hh(A) { WW.hh=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
25945 @d dump_qqqq(A) { WW.qqqq=(A); (mp->write_binary_file)(mp,mp->mem_file,&WW,sizeof(WW)); }
25946 @d dump_string(A) { dump_int(strlen(A)+1);
25947 (mp->write_binary_file)(mp,mp->mem_file,A,strlen(A)+1); }
25950 void * mem_file; /* for input or output of mem information */
25952 @ The inverse macros are slightly more complicated, since we need to check
25953 the range of the values we are reading in. We say `|undump(a)(b)(x)|' to
25954 read an integer value |x| that is supposed to be in the range |a<=x<=b|.
25957 size_t wanted = sizeof(A);
25959 (mp->read_binary_file)(mp, mp->mem_file,&A_ptr,&wanted);
25960 if (wanted!=sizeof(A)) goto OFF_BASE;
25964 size_t wanted = sizeof(A);
25966 (mp->read_binary_file)(mp, mp->mem_file,&A_ptr,&wanted);
25967 if (wanted!=sizeof(A)) goto OFF_BASE;
25970 @d undump_wd(A) { mgetw(WW); A=WW; }
25971 @d undump_int(A) { int cint; mgeti(cint); A=cint; }
25972 @d undump_hh(A) { mgetw(WW); A=WW.hh; }
25973 @d undump_qqqq(A) { mgetw(WW); A=WW.qqqq; }
25974 @d undump_strings(A,B,C) {
25975 undump_int(x); if ( (x<(A)) || (x>(B)) ) goto OFF_BASE; else C=str(x); }
25976 @d undump(A,B,C) { undump_int(x); if ( (x<(A)) || (x>(int)(B)) ) goto OFF_BASE; else C=x; }
25977 @d undump_size(A,B,C,D) { undump_int(x);
25978 if (x<(A)) goto OFF_BASE;
25979 if (x>(B)) { too_small((C)); } else { D=x;} }
25980 @d undump_string(A) do {
25986 the_string = xmalloc(XX,sizeof(char));
25987 (mp->read_binary_file)(mp,mp->mem_file,&the_string,&the_wanted);
25988 A = (char *)the_string;
25989 if (the_wanted!=(size_t)XX) goto OFF_BASE;
25992 @ The next few sections of the program should make it clear how we use the
25993 dump/undump macros.
25995 @<Dump constants for consistency check@>=
25996 dump_int(mp->mem_top);
25997 dump_int(mp->hash_size);
25998 dump_int(mp->hash_prime)
25999 dump_int(mp->param_size);
26000 dump_int(mp->max_in_open);
26002 @ Sections of a \.{WEB} program that are ``commented out'' still contribute
26003 strings to the string pool; therefore \.{INIMP} and \MP\ will have
26004 the same strings. (And it is, of course, a good thing that they do.)
26008 @<Undump constants for consistency check@>=
26009 undump_int(x); mp->mem_top = x;
26010 undump_int(x); mp->hash_size = x;
26011 undump_int(x); mp->hash_prime = x;
26012 undump_int(x); mp->param_size = x;
26013 undump_int(x); mp->max_in_open = x;
26015 @ We do string pool compaction to avoid dumping unused strings.
26018 w.b0=qi(mp->str_pool[k]); w.b1=qi(mp->str_pool[k+1]);
26019 w.b2=qi(mp->str_pool[k+2]); w.b3=qi(mp->str_pool[k+3]);
26022 @<Dump the string pool@>=
26023 mp_do_compaction(mp, mp->pool_size);
26024 dump_int(mp->pool_ptr);
26025 dump_int(mp->max_str_ptr);
26026 dump_int(mp->str_ptr);
26028 while ( (mp->next_str[k]==k+1) && (k<=mp->max_str_ptr) )
26031 while ( k<=mp->max_str_ptr ) {
26032 dump_int(mp->next_str[k]); incr(k);
26036 dump_int(mp->str_start[k]); /* TODO: valgrind warning here */
26037 if ( k==mp->str_ptr ) {
26044 while (k+4<mp->pool_ptr ) {
26045 dump_four_ASCII; k=k+4;
26047 k=mp->pool_ptr-4; dump_four_ASCII;
26048 mp_print_ln(mp); mp_print(mp, "at most "); mp_print_int(mp, mp->max_str_ptr);
26049 mp_print(mp, " strings of total length ");
26050 mp_print_int(mp, mp->pool_ptr)
26052 @ @d undump_four_ASCII
26054 mp->str_pool[k]=qo(w.b0); mp->str_pool[k+1]=qo(w.b1);
26055 mp->str_pool[k+2]=qo(w.b2); mp->str_pool[k+3]=qo(w.b3)
26057 @<Undump the string pool@>=
26058 undump_int(mp->pool_ptr);
26059 mp_reallocate_pool(mp, mp->pool_ptr) ;
26060 undump_int(mp->max_str_ptr);
26061 mp_reallocate_strings (mp,mp->max_str_ptr) ;
26062 undump(0,mp->max_str_ptr,mp->str_ptr);
26063 undump(0,mp->max_str_ptr+1,s);
26064 for (k=0;k<=s-1;k++)
26065 mp->next_str[k]=k+1;
26066 for (k=s;k<=mp->max_str_ptr;k++)
26067 undump(s+1,mp->max_str_ptr+1,mp->next_str[k]);
26068 mp->fixed_str_use=0;
26071 undump(0,mp->pool_ptr,mp->str_start[k]);
26072 if ( k==mp->str_ptr ) break;
26073 mp->str_ref[k]=max_str_ref;
26074 incr(mp->fixed_str_use);
26075 mp->last_fixed_str=k; k=mp->next_str[k];
26078 while ( k+4<mp->pool_ptr ) {
26079 undump_four_ASCII; k=k+4;
26081 k=mp->pool_ptr-4; undump_four_ASCII;
26082 mp->init_str_use=mp->fixed_str_use; mp->init_pool_ptr=mp->pool_ptr;
26083 mp->max_pool_ptr=mp->pool_ptr;
26084 mp->strs_used_up=mp->fixed_str_use;
26085 mp->pool_in_use=mp->str_start[mp->str_ptr]; mp->strs_in_use=mp->fixed_str_use;
26086 mp->max_pl_used=mp->pool_in_use; mp->max_strs_used=mp->strs_in_use;
26087 mp->pact_count=0; mp->pact_chars=0; mp->pact_strs=0;
26089 @ By sorting the list of available spaces in the variable-size portion of
26090 |mem|, we are usually able to get by without having to dump very much
26091 of the dynamic memory.
26093 We recompute |var_used| and |dyn_used|, so that \.{INIMP} dumps valid
26094 information even when it has not been gathering statistics.
26096 @<Dump the dynamic memory@>=
26097 mp_sort_avail(mp); mp->var_used=0;
26098 dump_int(mp->lo_mem_max); dump_int(mp->rover);
26099 p=0; q=mp->rover; x=0;
26101 for (k=p;k<= q+1;k++)
26102 dump_wd(mp->mem[k]);
26103 x=x+q+2-p; mp->var_used=mp->var_used+q-p;
26104 p=q+node_size(q); q=rlink(q);
26105 } while (q!=mp->rover);
26106 mp->var_used=mp->var_used+mp->lo_mem_max-p;
26107 mp->dyn_used=mp->mem_end+1-mp->hi_mem_min;
26108 for (k=p;k<= mp->lo_mem_max;k++ )
26109 dump_wd(mp->mem[k]);
26110 x=x+mp->lo_mem_max+1-p;
26111 dump_int(mp->hi_mem_min); dump_int(mp->avail);
26112 for (k=mp->hi_mem_min;k<=mp->mem_end;k++ )
26113 dump_wd(mp->mem[k]);
26114 x=x+mp->mem_end+1-mp->hi_mem_min;
26116 while ( p!=null ) {
26117 decr(mp->dyn_used); p=link(p);
26119 dump_int(mp->var_used); dump_int(mp->dyn_used);
26120 mp_print_ln(mp); mp_print_int(mp, x);
26121 mp_print(mp, " memory locations dumped; current usage is ");
26122 mp_print_int(mp, mp->var_used); mp_print_char(mp, '&'); mp_print_int(mp, mp->dyn_used)
26124 @ @<Undump the dynamic memory@>=
26125 undump(lo_mem_stat_max+1000,hi_mem_stat_min-1,mp->lo_mem_max);
26126 undump(lo_mem_stat_max+1,mp->lo_mem_max,mp->rover);
26129 for (k=p;k<= q+1; k++)
26130 undump_wd(mp->mem[k]);
26132 if ( (p>mp->lo_mem_max)||((q>=rlink(q))&&(rlink(q)!=mp->rover)) )
26135 } while (q!=mp->rover);
26136 for (k=p;k<=mp->lo_mem_max;k++ )
26137 undump_wd(mp->mem[k]);
26138 undump(mp->lo_mem_max+1,hi_mem_stat_min,mp->hi_mem_min);
26139 undump(null,mp->mem_top,mp->avail); mp->mem_end=mp->mem_top;
26140 mp->last_pending=spec_head;
26141 for (k=mp->hi_mem_min;k<= mp->mem_end;k++)
26142 undump_wd(mp->mem[k]);
26143 undump_int(mp->var_used); undump_int(mp->dyn_used)
26145 @ A different scheme is used to compress the hash table, since its lower region
26146 is usually sparse. When |text(p)<>0| for |p<=hash_used|, we output three
26147 words: |p|, |hash[p]|, and |eqtb[p]|. The hash table is, of course, densely
26148 packed for |p>=hash_used|, so the remaining entries are output in~a~block.
26150 @<Dump the table of equivalents and the hash table@>=
26151 dump_int(mp->hash_used);
26152 mp->st_count=frozen_inaccessible-1-mp->hash_used;
26153 for (p=1;p<=mp->hash_used;p++) {
26154 if ( text(p)!=0 ) {
26155 dump_int(p); dump_hh(mp->hash[p]); dump_hh(mp->eqtb[p]); incr(mp->st_count);
26158 for (p=mp->hash_used+1;p<=(int)hash_end;p++) {
26159 dump_hh(mp->hash[p]); dump_hh(mp->eqtb[p]);
26161 dump_int(mp->st_count);
26162 mp_print_ln(mp); mp_print_int(mp, mp->st_count); mp_print(mp, " symbolic tokens")
26164 @ @<Undump the table of equivalents and the hash table@>=
26165 undump(1,frozen_inaccessible,mp->hash_used);
26168 undump(p+1,mp->hash_used,p);
26169 undump_hh(mp->hash[p]); undump_hh(mp->eqtb[p]);
26170 } while (p!=mp->hash_used);
26171 for (p=mp->hash_used+1;p<=(int)hash_end;p++ ) {
26172 undump_hh(mp->hash[p]); undump_hh(mp->eqtb[p]);
26174 undump_int(mp->st_count)
26176 @ We have already printed a lot of statistics, so we set |mp_tracing_stats:=0|
26177 to prevent them appearing again.
26179 @<Dump a few more things and the closing check word@>=
26180 dump_int(mp->max_internal);
26181 dump_int(mp->int_ptr);
26182 for (k=1;k<= mp->int_ptr;k++ ) {
26183 dump_int(mp->internal[k]);
26184 dump_string(mp->int_name[k]);
26186 dump_int(mp->start_sym);
26187 dump_int(mp->interaction);
26188 dump_string(mp->mem_ident);
26189 dump_int(mp->bg_loc); dump_int(mp->eg_loc); dump_int(mp->serial_no); dump_int(69073);
26190 mp->internal[mp_tracing_stats]=0
26192 @ @<Undump a few more things and the closing check word@>=
26194 if (x>mp->max_internal) mp_grow_internals(mp,x);
26195 undump_int(mp->int_ptr);
26196 for (k=1;k<= mp->int_ptr;k++) {
26197 undump_int(mp->internal[k]);
26198 undump_string(mp->int_name[k]);
26200 undump(0,frozen_inaccessible,mp->start_sym);
26201 if (mp->interaction==mp_unspecified_mode) {
26202 undump(mp_unspecified_mode,mp_error_stop_mode,mp->interaction);
26204 undump(mp_unspecified_mode,mp_error_stop_mode,x);
26206 undump_string(mp->mem_ident);
26207 undump(1,hash_end,mp->bg_loc);
26208 undump(1,hash_end,mp->eg_loc);
26209 undump_int(mp->serial_no);
26211 if (x!=69073) goto OFF_BASE
26213 @ @<Create the |mem_ident|...@>=
26215 xfree(mp->mem_ident);
26216 mp->mem_ident = xmalloc(256,1);
26217 char *tmp = xmalloc(11,1);
26218 sprintf(tmp,"%04d.%02d.%02d",
26219 (int)mp_round_unscaled(mp, mp->internal[mp_year]),
26220 (int)mp_round_unscaled(mp, mp->internal[mp_month]),
26221 (int)mp_round_unscaled(mp, mp->internal[mp_day]));
26222 mp_snprintf(mp->mem_ident,256," (mem=%s %s)",mp->job_name, tmp);
26224 mp_pack_job_name(mp, ".mem");
26225 while (! mp_w_open_out(mp, &mp->mem_file) )
26226 mp_prompt_file_name(mp, "mem file name", ".mem");
26227 mp_print_nl(mp, "Beginning to dump on file ");
26228 @.Beginning to dump...@>
26229 mp_print(mp, mp->name_of_file);
26230 mp_print_nl(mp, mp->mem_ident);
26233 @ @<Dealloc variables@>=
26234 xfree(mp->mem_ident);
26236 @ @<Close the mem file@>=
26237 (mp->close_file)(mp,mp->mem_file)
26239 @* \[46] The main program.
26240 This is it: the part of \MP\ that executes all those procedures we have
26243 Well---almost. We haven't put the parsing subroutines into the
26244 program yet; and we'd better leave space for a few more routines that may
26245 have been forgotten.
26247 @c @<Declare the basic parsing subroutines@>
26248 @<Declare miscellaneous procedures that were declared |forward|@>
26249 @<Last-minute procedures@>
26251 @ We've noted that there are two versions of \MP. One, called \.{INIMP},
26253 has to be run first; it initializes everything from scratch, without
26254 reading a mem file, and it has the capability of dumping a mem file.
26255 The other one is called `\.{VIRMP}'; it is a ``virgin'' program that needs
26257 to input a mem file in order to get started. \.{VIRMP} typically has
26258 a bit more memory capacity than \.{INIMP}, because it does not need the
26259 space consumed by the dumping/undumping routines and the numerous calls on
26262 The \.{VIRMP} program cannot read a mem file instantaneously, of course;
26263 the best implementations therefore allow for production versions of \MP\ that
26264 not only avoid the loading routine for object code, they also have
26265 a mem file pre-loaded.
26267 @ @<Option variables@>=
26268 int ini_version; /* are we iniMP? */
26270 @ @<Set |ini_version|@>=
26271 mp->ini_version = (opt->ini_version ? true : false);
26273 @ The code below make the final chosen hash size the next larger
26274 multiple of 2 from the requested size, and this array is a list of
26275 suitable prime numbers to go with such values.
26277 The top limit is chosen such that it is definately lower than
26278 |max_halfword-3*param_size|, because |param_size| cannot be larger
26279 than |max_halfword/sizeof(pointer)|.
26282 static int mp_prime_choices[] =
26283 { 12289, 24593, 49157, 98317,
26284 196613, 393241, 786433, 1572869,
26285 3145739, 6291469, 12582917, 25165843,
26286 50331653, 100663319 };
26288 @ @<Find constant sizes@>=
26289 if (mp->ini_version) {
26291 set_value(mp->mem_top,opt->main_memory,5000);
26292 mp->mem_max = mp->mem_top;
26293 set_value(mp->param_size,opt->param_size,150);
26294 set_value(mp->max_in_open,opt->max_in_open,10);
26295 if (opt->hash_size>0x8000000)
26296 opt->hash_size=0x8000000;
26297 set_value(mp->hash_size,(2*opt->hash_size-1),16384);
26298 mp->hash_size = mp->hash_size>>i;
26299 while (mp->hash_size>=2) {
26300 mp->hash_size /= 2;
26303 mp->hash_size = mp->hash_size << i;
26304 if (mp->hash_size>0x8000000)
26305 mp->hash_size=0x8000000;
26306 mp->hash_prime=mp_prime_choices[(i-14)];
26309 if (mp->command_line != NULL && *(mp->command_line) == '&') {
26311 char *cmd = mp->command_line+1;
26312 xfree(mp->mem_name); /* just in case */
26313 mp->mem_name = mp_xstrdup(mp,cmd);
26314 while (*cmd && *cmd!=' ') cmd++;
26315 if (*cmd==' ') *cmd++ = '\0';
26317 s = mp_xstrdup(mp,cmd);
26319 xfree(mp->command_line);
26320 mp->command_line = s;
26322 if (mp->mem_name == NULL) {
26323 mp->mem_name = mp_xstrdup(mp,"plain");
26325 if (mp_open_mem_file(mp)) {
26326 @<Undump constants for consistency check@>;
26327 set_value(mp->mem_max,opt->main_memory,mp->mem_top);
26331 wterm_ln("(Fatal mem file error; I'm stymied)\n");
26332 mp->history = mp_fatal_error_stop;
26338 @ Here we do whatever is needed to complete \MP's job gracefully on the
26339 local operating system. The code here might come into play after a fatal
26340 error; it must therefore consist entirely of ``safe'' operations that
26341 cannot produce error messages. For example, it would be a mistake to call
26342 |str_room| or |make_string| at this time, because a call on |overflow|
26343 might lead to an infinite loop.
26344 @^system dependencies@>
26346 This program doesn't bother to close the input files that may still be open.
26348 @ @<Last-minute...@>=
26349 void mp_close_files_and_terminate (MP mp) {
26350 integer k; /* all-purpose index */
26351 integer LH; /* the length of the \.{TFM} header, in words */
26352 int lk_offset; /* extra words inserted at beginning of |lig_kern| array */
26353 pointer p; /* runs through a list of \.{TFM} dimensions */
26354 @<Close all open files in the |rd_file| and |wr_file| arrays@>;
26355 if ( mp->internal[mp_tracing_stats]>0 )
26356 @<Output statistics about this job@>;
26358 @<Do all the finishing work on the \.{TFM} file@>;
26359 @<Explain what output files were written@>;
26360 if ( mp->log_opened && ! mp->noninteractive ){
26362 (mp->close_file)(mp,mp->log_file);
26363 mp->selector=mp->selector-2;
26364 if ( mp->selector==term_only ) {
26365 mp_print_nl(mp, "Transcript written on ");
26366 @.Transcript written...@>
26367 mp_print(mp, mp->log_name); mp_print_char(mp, '.');
26371 mp->finished = true;
26374 @ @<Declarations@>=
26375 void mp_close_files_and_terminate (MP mp) ;
26377 @ @<Close all open files in the |rd_file| and |wr_file| arrays@>=
26378 if (mp->rd_fname!=NULL) {
26379 for (k=0;k<=(int)mp->read_files-1;k++ ) {
26380 if ( mp->rd_fname[k]!=NULL ) {
26381 (mp->close_file)(mp,mp->rd_file[k]);
26382 xfree(mp->rd_fname[k]);
26386 if (mp->wr_fname!=NULL) {
26387 for (k=0;k<=(int)mp->write_files-1;k++) {
26388 if ( mp->wr_fname[k]!=NULL ) {
26389 (mp->close_file)(mp,mp->wr_file[k]);
26390 xfree(mp->wr_fname[k]);
26396 for (k=0;k<(int)mp->max_read_files;k++ ) {
26397 if ( mp->rd_fname[k]!=NULL ) {
26398 (mp->close_file)(mp,mp->rd_file[k]);
26399 xfree(mp->rd_fname[k]);
26402 xfree(mp->rd_file);
26403 xfree(mp->rd_fname);
26404 for (k=0;k<(int)mp->max_write_files;k++) {
26405 if ( mp->wr_fname[k]!=NULL ) {
26406 (mp->close_file)(mp,mp->wr_file[k]);
26407 xfree(mp->wr_fname[k]);
26410 xfree(mp->wr_file);
26411 xfree(mp->wr_fname);
26414 @ We want to produce a \.{TFM} file if and only if |mp_fontmaking| is positive.
26416 We reclaim all of the variable-size memory at this point, so that
26417 there is no chance of another memory overflow after the memory capacity
26418 has already been exceeded.
26420 @<Do all the finishing work on the \.{TFM} file@>=
26421 if ( mp->internal[mp_fontmaking]>0 ) {
26422 @<Make the dynamic memory into one big available node@>;
26423 @<Massage the \.{TFM} widths@>;
26424 mp_fix_design_size(mp); mp_fix_check_sum(mp);
26425 @<Massage the \.{TFM} heights, depths, and italic corrections@>;
26426 mp->internal[mp_fontmaking]=0; /* avoid loop in case of fatal error */
26427 @<Finish the \.{TFM} file@>;
26430 @ @<Make the dynamic memory into one big available node@>=
26431 mp->rover=lo_mem_stat_max+1; link(mp->rover)=empty_flag; mp->lo_mem_max=mp->hi_mem_min-1;
26432 if ( mp->lo_mem_max-mp->rover>max_halfword ) mp->lo_mem_max=max_halfword+mp->rover;
26433 node_size(mp->rover)=mp->lo_mem_max-mp->rover;
26434 llink(mp->rover)=mp->rover; rlink(mp->rover)=mp->rover;
26435 link(mp->lo_mem_max)=null; info(mp->lo_mem_max)=null
26437 @ The present section goes directly to the log file instead of using
26438 |print| commands, because there's no need for these strings to take
26439 up |str_pool| memory when a non-{\bf stat} version of \MP\ is being used.
26441 @<Output statistics...@>=
26442 if ( mp->log_opened ) {
26445 wlog_ln("Here is how much of MetaPost's memory you used:");
26446 @.Here is how much...@>
26447 mp_snprintf(s,128," %i string%s out of %i",(int)mp->max_strs_used-mp->init_str_use,
26448 (mp->max_strs_used!=mp->init_str_use+1 ? "s" : ""),
26449 (int)(mp->max_strings-1-mp->init_str_use));
26451 mp_snprintf(s,128," %i string characters out of %i",
26452 (int)mp->max_pl_used-mp->init_pool_ptr,
26453 (int)mp->pool_size-mp->init_pool_ptr);
26455 mp_snprintf(s,128," %i words of memory out of %i",
26456 (int)mp->lo_mem_max+mp->mem_end-mp->hi_mem_min+2,
26459 mp_snprintf(s,128," %i symbolic tokens out of %i", (int)mp->st_count, (int)mp->hash_size);
26461 mp_snprintf(s,128," %ii,%in,%ip,%ib stack positions out of %ii,%in,%ip,%ib",
26462 (int)mp->max_in_stack,(int)mp->int_ptr,
26463 (int)mp->max_param_stack,(int)mp->max_buf_stack+1,
26464 (int)mp->stack_size,(int)mp->max_internal,(int)mp->param_size,(int)mp->buf_size);
26466 mp_snprintf(s,128," %i string compactions (moved %i characters, %i strings)",
26467 (int)mp->pact_count,(int)mp->pact_chars,(int)mp->pact_strs);
26471 @ It is nice to have have some of the stats available from the API.
26473 @<Exported function ...@>=
26474 int mp_memory_usage (MP mp );
26475 int mp_hash_usage (MP mp );
26476 int mp_param_usage (MP mp );
26477 int mp_open_usage (MP mp );
26480 int mp_memory_usage (MP mp ) {
26481 return (int)mp->lo_mem_max+mp->mem_end-mp->hi_mem_min+2;
26483 int mp_hash_usage (MP mp ) {
26484 return (int)mp->st_count;
26486 int mp_param_usage (MP mp ) {
26487 return (int)mp->max_param_stack;
26489 int mp_open_usage (MP mp ) {
26490 return (int)mp->max_in_stack;
26493 @ We get to the |final_cleanup| routine when \&{end} or \&{dump} has
26496 @<Last-minute...@>=
26497 void mp_final_cleanup (MP mp) {
26498 small_number c; /* 0 for \&{end}, 1 for \&{dump} */
26500 if ( mp->job_name==NULL ) mp_open_log_file(mp);
26501 while ( mp->input_ptr>0 ) {
26502 if ( token_state ) mp_end_token_list(mp);
26503 else mp_end_file_reading(mp);
26505 while ( mp->loop_ptr!=null ) mp_stop_iteration(mp);
26506 while ( mp->open_parens>0 ) {
26507 mp_print(mp, " )"); decr(mp->open_parens);
26509 while ( mp->cond_ptr!=null ) {
26510 mp_print_nl(mp, "(end occurred when ");
26511 @.end occurred...@>
26512 mp_print_cmd_mod(mp, fi_or_else,mp->cur_if);
26513 /* `\.{if}' or `\.{elseif}' or `\.{else}' */
26514 if ( mp->if_line!=0 ) {
26515 mp_print(mp, " on line "); mp_print_int(mp, mp->if_line);
26517 mp_print(mp, " was incomplete)");
26518 mp->if_line=if_line_field(mp->cond_ptr);
26519 mp->cur_if=name_type(mp->cond_ptr); mp->cond_ptr=link(mp->cond_ptr);
26521 if ( mp->history!=mp_spotless )
26522 if ( ((mp->history==mp_warning_issued)||(mp->interaction<mp_error_stop_mode)) )
26523 if ( mp->selector==term_and_log ) {
26524 mp->selector=term_only;
26525 mp_print_nl(mp, "(see the transcript file for additional information)");
26526 @.see the transcript file...@>
26527 mp->selector=term_and_log;
26530 if (mp->ini_version) {
26531 mp_store_mem_file(mp); return;
26533 mp_print_nl(mp, "(dump is performed only by INIMP)"); return;
26534 @.dump...only by INIMP@>
26538 @ @<Declarations@>=
26539 void mp_final_cleanup (MP mp) ;
26540 void mp_init_prim (MP mp) ;
26541 void mp_init_tab (MP mp) ;
26543 @ @<Last-minute...@>=
26544 void mp_init_prim (MP mp) { /* initialize all the primitives */
26548 void mp_init_tab (MP mp) { /* initialize other tables */
26549 integer k; /* all-purpose index */
26550 @<Initialize table entries (done by \.{INIMP} only)@>;
26554 @ When we begin the following code, \MP's tables may still contain garbage;
26555 thus we must proceed cautiously to get bootstrapped in.
26557 But when we finish this part of the program, \MP\ is ready to call on the
26558 |main_control| routine to do its work.
26560 @<Get the first line...@>=
26562 @<Initialize the input routines@>;
26563 if (mp->mem_ident==NULL) {
26564 if ( ! mp_load_mem_file(mp) ) {
26565 (mp->close_file)(mp, mp->mem_file);
26566 mp->history = mp_fatal_error_stop;
26569 (mp->close_file)(mp, mp->mem_file);
26571 @<Initializations following first line@>;
26574 @ @<Initializations following first line@>=
26575 mp->buffer[limit]='%';
26576 mp_fix_date_and_time(mp);
26577 if (mp->random_seed==0)
26578 mp->random_seed = (mp->internal[mp_time] / unity)+mp->internal[mp_day];
26579 mp_init_randoms(mp, mp->random_seed);
26580 @<Initialize the print |selector|...@>;
26581 if ( loc<limit ) if ( mp->buffer[loc]!='\\' )
26582 mp_start_input(mp); /* \&{input} assumed */
26584 @ @<Run inimpost commands@>=
26586 mp_get_strings_started(mp);
26587 mp_init_tab(mp); /* initialize the tables */
26588 mp_init_prim(mp); /* call |primitive| for each primitive */
26589 mp->init_str_use=mp->str_ptr; mp->init_pool_ptr=mp->pool_ptr;
26590 mp->max_str_ptr=mp->str_ptr; mp->max_pool_ptr=mp->pool_ptr;
26591 mp_fix_date_and_time(mp);
26594 @ Saving the filename template
26596 @<Save the filename template@>=
26598 if ( mp->filename_template!=0 ) delete_str_ref(mp->filename_template);
26599 if ( length(mp->cur_exp)==0 ) mp->filename_template=0;
26601 mp->filename_template=mp->cur_exp; add_str_ref(mp->filename_template);
26605 @* \[47] Debugging.
26608 @* \[48] System-dependent changes.
26609 This section should be replaced, if necessary, by any special
26610 modification of the program
26611 that are necessary to make \MP\ work at a particular installation.
26612 It is usually best to design your change file so that all changes to
26613 previous sections preserve the section numbering; then everybody's version
26614 will be consistent with the published program. More extensive changes,
26615 which introduce new sections, can be inserted here; then only the index
26616 itself will get a new section number.
26617 @^system dependencies@>
26620 Here is where you can find all uses of each identifier in the program,
26621 with underlined entries pointing to where the identifier was defined.
26622 If the identifier is only one letter long, however, you get to see only
26623 the underlined entries. {\sl All references are to section numbers instead of
26626 This index also lists error messages and other aspects of the program
26627 that you might want to look up some day. For example, the entry
26628 for ``system dependencies'' lists all sections that should receive
26629 special attention from people who are installing \MP\ in a new
26630 operating environment. A list of various things that can't happen appears
26631 under ``this can't happen''.
26632 Approximately 25 sections are listed under ``inner loop''; these account
26633 for more than 60\pct! of \MP's running time, exclusive of input and output.