1 % $Id
: mp.w
2037 2014-09-02 14:59:07Z luigi $
3 % This file is part of MetaPost
;
4 % the MetaPost program is in the public domain.
5 % See the
<Show version...
> code in mpost.w for more info.
7 % Here is TeX material that gets inserted after \input webmac
8 \def\hang
{\hangindent
3em\noindent\ignorespaces
}
9 \def\textindent#
1{\hangindent2.5em\noindent\hbox to2.5em
{\hss#
1 }\ignorespaces
}
11 \def\psqrt#
1{\sqrt
{\mathstrut#
1}}
13 \def\pct
!{{\char`\
%}} % percent sign in ordinary text
14 \font\tenlogo
=logo10
% font used for the METAFONT logo
16 \def\MF
{{\tenlogo META
}\
-{\tenlogo
FONT}}
17 \def\MP
{{\tenlogo META
}\
-{\tenlogo POST
}}
18 \def\
<#
1>{$\langle#
1\rangle$
}
19 \def\section
{\mathhexbox278
}
20 \let\swap
=\leftrightarrow
21 \def\round
{\mathop
{\rm round
}\nolimits
}
22 \mathchardef\vbv
="026A % synonym for `\|'
23 \def\vb{\relax\ifmmode\vbv\else$\vbv$\fi}
25 \def\(#1){} % this is used to make section names sort themselves better
26 \def\9#1{} % this is used for sort keys in the index via @@:sort key}{entry@@>
33 This is \MP\ by John Hobby, a graphics-language processor based on D. E. Knuth's \MF.
35 Much of the original Pascal version of this program was copied with
36 permission from MF.web Version 1.9. It interprets a language very
37 similar to D.E. Knuth's METAFONT, but with changes designed to make it
38 more suitable for PostScript output.
40 The main purpose of the following program is to explain the algorithms of \MP\
41 as clearly as possible. However, the program has been written so that it
42 can be tuned to run efficiently in a wide variety of operating environments
43 by making comparatively few changes. Such flexibility is possible because
44 the documentation that follows is written in the \.{WEB} language, which is
45 at a higher level than C.
47 A large piece of software like \MP\ has inherent complexity that cannot
48 be reduced below a certain level of difficulty, although each individual
49 part is fairly simple by itself. The \.{WEB} language is intended to make
50 the algorithms as readable as possible, by reflecting the way the
51 individual program pieces fit together and by providing the
52 cross-references that connect different parts. Detailed comments about
53 what is going on, and about why things were done in certain ways, have
54 been liberally sprinkled throughout the program. These comments explain
55 features of the implementation, but they rarely attempt to explain the
56 \MP\ language itself, since the reader is supposed to be familiar with
57 {\sl The {\logos METAFONT\/}book} as well as the manual
59 @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
60 {\sl A User's Manual for MetaPost}, Computing Science Technical Report 162,
61 AT\AM T Bell Laboratories.
63 @ The present implementation is a preliminary version, but the possibilities
64 for new features are limited by the desire to remain as nearly compatible
65 with \MF\ as possible.
67 On the other hand, the \.{WEB} description can be extended without changing
68 the core of the program, and it has been designed so that such
69 extensions are not extremely difficult to make.
70 The |banner| string defined here should be changed whenever \MP\
71 undergoes any modifications, so that it will be clear which version of
72 \MP\ might be the guilty party when a problem arises.
74 @^system dependencies@>
76 @d default_banner "This is MetaPost
, Version
1.999" /* printed when \MP\ starts */
80 @<Metapost version header@>=
81 #define metapost_version "1.999"
83 @ The external library header for \MP\ is |mplib.h|. It contains a
84 few typedefs and the header defintions for the externally used
87 The most important of the typedefs is the definition of the structure
88 |MP_options|, that acts as a small, configurable front-end to the fairly
89 large |MP_instance| structure.
98 @<Metapost version header@>
99 typedef struct MP_instance *MP;
101 typedef struct MP_options {
104 @<Exported function headers@>
105 @<MPlib header stuff@>
108 @ The internal header file is much longer: it not only lists the complete
109 |MP_instance|, but also a lot of functions that have to be available to
110 the \ps\ backend, that is defined in a separate \.{WEB} file.
112 The variables from |MP_options| are included inside the |MP_instance|
121 typedef struct psout_data_struct *psout_data;
122 typedef struct svgout_data_struct *svgout_data;
123 typedef struct pngout_data_struct *pngout_data;
131 @<Enumeration types@>;
132 @<Types in the outer block@>;
133 @<Constants in the outer block@>;
134 typedef struct MP_instance {
138 @<Internal library declarations@>
139 @<MPlib internal header stuff@>
143 #define KPATHSEA_DEBUG_H 1
144 #include <w2c/config.h>
152 # include <unistd.h> /* for access */
154 #include <time.h> /* for struct tm \& co */
155 #include <zlib.h> /* for |ZLIB_VERSION|, zlibVersion() */
156 #include <png.h> /* for |PNG_LIBPNG_VER_STRING|, |png_libpng_ver| */
157 #include <pixman.h> /* for |PIXMAN_VERSION_STRING|, |pixman_version_string()| */
158 #include <cairo.h> /* for |CAIRO_VERSION_STRING|, |cairo_version_string()| */
159 #include <gmp.h> /* for |gmp_version| */
160 #include <mpfr.h> /* for |MPFR_VERSION_STRING|, |mpfr_get_version()| */
162 #include "mplibps.h
" /* external header */
163 #include "mplibsvg.h
" /* external header */
164 #include "mplibpng.h
" /* external header */
165 #include "mpmp.h
" /* internal header */
166 #include "mppsout.h
" /* internal header */
167 #include "mpsvgout.h
" /* internal header */
168 #include "mppngout.h
" /* internal header */
169 #include "mpmath.h
" /* internal header */
170 #include "mpmathdouble.h
" /* internal header */
171 #include "mpmathdecimal.h
" /* internal header */
172 #include "mpmathbinary.h
" /* internal header */
173 #include "mpstrings.h
" /* internal header */
174 extern font_number mp_read_font_info (MP mp, char *fname); /* tfmin.w */
176 @<Basic printing procedures@>;
177 @<Error handling procedures@>
179 @ Some debugging support for development. The trick with the variadic macros
180 probably only works in gcc, as this preprocessor feature was not formalized
181 until the c99 standard (and that is too new for us). Lets' hope that at least
182 most compilers understand the non-debug version.
183 @^system dependencies@>
185 @<MPlib internal header stuff@>=
188 #define debug_number(A) printf("%d
: %s
=%.32f
(%d
)\n
", __LINE__, #A, number_to_double(A), number_to_scaled(A))
190 #define debug_number(A)
193 void do_debug_printf(MP mp, const char *prefix, const char *fmt, ...);
194 # define debug_printf(a1,a2,a3) do_debug_printf(mp, "", a1,a2,a3)
195 # define FUNCTION_TRACE1(a1) do_debug_printf(mp, "FTRACE
: ", a1)
196 # define FUNCTION_TRACE2(a1,a2) do_debug_printf(mp, "FTRACE
: ", a1,a2)
197 # define FUNCTION_TRACE3(a1,a2,a3) do_debug_printf(mp, "FTRACE
: ", a1,a2,a3)
198 # define FUNCTION_TRACE3X(a1,a2,a3) (void)mp
199 # define FUNCTION_TRACE4(a1,a2,a3,a4) do_debug_printf(mp, "FTRACE
: ", a1,a2,a3,a4)
201 # define debug_printf(a1,a2,a3)
202 # define FUNCTION_TRACE1(a1) (void)mp
203 # define FUNCTION_TRACE2(a1,a2) (void)mp
204 # define FUNCTION_TRACE3(a1,a2,a3) (void)mp
205 # define FUNCTION_TRACE3X(a1,a2,a3) (void)mp
206 # define FUNCTION_TRACE4(a1,a2,a3,a4) (void)mp
209 @ This function occasionally crashes (if something is written after the
210 log file is already closed), but that is not so important while debugging.
214 void do_debug_printf(MP mp, const char *prefix, const char *fmt, ...) ;
215 void do_debug_printf(MP mp, const char *prefix, const char *fmt, ...) {
219 if (mp->log_file && !ferror((FILE *)mp->log_file)) {
220 fputs(prefix, mp->log_file);
221 vfprintf(mp->log_file, fmt, ap);
227 if (mp->term_out && !ferror((FILE *)mp->term_out)) {
231 fputs(prefix, mp->term_out);
232 vfprintf(mp->term_out, fmt, ap);
234 fputs(prefix, stdout);
235 vfprintf(stdout, fmt, ap);
241 @ Here are the functions that set up the \MP\ instance.
244 MP_options *mp_options (void);
245 MP mp_initialize (MP_options * opt);
248 MP_options *mp_options (void) {
250 size_t l = sizeof (MP_options);
259 @ @<Internal library declarations@>=
260 @<Declare subroutines for parsing file names@>
263 @ The whole instance structure is initialized with zeroes,
264 this greatly reduces the number of statements needed in
265 the |Allocate or initialize variables| block.
267 @d set_callback_option(A) do { mp->A = mp_##A;
268 if (opt->A!=NULL) mp->A = opt->A;
272 static MP mp_do_new (jmp_buf * buf) {
273 MP mp = malloc (sizeof (MP_instance));
278 memset (mp, 0, sizeof (MP_instance));
285 static void mp_free (MP mp) {
286 int k; /* loop variable */
287 @<Dealloc variables@>;
288 if (mp->noninteractive) {
289 @<Finish non-interactive use@>;
291 xfree (mp->jump_buf);
292 @<Free table entries@>;
299 static void mp_do_initialize (MP mp) {
300 @<Local variables for initialization@>;
301 @<Set initial values of key variables@>;
304 @ For the retargetable math library, we need to have a pointer, at least.
306 @<Global variables@>=
309 @ @<Exported types@>=
324 typedef struct mp_number_data {
325 mp_number_store data;
328 typedef struct mp_number_data mp_number;
329 #define is_number(A) ((A).type != mp_nan_type)
331 typedef void (*convert_func) (mp_number *r);
332 typedef void (*m_log_func) (MP mp, mp_number *r, mp_number a);
333 typedef void (*m_exp_func) (MP mp, mp_number *r, mp_number a);
334 typedef void (*pyth_add_func) (MP mp, mp_number *r, mp_number a, mp_number b);
335 typedef void (*pyth_sub_func) (MP mp, mp_number *r, mp_number a, mp_number b);
336 typedef void (*n_arg_func) (MP mp, mp_number *r, mp_number a, mp_number b);
337 typedef void (*velocity_func) (MP mp, mp_number *r, mp_number a, mp_number b, mp_number c, mp_number d, mp_number e);
338 typedef void (*ab_vs_cd_func) (MP mp, mp_number *r, mp_number a, mp_number b, mp_number c, mp_number d);
339 typedef void (*crossing_point_func) (MP mp, mp_number *r, mp_number a, mp_number b, mp_number c);
340 typedef void (*number_from_int_func) (mp_number *A, int B);
341 typedef void (*number_from_boolean_func) (mp_number *A, int B);
342 typedef void (*number_from_scaled_func) (mp_number *A, int B);
343 typedef void (*number_from_double_func) (mp_number *A, double B);
344 typedef void (*number_from_addition_func) (mp_number *A, mp_number B, mp_number C);
345 typedef void (*number_from_substraction_func) (mp_number *A, mp_number B, mp_number C);
346 typedef void (*number_from_div_func) (mp_number *A, mp_number B, mp_number C);
347 typedef void (*number_from_mul_func) (mp_number *A, mp_number B, mp_number C);
348 typedef void (*number_from_int_div_func) (mp_number *A, mp_number B, int C);
349 typedef void (*number_from_int_mul_func) (mp_number *A, mp_number B, int C);
350 typedef void (*number_from_oftheway_func) (MP mp, mp_number *A, mp_number t, mp_number B, mp_number C);
351 typedef void (*number_negate_func) (mp_number *A);
352 typedef void (*number_add_func) (mp_number *A, mp_number B);
353 typedef void (*number_substract_func) (mp_number *A, mp_number B);
354 typedef void (*number_modulo_func) (mp_number *A, mp_number B);
355 typedef void (*number_half_func) (mp_number *A);
356 typedef void (*number_halfp_func) (mp_number *A);
357 typedef void (*number_double_func) (mp_number *A);
358 typedef void (*number_abs_func) (mp_number *A);
359 typedef void (*number_clone_func) (mp_number *A, mp_number B);
360 typedef void (*number_swap_func) (mp_number *A, mp_number *B);
361 typedef void (*number_add_scaled_func) (mp_number *A, int b);
362 typedef void (*number_multiply_int_func) (mp_number *A, int b);
363 typedef void (*number_divide_int_func) (mp_number *A, int b);
364 typedef int (*number_to_int_func) (mp_number A);
365 typedef int (*number_to_boolean_func) (mp_number A);
366 typedef int (*number_to_scaled_func) (mp_number A);
367 typedef int (*number_round_func) (mp_number A);
368 typedef void (*number_floor_func) (mp_number *A);
369 typedef double (*number_to_double_func) (mp_number A);
370 typedef int (*number_odd_func) (mp_number A);
371 typedef int (*number_equal_func) (mp_number A, mp_number B);
372 typedef int (*number_less_func) (mp_number A, mp_number B);
373 typedef int (*number_greater_func) (mp_number A, mp_number B);
374 typedef int (*number_nonequalabs_func) (mp_number A, mp_number B);
375 typedef void (*make_scaled_func) (MP mp, mp_number *ret, mp_number A, mp_number B);
376 typedef void (*make_fraction_func) (MP mp, mp_number *ret, mp_number A, mp_number B);
377 typedef void (*take_fraction_func) (MP mp, mp_number *ret, mp_number A, mp_number B);
378 typedef void (*take_scaled_func) (MP mp, mp_number *ret, mp_number A, mp_number B);
379 typedef void (*sin_cos_func) (MP mp, mp_number A, mp_number *S, mp_number *C);
380 typedef void (*slow_add_func) (MP mp, mp_number *A, mp_number S, mp_number C);
381 typedef void (*sqrt_func) (MP mp, mp_number *ret, mp_number A);
382 typedef void (*init_randoms_func) (MP mp, int seed);
383 typedef void (*new_number_func) (MP mp, mp_number *A, mp_number_type t);
384 typedef void (*free_number_func) (MP mp, mp_number *n);
385 typedef void (*fraction_to_round_scaled_func) (mp_number *n);
386 typedef void (*print_func) (MP mp, mp_number A);
387 typedef char * (*tostring_func) (MP mp, mp_number A);
388 typedef void (*scan_func) (MP mp, int A);
389 typedef void (*mp_free_func) (MP mp);
390 typedef void (*set_precision_func) (MP mp);
392 typedef struct math_data {
393 mp_number precision_default;
394 mp_number precision_max;
395 mp_number precision_min;
398 mp_number one_third_inf_t;
403 mp_number half_unit_t;
404 mp_number three_quarter_unit_t;
405 mp_number fraction_one_t;
406 mp_number fraction_half_t;
407 mp_number fraction_three_t;
408 mp_number fraction_four_t;
409 mp_number one_eighty_deg_t;
410 mp_number three_sixty_deg_t;
412 mp_number sqrt_8_e_k;
413 mp_number twelve_ln_2_k;
414 mp_number coef_bound_k;
415 mp_number coef_bound_minus_1;
416 mp_number twelvebits_3;
418 mp_number twentysixbits_sqrt2_t;
419 mp_number twentyeightbits_d_t;
420 mp_number twentysevenbits_sqrt2_d_t;
421 mp_number fraction_threshold_t;
422 mp_number half_fraction_threshold_t;
423 mp_number scaled_threshold_t;
424 mp_number half_scaled_threshold_t;
425 mp_number near_zero_angle_t;
426 mp_number p_over_v_threshold_t;
427 mp_number equation_threshold_t;
428 mp_number tfm_warn_threshold_t;
429 mp_number warning_limit_t;
430 new_number_func allocate;
431 free_number_func free;
432 number_from_int_func from_int;
433 number_from_boolean_func from_boolean;
434 number_from_scaled_func from_scaled;
435 number_from_double_func from_double;
436 number_from_addition_func from_addition;
437 number_from_substraction_func from_substraction;
438 number_from_div_func from_div;
439 number_from_mul_func from_mul;
440 number_from_int_div_func from_int_div;
441 number_from_int_mul_func from_int_mul;
442 number_from_oftheway_func from_oftheway;
443 number_negate_func negate;
445 number_substract_func substract;
446 number_half_func half;
447 number_modulo_func modulo;
448 number_halfp_func halfp;
449 number_double_func do_double;
451 number_clone_func clone;
452 number_swap_func swap;
453 number_add_scaled_func add_scaled;
454 number_multiply_int_func multiply_int;
455 number_divide_int_func divide_int;
456 number_to_int_func to_int;
457 number_to_boolean_func to_boolean;
458 number_to_scaled_func to_scaled;
459 number_to_double_func to_double;
461 number_equal_func equal;
462 number_less_func less;
463 number_greater_func greater;
464 number_nonequalabs_func nonequalabs;
465 number_round_func round_unscaled;
466 number_floor_func floor_scaled;
467 make_scaled_func make_scaled;
468 make_fraction_func make_fraction;
469 take_fraction_func take_fraction;
470 take_scaled_func take_scaled;
471 velocity_func velocity;
472 ab_vs_cd_func ab_vs_cd;
473 crossing_point_func crossing_point;
477 pyth_add_func pyth_add;
478 pyth_sub_func pyth_sub;
479 fraction_to_round_scaled_func fraction_to_round_scaled;
480 convert_func fraction_to_scaled;
481 convert_func scaled_to_fraction;
482 convert_func scaled_to_angle;
483 convert_func angle_to_scaled;
484 init_randoms_func init_randoms;
485 sin_cos_func sin_cos;
487 slow_add_func slow_add;
489 tostring_func tostring;
490 scan_func scan_numeric;
491 scan_func scan_fractional;
492 mp_free_func free_math;
493 set_precision_func set_precision;
498 @ This procedure gets things started properly.
500 MP mp_initialize (MP_options * opt) {
502 jmp_buf *buf = malloc (sizeof (jmp_buf));
503 if (buf == NULL || setjmp (*buf) != 0)
505 mp = mp_do_new (buf);
508 mp->userdata = opt->userdata;
509 mp->noninteractive = opt->noninteractive;
510 set_callback_option (find_file);
511 set_callback_option (open_file);
512 set_callback_option (read_ascii_file);
513 set_callback_option (read_binary_file);
514 set_callback_option (close_file);
515 set_callback_option (eof_file);
516 set_callback_option (flush_file);
517 set_callback_option (write_ascii_file);
518 set_callback_option (write_binary_file);
519 set_callback_option (shipout_backend);
520 set_callback_option (run_script);
521 if (opt->banner && *(opt->banner)) {
522 mp->banner = xstrdup (opt->banner);
524 mp->banner = xstrdup (default_banner);
526 if (opt->command_line && *(opt->command_line))
527 mp->command_line = xstrdup (opt->command_line);
528 if (mp->noninteractive) {
529 @<Prepare function pointers for non-interactive use@>;
531 /* open the terminal for output */
534 setvbuf(stdout, (char *) NULL, _IONBF, 0);
535 setvbuf(mp->term_out, (char *) NULL, _IONBF, 0);
537 if (opt->math_mode == mp_math_scaled_mode) {
538 mp->math = mp_initialize_scaled_math(mp);
539 } else if (opt->math_mode == mp_math_decimal_mode) {
540 mp->math = mp_initialize_decimal_math(mp);
541 } else if (opt->math_mode == mp_math_binary_mode) {
542 mp->math = mp_initialize_binary_math(mp);
544 mp->math = mp_initialize_double_math(mp);
546 @<Find and load preload file, if required@>;
547 @<Allocate or initialize variables@>;
548 mp_reallocate_paths (mp, 1000);
549 mp_reallocate_fonts (mp, 8);
550 mp->history = mp_fatal_error_stop; /* in case we quit during initialization */
551 @<Check the ``constant'' values...@>;
554 mp_snprintf (ss, 256, "Ouch---my internal constants have been clobbered
!\n
"
555 "---case
%i
", (int) mp->bad);
556 mp_fputs ((char *) ss, mp->err_out);
557 @.Ouch...clobbered@>;
560 mp_do_initialize (mp); /* erase preloaded mem */
561 mp_init_tab (mp); /* initialize the tables */
562 if (opt->math_mode == mp_math_scaled_mode) {
563 set_internal_string (mp_number_system, mp_intern (mp, "scaled
"));
564 } else if (opt->math_mode == mp_math_decimal_mode) {
565 set_internal_string (mp_number_system, mp_intern (mp, "decimal
"));
566 } else if (opt->math_mode == mp_math_binary_mode) {
567 set_internal_string (mp_number_system, mp_intern (mp, "binary
"));
569 set_internal_string (mp_number_system, mp_intern (mp, "double
"));
571 mp_init_prim (mp); /* call |primitive| for each primitive */
572 mp_fix_date_and_time (mp);
573 if (!mp->noninteractive) {
574 @<Initialize the output routines@>;
575 @<Get the first line of input and prepare to start@>;
576 @<Initializations after first line is read@>;
577 @<Fix up |mp->internal[mp_job_name]|@>;
579 mp->history = mp_spotless;
586 @ @<Initializations after first line is read@>=
587 mp_open_log_file (mp);
589 mp_init_map_file (mp, mp->troff_mode);
590 mp->history = mp_spotless; /* ready to go! */
591 if (mp->troff_mode) {
592 number_clone (internal_value (mp_gtroffmode), unity_t);
593 number_clone (internal_value (mp_prologues), unity_t);
595 if (mp->start_sym != NULL) { /* insert the `\&{everyjob}' symbol */
596 set_cur_sym (mp->start_sym);
600 @ @<Exported function headers@>=
601 extern MP_options *mp_options (void);
602 extern MP mp_initialize (MP_options * opt);
603 extern int mp_status (MP mp);
604 extern void *mp_userdata (MP mp);
607 int mp_status (MP mp) {
613 void *mp_userdata (MP mp) {
618 @ The overall \MP\ program begins with the heading just shown, after which
619 comes a bunch of procedure declarations and function declarations.
620 Finally we will get to the main program, which begins with the
621 comment `|start_here|'. If you want to skip down to the
622 main program now, you can look up `|start_here|' in the index.
623 But the author suggests that the best way to understand this program
624 is to follow pretty much the order of \MP's components as they appear in the
625 \.{WEB} description you are now reading, since the present ordering is
626 intended to combine the advantages of the ``bottom up'' and ``top down''
627 approaches to the problem of understanding a somewhat complicated system.
629 @ Some of the code below is intended to be used only when diagnosing the
630 strange behavior that sometimes occurs when \MP\ is being installed or
631 when system wizards are fooling around with \MP\ without quite knowing
632 what they are doing. Such code will not normally be compiled; it is
633 delimited by the preprocessor test `|#ifdef DEBUG .. #endif|'.
635 @ The following parameters can be changed at compile time to extend or
636 reduce \MP's capacity.
637 @^system dependencies@>
640 #define bistack_size 1500 /* size of stack for bisection algorithms;
641 should probably be left at this value */
643 @ Like the preceding parameters, the following quantities can be changed
644 to extend or reduce \MP's capacity.
647 int pool_size; /* maximum number of characters in strings, including all
648 error messages and help texts, and the names of all identifiers */
649 int max_in_open; /* maximum number of input files and error insertions that
650 can be going on simultaneously */
651 int param_size; /* maximum number of simultaneous macro parameters */
653 @ @<Option variables@>=
654 int error_line; /* width of context lines on terminal error messages */
655 int half_error_line; /* width of first lines of contexts in terminal
656 error messages; should be between 30 and |error_line-15| */
657 int halt_on_error; /* do we quit at the first error? */
658 int max_print_line; /* width of longest text lines output; should be at least 60 */
659 void *userdata; /* this allows the calling application to setup local */
660 char *banner; /* the banner that is printed to the screen and log */
663 @ @<Dealloc variables@>=
667 @d set_lower_limited_value(a,b,c) do { a=c; if (b>c) a=b; } while (0)
672 mp->pool_size = 10000;
673 set_lower_limited_value (mp->error_line, opt->error_line, 79);
674 set_lower_limited_value (mp->half_error_line, opt->half_error_line, 50);
675 if (mp->half_error_line > mp->error_line - 15)
676 mp->half_error_line = mp->error_line - 15;
677 mp->max_print_line = 100;
678 set_lower_limited_value (mp->max_print_line, opt->max_print_line, 79);
679 mp->halt_on_error = (opt->halt_on_error ? true : false);
680 mp->ini_version = (opt->ini_version ? true : false);
682 @ In case somebody has inadvertently made bad settings of the ``constants,''
683 \MP\ checks them using a global variable called |bad|.
685 This is the second of many sections of \MP\ where global variables are
689 integer bad; /* is some ``constant'' wrong? */
691 @ Later on we will say `|if ( int_packets+17*int_increment>bistack_size )mp->bad=19;|',
692 or something similar.
694 In case you are wondering about the non-consequtive values of |bad|: most
695 of the things that used to be WEB constants are now runtime variables
696 with checking at assignment time.
698 @<Check the ``constant'' values for consistency@>=
701 @ Here are some macros for common programming idioms.
703 @d incr(A) (A)=(A)+1 /* increase a variable by unity */
704 @d decr(A) (A)=(A)-1 /* decrease a variable by unity */
705 @d negate(A) (A)=-(A) /* change the sign of a variable */
706 @d double(A) (A)=(A)+(A)
707 @d odd(A) (abs(A)%2==1)
709 @* The character set.
710 In order to make \MP\ readily portable to a wide variety of
711 computers, all of its input text is converted to an internal eight-bit
712 code that includes standard ASCII, the ``American Standard Code for
713 Information Interchange.'' This conversion is done immediately when each
714 character is read in. Conversely, characters are converted from ASCII to
715 the user's external representation just before they are output to a
719 Such an internal code is relevant to users of \MP\ only with respect to
720 the \&{char} and \&{ASCII} operations, and the comparison of strings.
722 @ Characters of text that have been converted to \MP's internal form
723 are said to be of type |ASCII_code|, which is a subrange of the integers.
726 typedef unsigned char ASCII_code; /* eight-bit numbers */
728 @ The present specification of \MP\ has been written under the assumption
729 that the character set contains at least the letters and symbols associated
730 with ASCII codes 040 through 0176; all of these characters are now
731 available on most computer terminals.
734 typedef unsigned char text_char; /* the data type of characters in text files */
736 @ @<Local variables for init...@>=
739 @ The \MP\ processor converts between ASCII code and
740 the user's external character set by means of arrays |xord| and |xchr|
741 that are analogous to Pascal's |ord| and |chr| functions.
743 @<MPlib internal header stuff@>=
744 #define xchr(A) mp->xchr[(A)]
745 #define xord(A) mp->xord[(A)]
748 ASCII_code xord[256]; /* specifies conversion of input characters */
749 text_char xchr[256]; /* specifies conversion of output characters */
751 @ The core system assumes all 8-bit is acceptable. If it is not,
752 a change file has to alter the below section.
753 @^system dependencies@>
755 Additionally, people with extended character sets can
756 assign codes arbitrarily, giving an |xchr| equivalent to whatever
757 characters the users of \MP\ are allowed to have in their input files.
758 Appropriate changes to \MP's |char_class| table should then be made.
759 (Unlike \TeX, each installation of \MP\ has a fixed assignment of category
760 codes, called the |char_class|.) Such changes make portability of programs
761 more difficult, so they should be introduced cautiously if at all.
762 @^character set dependencies@>
763 @^system dependencies@>
766 for (i = 0; i <= 0377; i++) {
767 xchr (i) = (text_char) i;
771 @ The following system-independent code makes the |xord| array contain a
772 suitable inverse to the information in |xchr|. Note that if |xchr[i]=xchr[j]|
773 where |i<j<0177|, the value of |xord[xchr[i]]| will turn out to be
774 |j| or more; hence, standard ASCII code numbers will be used instead of
775 codes below 040 in case there is a coincidence.
778 for (i = 0; i <= 255; i++) {
779 xord (xchr (i)) = 0177;
781 for (i = 0200; i <= 0377; i++) {
782 xord (xchr (i)) = (ASCII_code) i;
784 for (i = 0; i <= 0176; i++) {
785 xord (xchr (i)) = (ASCII_code) i;
790 The bane of portability is the fact that different operating systems treat
791 input and output quite differently, perhaps because computer scientists
792 have not given sufficient attention to this problem. People have felt somehow
793 that input and output are not part of ``real'' programming. Well, it is true
794 that some kinds of programming are more fun than others. With existing
795 input/output conventions being so diverse and so messy, the only sources of
796 joy in such parts of the code are the rare occasions when one can find a
797 way to make the program a little less bad than it might have been. We have
798 two choices, either to attack I/O now and get it over with, or to postpone
799 I/O until near the end. Neither prospect is very attractive, so let's
802 The basic operations we need to do are (1)~inputting and outputting of
803 text, to or from a file or the user's terminal; (2)~inputting and
804 outputting of eight-bit bytes, to or from a file; (3)~instructing the
805 operating system to initiate (``open'') or to terminate (``close'') input or
806 output from a specified file; (4)~testing whether the end of an input
807 file has been reached; (5)~display of bits on the user's screen.
808 The bit-display operation will be discussed in a later section; we shall
809 deal here only with more traditional kinds of I/O.
811 @ Finding files happens in a slightly roundabout fashion: the \MP\
812 instance object contains a field that holds a function pointer that finds a
813 file, and returns its name, or NULL. For this, it receives three
814 parameters: the non-qualified name |fname|, the intended |fopen|
815 operation type |fmode|, and the type of the file |ftype|.
817 The file types that are passed on in |ftype| can be used to
818 differentiate file searches if a library like kpathsea is used,
819 the fopen mode is passed along for the same reason.
822 typedef unsigned char eight_bits; /* unsigned one-byte quantity */
824 @ @<Exported types@>=
826 mp_filetype_terminal = 0, /* the terminal */
827 mp_filetype_error, /* the terminal */
828 mp_filetype_program, /* \MP\ language input */
829 mp_filetype_log, /* the log file */
830 mp_filetype_postscript, /* the postscript output */
831 mp_filetype_bitmap, /* the bitmap output file */
832 mp_filetype_memfile, /* memory dumps, obsolete */
833 mp_filetype_metrics, /* TeX font metric files */
834 mp_filetype_fontmap, /* PostScript font mapping files */
835 mp_filetype_font, /* PostScript type1 font programs */
836 mp_filetype_encoding, /* PostScript font encoding files */
837 mp_filetype_text /* first text file for readfrom and writeto primitives */
839 typedef char *(*mp_file_finder) (MP, const char *, const char *, int);
840 typedef char *(*mp_script_runner) (MP, const char *);
841 typedef void *(*mp_file_opener) (MP, const char *, const char *, int);
842 typedef char *(*mp_file_reader) (MP, void *, size_t *);
843 typedef void (*mp_binfile_reader) (MP, void *, void **, size_t *);
844 typedef void (*mp_file_closer) (MP, void *);
845 typedef int (*mp_file_eoftest) (MP, void *);
846 typedef void (*mp_file_flush) (MP, void *);
847 typedef void (*mp_file_writer) (MP, void *, const char *);
848 typedef void (*mp_binfile_writer) (MP, void *, void *, size_t);
850 @ @<Option variables@>=
851 mp_file_finder find_file;
852 mp_file_opener open_file;
853 mp_script_runner run_script;
854 mp_file_reader read_ascii_file;
855 mp_binfile_reader read_binary_file;
856 mp_file_closer close_file;
857 mp_file_eoftest eof_file;
858 mp_file_flush flush_file;
859 mp_file_writer write_ascii_file;
860 mp_binfile_writer write_binary_file;
862 @ The default function for finding files is |mp_find_file|. It is
863 pretty stupid: it will only find files in the current directory.
866 static char *mp_find_file (MP mp, const char *fname, const char *fmode,
869 if (fmode[0] != 'r' || (!access (fname, R_OK)) || ftype) {
870 return mp_strdup (fname);
876 static char *mp_run_script (MP mp, const char *str) {
878 return mp_strdup (str);
882 @ Because |mp_find_file| is used so early, it has to be in the helpers
886 static char *mp_find_file (MP mp, const char *fname, const char *fmode,
888 static void *mp_open_file (MP mp, const char *fname, const char *fmode,
890 static char *mp_read_ascii_file (MP mp, void *f, size_t * size);
891 static void mp_read_binary_file (MP mp, void *f, void **d, size_t * size);
892 static void mp_close_file (MP mp, void *f);
893 static int mp_eof_file (MP mp, void *f);
894 static void mp_flush_file (MP mp, void *f);
895 static void mp_write_ascii_file (MP mp, void *f, const char *s);
896 static void mp_write_binary_file (MP mp, void *f, void *s, size_t t);
897 static char *mp_run_script (MP mp, const char *str);
899 @ The function to open files can now be very short.
902 void *mp_open_file (MP mp, const char *fname, const char *fmode, int ftype) {
905 realmode[0] = *fmode;
908 if (ftype == mp_filetype_terminal) {
909 return (fmode[0] == 'r' ? stdin : stdout);
910 } else if (ftype == mp_filetype_error) {
912 } else if (fname != NULL && (fmode[0] != 'r' || (!access (fname, R_OK)))) {
913 return (void *) fopen (fname, realmode);
919 @ (Almost) all file names pass through |name_of_file|.
922 char *name_of_file; /* the name of a system file */
924 @ If this parameter is true, the terminal and log will report the found
925 file names for input files instead of the requested ones.
926 It is off by default because it creates an extra filename lookup.
928 @<Option variables@>=
929 int print_found_names; /* configuration parameter */
931 @ @<Allocate or initialize ...@>=
932 mp->print_found_names = (opt->print_found_names > 0 ? true : false);
934 @ The |file_line_error_style| parameter makes \MP\ use a more
935 standard compiler error message format instead of the Knuthian
936 exclamation mark. It needs the actual version of the current input
937 file name, that will be saved by |open_in| in the |long_name|.
939 TODO: currently these long strings cause memory leaks, because they cannot
940 be safely freed as they may appear in the |input_stack| multiple times.
941 In fact, the current implementation is just a quick hack in response
942 to a bug report for metapost 1.205.
944 @d long_name mp->cur_input.long_name_field /* long name of the current file */
946 @<Option variables@>=
947 int file_line_error_style; /* configuration parameter */
949 @ @<Allocate or initialize ...@>=
950 mp->file_line_error_style = (opt->file_line_error_style > 0 ? true : false);
952 @ \MP's file-opening procedures return |false| if no file identified by
953 |name_of_file| could be opened.
955 The |do_open_file| function takes care of the |print_found_names| parameter.
958 static boolean mp_do_open_file (MP mp, void **f, int ftype, const char *mode) {
959 if (mp->print_found_names || mp->file_line_error_style) {
960 char *s = (mp->find_file)(mp,mp->name_of_file,mode,ftype);
962 *f = (mp->open_file)(mp,mp->name_of_file,mode, ftype);
963 if (mp->print_found_names) {
964 xfree(mp->name_of_file);
965 mp->name_of_file = xstrdup(s);
967 if ((*mode == 'r') && (ftype == mp_filetype_program)) {
968 long_name = xstrdup(s);
975 *f = (mp->open_file)(mp,mp->name_of_file,mode, ftype);
977 return (*f ? true : false);
980 static boolean mp_open_in (MP mp, void **f, int ftype) {
981 /* open a file for input */
982 return mp_do_open_file (mp, f, ftype, "r
");
985 static boolean mp_open_out (MP mp, void **f, int ftype) {
986 /* open a file for output */
987 return mp_do_open_file (mp, f, ftype, "w
");
992 static char *mp_read_ascii_file (MP mp, void *ff, size_t * size) {
994 size_t len = 0, lim = 128;
996 FILE *f = (FILE *) ff;
998 (void) mp; /* for -Wunused */
1007 while (c != EOF && c != '\n' && c != '\r') {
1008 if ((len + 1) == lim) {
1009 s = realloc (s, (lim + (lim >> 2)));
1014 s[len++] = (char) c;
1019 if (c != EOF && c != '\n')
1029 void mp_write_ascii_file (MP mp, void *f, const char *s) {
1032 fputs (s, (FILE *) f);
1038 void mp_read_binary_file (MP mp, void *f, void **data, size_t * size) {
1042 len = fread (*data, 1, *size, (FILE *) f);
1048 void mp_write_binary_file (MP mp, void *f, void *s, size_t size) {
1051 (void) fwrite (s, size, 1, (FILE *) f);
1056 void mp_close_file (MP mp, void *f) {
1059 fclose ((FILE *) f);
1064 int mp_eof_file (MP mp, void *f) {
1067 return feof ((FILE *) f);
1074 void mp_flush_file (MP mp, void *f) {
1077 fflush ((FILE *) f);
1081 @ Input from text files is read one line at a time, using a routine called
1082 |input_ln|. This function is defined in terms of global variables called
1083 |buffer|, |first|, and |last| that will be described in detail later; for
1084 now, it suffices for us to know that |buffer| is an array of |ASCII_code|
1085 values, and that |first| and |last| are indices into this array
1086 representing the beginning and ending of a line of text.
1089 size_t buf_size; /* maximum number of characters simultaneously present in
1090 current lines of open files */
1091 ASCII_code *buffer; /* lines of characters being read */
1092 size_t first; /* the first unused position in |buffer| */
1093 size_t last; /* end of the line just input to |buffer| */
1094 size_t max_buf_stack; /* largest index used in |buffer| */
1096 @ @<Allocate or initialize ...@>=
1098 mp->buffer = xmalloc ((mp->buf_size + 1), sizeof (ASCII_code));
1100 @ @<Dealloc variables@>=
1104 static void mp_reallocate_buffer (MP mp, size_t l) {
1106 if (l > max_halfword) {
1107 mp_confusion (mp, "buffer size
"); /* can't happen (I hope) */
1109 buffer = xmalloc ((l + 1), sizeof (ASCII_code));
1110 (void) memcpy (buffer, mp->buffer, (mp->buf_size + 1));
1112 mp->buffer = buffer;
1117 @ The |input_ln| function brings the next line of input from the specified
1118 field into available positions of the buffer array and returns the value
1119 |true|, unless the file has already been entirely read, in which case it
1120 returns |false| and sets |last:=first|. In general, the |ASCII_code|
1121 numbers that represent the next line of the file are input into
1122 |buffer[first]|, |buffer[first+1]|, \dots, |buffer[last-1]|; and the
1123 global variable |last| is set equal to |first| plus the length of the
1124 line. Trailing blanks are removed from the line; thus, either |last=first|
1125 (in which case the line was entirely blank) or |buffer[last-1]<>" "|.
1128 The variable |max_buf_stack|, which is used to keep track of how large
1129 the |buf_size| parameter must be to accommodate the present job, is
1130 also kept up to date by |input_ln|.
1133 static boolean mp_input_ln (MP mp, void *f) {
1134 /* inputs the next line or returns |false| */
1137 mp->last = mp->first; /* cf.\ Matthew 19\thinspace:\thinspace30 */
1138 s = (mp->read_ascii_file) (mp, f, &size);
1142 mp->last = mp->first + size;
1143 if (mp->last >= mp->max_buf_stack) {
1144 mp->max_buf_stack = mp->last + 1;
1145 while (mp->max_buf_stack > mp->buf_size) {
1146 mp_reallocate_buffer (mp, (mp->buf_size + (mp->buf_size >> 2)));
1149 (void) memcpy ((mp->buffer + mp->first), s, size);
1156 @ The user's terminal acts essentially like other files of text, except
1157 that it is used both for input and for output. When the terminal is
1158 considered an input file, the file variable is called |term_in|, and when it
1159 is considered an output file the file variable is |term_out|.
1160 @^system dependencies@>
1163 void *term_in; /* the terminal as an input file */
1164 void *term_out; /* the terminal as an output file */
1165 void *err_out; /* the terminal as an output file */
1167 @ Here is how to open the terminal files. In the default configuration,
1168 nothing happens except that the command line (if there is one) is copied
1169 to the input buffer. The variable |command_line| will be filled by the
1172 @d t_open_out() do {/* open the terminal for text output */
1173 mp->term_out = (mp->open_file)(mp,"terminal
", "w
", mp_filetype_terminal);
1174 mp->err_out = (mp->open_file)(mp,"error
", "w
", mp_filetype_error);
1176 @d t_open_in() do { /* open the terminal for text input */
1177 mp->term_in = (mp->open_file)(mp,"terminal
", "r
", mp_filetype_terminal);
1178 if (mp->command_line!=NULL) {
1179 mp->last = strlen(mp->command_line);
1180 (void)memcpy((void *)mp->buffer,(void *)mp->command_line,mp->last);
1181 xfree(mp->command_line);
1187 @<Option variables@>=
1190 @ Sometimes it is necessary to synchronize the input/output mixture that
1191 happens on the user's terminal, and three system-dependent
1192 procedures are used for this
1193 purpose. The first of these, |update_terminal|, is called when we want
1194 to make sure that everything we have output to the terminal so far has
1195 actually left the computer's internal buffers and been sent.
1196 The second, |clear_terminal|, is called when we wish to cancel any
1197 input that the user may have typed ahead (since we are about to
1198 issue an unexpected error message). The third, |wake_up_terminal|,
1199 is supposed to revive the terminal if the user has disabled it by
1200 some instruction to the operating system. The following macros show how
1201 these operations can be specified:
1202 @^system dependencies@>
1204 @<MPlib internal header stuff@>=
1205 #define update_terminal() (mp->flush_file)(mp,mp->term_out) /* empty the terminal output buffer */
1206 #define clear_terminal() /* clear the terminal input buffer */
1207 #define wake_up_terminal() (mp->flush_file)(mp,mp->term_out)
1208 /* cancel the user's cancellation of output */
1210 @ We need a special routine to read the first line of \MP\ input from
1211 the user's terminal. This line is different because it is read before we
1212 have opened the transcript file; there is sort of a ``chicken and
1213 egg'' problem here. If the user types `\.{input cmr10}' on the first
1214 line, or if some macro invoked by that line does such an \.{input},
1215 the transcript file will be named `\.{cmr10.log}'; but if no \.{input}
1216 commands are performed during the first line of terminal input, the transcript
1217 file will acquire its default name `\.{mpout.log}'. (The transcript file
1218 will not contain error messages generated by the first line before the
1219 first \.{input} command.)
1221 The first line is even more special. It's nice to let the user start
1222 running a \MP\ job by typing a command line like `\.{MP cmr10}'; in
1223 such a case, \MP\ will operate as if the first line of input were
1224 `\.{cmr10}', i.e., the first line will consist of the remainder of the
1225 command line, after the part that invoked \MP.
1227 @ Different systems have different ways to get started. But regardless of
1228 what conventions are adopted, the routine that initializes the terminal
1229 should satisfy the following specifications:
1231 \yskip\textindent{1)}It should open file |term_in| for input from the
1232 terminal. (The file |term_out| will already be open for output to the
1235 \textindent{2)}If the user has given a command line, this line should be
1236 considered the first line of terminal input. Otherwise the
1237 user should be prompted with `\.{**}', and the first line of input
1238 should be whatever is typed in response.
1240 \textindent{3)}The first line of input, which might or might not be a
1241 command line, should appear in locations |first| to |last-1| of the
1244 \textindent{4)}The global variable |loc| should be set so that the
1245 character to be read next by \MP\ is in |buffer[loc]|. This
1246 character should not be blank, and we should have |loc<last|.
1248 \yskip\noindent(It may be necessary to prompt the user several times
1249 before a non-blank line comes in. The prompt is `\.{**}' instead of the
1250 later `\.*' because the meaning is slightly different: `\.{input}' need
1251 not be typed immediately after~`\.{**}'.)
1253 @d loc mp->cur_input.loc_field /* location of first unread character in |buffer| */
1256 boolean mp_init_terminal (MP mp) { /* gets the terminal input started */
1258 if (mp->last != 0) {
1264 if (!mp->noninteractive) {
1266 mp_fputs ("**", mp->term_out);
1270 if (!mp_input_ln (mp, mp->term_in)) { /* this shouldn't happen */
1271 mp_fputs ("\n
! End of file on the terminal... why?
", mp->term_out);
1272 @.End of file on the terminal@>;
1275 loc = (halfword) mp->first;
1276 while ((loc < (int) mp->last) && (mp->buffer[loc] == ' '))
1278 if (loc < (int) mp->last) {
1279 return true; /* return unless the line was all blank */
1281 if (!mp->noninteractive) {
1282 mp_fputs ("Please type the name of your input file.\n
", mp->term_out);
1289 static boolean mp_init_terminal (MP mp);
1291 @* Globals for strings.
1293 @ Symbolic token names and diagnostic messages are variable-length strings
1294 of eight-bit characters. Many strings \MP\ uses are simply literals
1295 in the compiled source, like the error messages and the names of the
1296 internal parameters. Other strings are used or defined from the \MP\ input
1297 language, and these have to be interned.
1299 \MP\ uses strings more extensively than \MF\ does, but the necessary
1300 operations can still be handled with a fairly simple data structure.
1301 The avl tree |strings| contains all of the known string structures.
1303 Each structure contains an |unsigned char| pointer containing the eight-bit
1304 data, a |size_t| that holds the length of that data, and an |int| that
1305 indicates how often this string is referenced (this will be explained below).
1306 Such strings are referred to by structure pointers called |mp_string|.
1308 Besides the avl tree, there is a set of three variables called |cur_string|,
1309 |cur_length| and |cur_string_size| that are used for strings while they are
1312 @<Exported types...@>=
1314 unsigned char *str; /* the string value */
1315 size_t len; /* its length */
1316 int refs; /* number of references */
1318 typedef mp_lstring *mp_string; /* for pointers to string values */
1320 @ The string handling functions are in \.{mpstrings.w}, but strings
1321 need a bunch of globals and those are defined here in the main file.
1324 avl_tree strings; /* string avl tree */
1325 unsigned char *cur_string; /* current string buffer */
1326 size_t cur_length; /* current index in that buffer */
1327 size_t cur_string_size; /* malloced size of |cur_string| */
1329 @ @<Allocate or initialize ...@>=
1330 mp_initialize_strings(mp);
1332 @ @<Dealloc variables@>=
1333 mp_dealloc_strings(mp);
1335 @ The next four variables are for keeping track of string memory usage.
1338 integer pool_in_use; /* total number of string bytes actually in use */
1339 integer max_pl_used; /* maximum |pool_in_use| so far */
1340 integer strs_in_use; /* total number of strings actually in use */
1341 integer max_strs_used; /* maximum |strs_in_use| so far */
1344 @* On-line and off-line printing.
1345 Messages that are sent to a user's terminal and to the transcript-log file
1346 are produced by several `|print|' procedures. These procedures will
1347 direct their output to a variety of places, based on the setting of
1348 the global variable |selector|, which has the following possible
1352 \hang |term_and_log|, the normal setting, prints on the terminal and on the
1355 \hang |log_only|, prints only on the transcript file.
1357 \hang |term_only|, prints only on the terminal.
1359 \hang |no_print|, doesn't print at all. This is used only in rare cases
1360 before the transcript file is open.
1362 \hang |pseudo|, puts output into a cyclic buffer that is used
1363 by the |show_context| routine; when we get to that routine we shall discuss
1364 the reasoning behind this curious mode.
1366 \hang |new_string|, appends the output to the current string in the
1369 \hang |>=write_file| prints on one of the files used for the \&{write}
1370 @:write_}{\&{write} primitive@>
1374 \noindent The symbolic names `|term_and_log|', etc., have been assigned
1375 numeric codes that satisfy the convenient relations |no_print+1=term_only|,
1376 |no_print+2=log_only|, |term_only+2=log_only+1=term_and_log|. These
1377 relations are not used when |selector| could be |pseudo|, or |new_string|.
1378 We need not check for unprintable characters when |selector<pseudo|.
1380 Three additional global variables, |tally|, |term_offset| and |file_offset|
1381 record the number of characters that have been printed
1382 since they were most recently cleared to zero. We use |tally| to record
1383 the length of (possibly very long) stretches of printing; |term_offset|,
1384 and |file_offset|, on the other hand, keep track of how many
1385 characters have appeared so far on the current line that has been output
1386 to the terminal, the transcript file, or the \ps\ output file, respectively.
1388 @d new_string 0 /* printing is deflected to the string pool */
1389 @d pseudo 2 /* special |selector| setting for |show_context| */
1390 @d no_print 3 /* |selector| setting that makes data disappear */
1391 @d term_only 4 /* printing is destined for the terminal only */
1392 @d log_only 5 /* printing is destined for the transcript file only */
1393 @d term_and_log 6 /* normal |selector| setting */
1394 @d write_file 7 /* first write file selector */
1397 void *log_file; /* transcript of \MP\ session */
1398 void *output_file; /* the generic font output goes here */
1399 unsigned int selector; /* where to print a message */
1400 integer tally; /* the number of characters recently printed */
1401 unsigned int term_offset;
1402 /* the number of characters on the current terminal line */
1403 unsigned int file_offset;
1404 /* the number of characters on the current file line */
1405 ASCII_code *trick_buf; /* circular buffer for pseudoprinting */
1406 integer trick_count; /* threshold for pseudoprinting, explained later */
1407 integer first_count; /* another variable for pseudoprinting */
1409 @ The first 128 strings will contain 95 standard ASCII characters, and the
1410 other 33 characters will be printed in three-symbol form like `\.{\^\^A}'
1411 unless a system-dependent change is made here. Installations that have
1412 an extended character set, where for example |xchr[032]=@t\.{'^^Z'}@>|,
1413 would like string 032 to be printed as the single character 032 instead
1414 of the three characters 0136, 0136, 0132 (\.{\^\^Z}). On the other hand,
1415 even people with an extended character set will want to represent string
1416 015 by \.{\^\^M}, since 015 is ASCII's ``carriage return'' code; the idea is
1417 to produce visible strings instead of tabs or line-feeds or carriage-returns
1418 or bell-rings or characters that are treated anomalously in text files.
1420 The boolean expression defined here should be |true| unless \MP\ internal
1421 code number~|k| corresponds to a non-troublesome visible symbol in the
1422 local character set.
1423 If character |k| cannot be printed, and |k<0200|, then character |k+0100| or
1424 |k-0100| must be printable; moreover, ASCII codes |[060..071, 0141..0146]|
1426 @^character set dependencies@>
1427 @^system dependencies@>
1429 @<Character |k| cannot be printed@>=
1430 (k < ' ') || (k == 127)
1432 @ @<Allocate or initialize ...@>=
1433 mp->trick_buf = xmalloc ((mp->error_line + 1), sizeof (ASCII_code));
1435 @ @<Dealloc variables@>=
1436 xfree (mp->trick_buf);
1438 @ @<Initialize the output routines@>=
1439 mp->selector = term_only;
1441 mp->term_offset = 0;
1442 mp->file_offset = 0;
1444 @ Macro abbreviations for output to the terminal and to the log file are
1445 defined here for convenience. Some systems need special conventions
1446 for terminal output, and it is possible to adhere to those conventions
1447 by changing |wterm|, |wterm_ln|, and |wterm_cr| here.
1448 @^system dependencies@>
1450 @<MPlib internal header stuff@>=
1451 #define mp_fputs(b,f) (mp->write_ascii_file)(mp,f,b)
1452 #define wterm(A) mp_fputs((A), mp->term_out)
1453 #define wterm_chr(A) { unsigned char ss[2]; ss[0]=(A); ss[1]='\0'; wterm((char *)ss);}
1454 #define wterm_cr mp_fputs("\n
", mp->term_out)
1455 #define wterm_ln(A) { wterm_cr; mp_fputs((A), mp->term_out); }
1456 #define wlog(A) mp_fputs((A), mp->log_file)
1457 #define wlog_chr(A) { unsigned char ss[2]; ss[0]=(A); ss[1]='\0'; wlog((char *)ss);}
1458 #define wlog_cr mp_fputs("\n
", mp->log_file)
1459 #define wlog_ln(A) { wlog_cr; mp_fputs((A), mp->log_file); }
1462 @ To end a line of text output, we call |print_ln|. Cases |0..max_write_files|
1463 use an array |wr_file| that will be declared later.
1465 @d mp_print_text(A) mp_print_str(mp,text((A)))
1467 @<Internal library ...@>=
1468 void mp_print (MP mp, const char *s);
1469 void mp_printf (MP mp, const char *ss, ...);
1470 void mp_print_ln (MP mp);
1471 void mp_print_char (MP mp, ASCII_code k);
1472 void mp_print_str (MP mp, mp_string s);
1473 void mp_print_nl (MP mp, const char *s);
1474 void mp_print_two (MP mp, mp_number x, mp_number y);
1477 static void mp_print_visible_char (MP mp, ASCII_code s);
1479 @ @<Basic print...@>=
1480 void mp_print_ln (MP mp) { /* prints an end-of-line */
1481 switch (mp->selector) {
1485 mp->term_offset = 0;
1486 mp->file_offset = 0;
1490 mp->file_offset = 0;
1494 mp->term_offset = 0;
1501 mp_fputs ("\n
", mp->wr_file[(mp->selector - write_file)]);
1503 } /* note that |tally| is not affected */
1506 @ The |print_visible_char| procedure sends one character to the desired
1507 destination, using the |xchr| array to map it into an external character
1508 compatible with |input_ln|. (It assumes that it is always called with
1509 a visible ASCII character.) All printing comes through |print_ln| or
1510 |print_char|, which ultimately calls |print_visible_char|, hence these
1511 routines are the ones that limit lines to at most |max_print_line| characters.
1512 But we must make an exception for the \ps\ output file since it is not safe
1513 to cut up lines arbitrarily in \ps.
1515 @<Basic printing...@>=
1516 static void mp_print_visible_char (MP mp, ASCII_code s) { /* prints a single character */
1517 switch (mp->selector) {
1519 wterm_chr (xchr (s));
1520 wlog_chr (xchr (s));
1521 incr (mp->term_offset);
1522 incr (mp->file_offset);
1523 if (mp->term_offset == (unsigned) mp->max_print_line) {
1525 mp->term_offset = 0;
1527 if (mp->file_offset == (unsigned) mp->max_print_line) {
1529 mp->file_offset = 0;
1533 wlog_chr (xchr (s));
1534 incr (mp->file_offset);
1535 if (mp->file_offset == (unsigned) mp->max_print_line)
1539 wterm_chr (xchr (s));
1540 incr (mp->term_offset);
1541 if (mp->term_offset == (unsigned) mp->max_print_line)
1547 if (mp->tally < mp->trick_count)
1548 mp->trick_buf[mp->tally % mp->error_line] = s;
1555 text_char ss[2] = {0,0};
1557 mp_fputs ((char *) ss, mp->wr_file[(mp->selector - write_file)]);
1564 @ The |print_char| procedure sends one character to the desired destination.
1565 File names and string expressions might contain |ASCII_code| values that
1566 can't be printed using |print_visible_char|. These characters will be
1567 printed in three- or four-symbol form like `\.{\^\^A}' or `\.{\^\^e4}'.
1568 (This procedure assumes that it is safe to bypass all checks for unprintable
1569 characters when |selector| is in the range |0..max_write_files-1|.
1570 The user might want to write unprintable characters.
1572 @<Basic printing...@>=
1573 void mp_print_char (MP mp, ASCII_code k) { /* prints a single character */
1574 if (mp->selector < pseudo || mp->selector >= write_file) {
1575 mp_print_visible_char (mp, k);
1576 } else if (@<Character |k| cannot be printed@>) {
1577 mp_print (mp, "^^
");
1579 mp_print_visible_char (mp, (ASCII_code) (k + 0100));
1580 } else if (k < 0200) {
1581 mp_print_visible_char (mp, (ASCII_code) (k - 0100));
1583 int l; /* small index or counter */
1585 mp_print_visible_char (mp, xord (l < 10 ? l + '0' : l - 10 + 'a'));
1587 mp_print_visible_char (mp, xord (l < 10 ? l + '0' : l - 10 + 'a'));
1590 mp_print_visible_char (mp, k);
1595 @ An entire string is output by calling |print|. Note that if we are outputting
1596 the single standard ASCII character \.c, we could call |print("c
")|, since
1597 |"c
"=99| is the number of a single-character string, as explained above. But
1598 |print_char("c
")| is quicker, so \MP\ goes directly to the |print_char|
1599 routine when it knows that this is safe. (The present implementation
1600 assumes that it is always safe to print a visible ASCII character.)
1601 @^system dependencies@>
1604 static void mp_do_print (MP mp, const char *ss, size_t len) { /* prints string |s| */
1607 if (mp->selector == new_string) {
1609 memcpy((mp->cur_string+mp->cur_length), ss, len);
1610 mp->cur_length += len;
1614 /* this was |xord((int)ss[j])| but that doesnt work */
1615 mp_print_char (mp, (ASCII_code) ss[j]);
1624 void mp_print (MP mp, const char *ss) {
1625 assert (ss != NULL);
1626 mp_do_print (mp, ss, strlen (ss));
1628 void mp_printf (MP mp, const char *ss, ...) {
1631 assert (ss != NULL);
1633 vsnprintf (pval, 256, ss, ap);
1634 mp_do_print (mp, pval, strlen (pval));
1638 void mp_print_str (MP mp, mp_string s) {
1640 mp_do_print (mp, (const char *) s->str, s->len);
1644 @ Here is the very first thing that \MP\ prints: a headline that identifies
1645 the version number and base name. The |term_offset| variable is temporarily
1646 incorrect, but the discrepancy is not serious since we assume that the banner
1647 and mem identifier together will occupy at most |max_print_line|
1648 character positions.
1650 @<Initialize the output...@>=
1655 @ The procedure |print_nl| is like |print|, but it makes sure that the
1656 string appears at the beginning of a new line.
1659 void mp_print_nl (MP mp, const char *s) { /* prints string |s| at beginning of line */
1660 switch (mp->selector) {
1662 if ((mp->term_offset > 0) || (mp->file_offset > 0))
1666 if (mp->file_offset > 0)
1670 if (mp->term_offset > 0)
1677 } /* there are no other cases */
1682 @ The following procedure, which prints out the decimal representation of a
1683 given integer |n|, assumes that all integers fit nicely into a |int|.
1684 @^system dependencies@>
1687 void mp_print_int (MP mp, integer n) { /* prints an integer in decimal form */
1689 mp_snprintf (s, 12, "%d
", (int) n);
1692 void mp_print_pointer (MP mp, void *n) { /* prints an pointer in hexadecimal form */
1694 mp_snprintf (s, 12, "%p
", n);
1698 @ @<Internal library ...@>=
1699 void mp_print_int (MP mp, integer n);
1700 void mp_print_pointer (MP mp, void *n);
1702 @ \MP\ also makes use of a trivial procedure to print two digits. The
1703 following subroutine is usually called with a parameter in the range |0<=n<=99|.
1706 static void mp_print_dd (MP mp, integer n) { /* prints two least significant digits */
1708 mp_print_char (mp, xord ('0' + (n / 10)));
1709 mp_print_char (mp, xord ('0' + (n % 10)));
1714 static void mp_print_dd (MP mp, integer n);
1716 @ Here is a procedure that asks the user to type a line of input,
1717 assuming that the |selector| setting is either |term_only| or |term_and_log|.
1718 The input is placed into locations |first| through |last-1| of the
1719 |buffer| array, and echoed on the transcript file if appropriate.
1721 This procedure is never called when |interaction<mp_scroll_mode|.
1723 @d prompt_input(A) do {
1724 if (!mp->noninteractive) {
1729 } while (0) /* prints a string and gets a line of input */
1732 void mp_term_input (MP mp) { /* gets a line from the terminal */
1733 size_t k; /* index into |buffer| */
1734 if (mp->noninteractive) {
1735 if (!mp_input_ln (mp, mp->term_in))
1736 longjmp (*(mp->jump_buf), 1); /* chunk finished */
1737 mp->buffer[mp->last] = xord ('%');
1739 update_terminal(); /* Now the user sees the prompt for sure */
1740 if (!mp_input_ln (mp, mp->term_in)) {
1741 mp_fatal_error (mp, "End of file on the terminal
!");
1742 @.End of file on the terminal@>
1744 mp->term_offset = 0; /* the user's line ended with \<\rm return> */
1745 decr (mp->selector); /* prepare to echo the input */
1746 if (mp->last != mp->first) {
1747 for (k = mp->first; k < mp->last; k++) {
1748 mp_print_char (mp, mp->buffer[k]);
1752 mp->buffer[mp->last] = xord ('%');
1753 incr (mp->selector); /* restore previous status */
1758 @* Reporting errors.
1760 The |print_err| procedure supplies a `\.!' before the official message,
1761 and makes sure that the terminal is awake if a stop is going to occur.
1762 The |error| procedure supplies a `\..' after the official message, then it
1763 shows the location of the error; and if |interaction=error_stop_mode|,
1764 it also enters into a dialog with the user, during which time the help
1765 message may be printed.
1766 @^system dependencies@>
1768 @ The global variable |interaction| has four settings, representing increasing
1769 amounts of user interaction:
1772 enum mp_interaction_mode {
1773 mp_unspecified_mode = 0, /* extra value for command-line switch */
1774 mp_batch_mode, /* omits all stops and omits terminal output */
1775 mp_nonstop_mode, /* omits all stops */
1776 mp_scroll_mode, /* omits error stops */
1777 mp_error_stop_mode /* stops at every opportunity to interact */
1780 @ @<Option variables@>=
1781 int interaction; /* current level of interaction */
1782 int noninteractive; /* do we have a terminal? */
1784 @ Set it here so it can be overwritten by the commandline
1786 @<Allocate or initialize ...@>=
1787 mp->interaction = opt->interaction;
1788 if (mp->interaction == mp_unspecified_mode
1789 || mp->interaction > mp_error_stop_mode)
1790 mp->interaction = mp_error_stop_mode;
1791 if (mp->interaction < mp_unspecified_mode)
1792 mp->interaction = mp_batch_mode;
1794 @ |print_err| is not merged in |error| because it is also used in |prompt_file_name|,
1795 where |error| is not called at all.
1798 static void mp_print_err (MP mp, const char *A);
1801 static void mp_print_err (MP mp, const char *A) {
1802 if (mp->interaction == mp_error_stop_mode)
1804 if (mp->file_line_error_style && file_state && !terminal_input) {
1805 mp_print_nl (mp, "");
1806 if (long_name != NULL) {
1807 mp_print (mp, long_name);
1809 mp_print (mp, mp_str (mp, name));
1812 mp_print_int (mp, line);
1813 mp_print (mp, ": ");
1815 mp_print_nl (mp, "! ");
1822 @ \MP\ is careful not to call |error| when the print |selector| setting
1823 might be unusual. The only possible values of |selector| at the time of
1826 \yskip\hang|no_print| (when |interaction=mp_batch_mode|
1827 and |log_file| not yet open);
1829 \hang|term_only| (when |interaction>mp_batch_mode| and |log_file| not yet open);
1831 \hang|log_only| (when |interaction=mp_batch_mode| and |log_file| is open);
1833 \hang|term_and_log| (when |interaction>mp_batch_mode| and |log_file| is open).
1835 @d initialize_print_selector() mp->selector = (mp->interaction == mp_batch_mode ? no_print : term_only);
1837 @ The global variable |history| records the worst level of error that
1838 has been detected. It has four possible values: |spotless|, |warning_issued|,
1839 |error_message_issued|, and |fatal_error_stop|.
1841 Another global variable, |error_count|, is increased by one when an
1842 |error| occurs without an interactive dialog, and it is reset to zero at
1843 the end of every statement. If |error_count| reaches 100, \MP\ decides
1844 that there is no point in continuing further.
1847 enum mp_history_state {
1848 mp_spotless = 0, /* |history| value when nothing has been amiss yet */
1849 mp_warning_issued, /* |history| value when |begin_diagnostic| has been called */
1850 mp_error_message_issued, /* |history| value when |error| has been called */
1851 mp_fatal_error_stop, /* |history| value when termination was premature */
1852 mp_system_error_stop /* |history| value when termination was due to disaster */
1856 int history; /* has the source input been clean so far? */
1857 int error_count; /* the number of scrolled errors since the last statement ended */
1859 @ The value of |history| is initially |fatal_error_stop|, but it will
1860 be changed to |spotless| if \MP\ survives the initialization process.
1862 @ Since errors can be detected almost anywhere in \MP, we want to declare the
1863 error procedures near the beginning of the program. But the error procedures
1864 in turn use some other procedures, which need to be declared |forward|
1865 before we get to |error| itself.
1867 It is possible for |error| to be called recursively if some error arises
1868 when |get_next| is being used to delete a token, and/or if some fatal error
1869 occurs while \MP\ is trying to fix a non-fatal one. But such recursion
1871 is never more than two levels deep.
1874 static void mp_get_next (MP mp);
1875 static void mp_term_input (MP mp);
1876 static void mp_show_context (MP mp);
1877 static void mp_begin_file_reading (MP mp);
1878 static void mp_open_log_file (MP mp);
1879 static void mp_clear_for_error_prompt (MP mp);
1882 void mp_normalize_selector (MP mp);
1885 boolean use_err_help; /* should the |err_help| string be shown? */
1886 mp_string err_help; /* a string set up by \&{errhelp} */
1888 @ @<Allocate or ...@>=
1889 mp->use_err_help = false;
1891 @ The |jump_out| procedure just cuts across all active procedure levels and
1892 goes to |end_of_MP|. This is the only nonlocal |goto| statement in the
1893 whole program. It is used when there is no recovery from a particular error.
1895 The program uses a |jump_buf| to handle this, this is initialized at three
1896 spots: the start of |mp_new|, the start of |mp_initialize|, and the start
1897 of |mp_run|. Those are the only library enty points.
1898 @^system dependencies@>
1903 @ If the array of internals is still |NULL| when |jump_out| is called, a
1904 crash occured during initialization, and it is not safe to run the normal
1908 void mp_jump_out (MP mp) {
1909 if (mp->internal != NULL && mp->history < mp_system_error_stop)
1910 mp_close_files_and_terminate (mp);
1911 longjmp (*(mp->jump_buf), 1);
1915 void mp_jump_out (MP mp);
1920 void mp_warn (MP mp, const char *msg) {
1921 unsigned saved_selector = mp->selector;
1922 mp_normalize_selector (mp);
1923 mp_print_nl (mp, "Warning
: ");
1926 mp->selector = saved_selector;
1929 @ Here now is the general |error| routine.
1931 The argument |deletions_allowed| is set |false| if the |get_next|
1932 routine is active when |error| is called; this ensures that |get_next|
1933 will never be called recursively.
1936 Individual lines of help are recorded in the array |help_line|, which
1937 contains entries in positions |0..(help_ptr-1)|. They should be printed
1938 in reverse order, i.e., with |help_line[0]| appearing last.
1941 void mp_error (MP mp, const char *msg, const char **hlp, boolean deletions_allowed) {
1942 ASCII_code c; /* what the user types */
1943 integer s1, s2; /* used to save global variables when deleting tokens */
1944 mp_sym s3; /* likewise */
1946 const char *help_line[6]; /* helps for the next |error| */
1947 unsigned int help_ptr; /* the number of help lines present */
1948 const char **cnt = NULL;
1949 mp_print_err(mp, msg);
1959 help_line[--i]= *cnt++;
1961 if (mp->history < mp_error_message_issued)
1962 mp->history = mp_error_message_issued;
1963 mp_print_char (mp, xord ('.'));
1964 mp_show_context (mp);
1965 if (mp->halt_on_error) {
1966 mp->history = mp_fatal_error_stop;
1969 if ((!mp->noninteractive) && (mp->interaction == mp_error_stop_mode)) {
1970 @<Get user's advice and |return|@>;
1972 incr (mp->error_count);
1973 if (mp->error_count == 100) {
1974 mp_print_nl (mp, "(That makes
100 errors
; please try again.
)");
1975 @.That makes 100 errors...@>;
1976 mp->history = mp_fatal_error_stop;
1979 @<Put help message on the transcript file@>;
1983 @ @<Exported function ...@>=
1984 extern void mp_error (MP mp, const char *msg, const char **hlp, boolean deletions_allowed);
1985 extern void mp_warn (MP mp, const char *msg);
1988 @ @<Get user's advice...@>=
1991 mp_clear_for_error_prompt (mp);
1992 prompt_input ("?
");
1994 if (mp->last == mp->first)
1996 c = mp->buffer[mp->first];
1998 c = (ASCII_code) (c + 'A' - 'a'); /* convert to uppercase */
1999 @<Interpret code |c| and |return| if done@>;
2003 @ It is desirable to provide an `\.E' option here that gives the user
2004 an easy way to return from \MP\ to the system editor, with the offending
2005 line ready to be edited. But such an extension requires some system
2006 wizardry, so the present implementation simply types out the name of the
2008 edited and the relevant line number.
2009 @^system dependencies@>
2012 typedef void (*mp_editor_cmd) (MP, char *, int);
2014 @ @<Option variables@>=
2015 mp_editor_cmd run_editor;
2017 @ @<Allocate or initialize ...@>=
2018 set_callback_option (run_editor);
2021 static void mp_run_editor (MP mp, char *fname, int fline);
2024 void mp_run_editor (MP mp, char *fname, int fline) {
2025 char *s = xmalloc (256, 1);
2026 mp_snprintf (s, 256, "You want to edit file
%s at line
%d\n
", fname, fline);
2028 @.You want to edit file x@>
2034 @<Interpret code |c| and |return| if done@>=
2046 if (deletions_allowed) {
2047 @<Delete tokens and |continue|@>;
2051 if (mp->file_ptr > 0) {
2052 mp->interaction = mp_scroll_mode;
2053 mp_close_files_and_terminate (mp);
2054 (mp->run_editor) (mp,
2055 mp_str (mp, mp->input_stack[mp->file_ptr].name_field),
2061 @<Print the help information and |continue|@>;
2064 @<Introduce new material from the terminal and |return|@>;
2069 @<Change the interaction level and |return|@>;
2072 mp->interaction = mp_scroll_mode;
2078 @<Print the menu of available options@>
2081 @ @<Print the menu...@>=
2083 mp_print (mp, "Type
<return
> to proceed
, S to scroll future error messages
,");
2084 @.Type <return> to proceed...@>;
2085 mp_print_nl (mp, "R to run without stopping
, Q to run quietly
,");
2086 mp_print_nl (mp, "I to insert something
, ");
2087 if (mp->file_ptr > 0)
2088 mp_print (mp, "E to edit your file
,");
2089 if (deletions_allowed)
2091 "1 or ... or
9 to ignore the next
1 to
9 tokens of input
,");
2092 mp_print_nl (mp, "H for help
, X to quit.
");
2096 @ @<Change the interaction...@>=
2098 mp->error_count = 0;
2099 mp_print (mp, "OK, entering
");
2102 mp->interaction = mp_batch_mode;
2103 mp_print (mp, "batchmode
");
2104 decr (mp->selector);
2107 mp->interaction = mp_nonstop_mode;
2108 mp_print (mp, "nonstopmode
");
2111 mp->interaction = mp_scroll_mode;
2112 mp_print (mp, "scrollmode
");
2114 } /* there are no other cases */
2115 mp_print (mp, "...
");
2122 @ When the following code is executed, |buffer[(first+1)..(last-1)]| may
2123 contain the material inserted by the user; otherwise another prompt will
2124 be given. In order to understand this part of the program fully, you need
2125 to be familiar with \MP's input stacks.
2127 @<Introduce new material...@>=
2129 mp_begin_file_reading (mp); /* enter a new syntactic level for terminal input */
2130 if (mp->last > mp->first + 1) {
2131 loc = (halfword) (mp->first + 1);
2132 mp->buffer[mp->first] = xord (' ');
2134 prompt_input ("insert
>");
2135 loc = (halfword) mp->first;
2138 mp->first = mp->last + 1;
2139 mp->cur_input.limit_field = (halfword) mp->last;
2144 @ We allow deletion of up to 99 tokens at a time.
2146 @<Delete tokens...@>=
2151 mp->OK_to_interrupt = false;
2152 if ((mp->last > mp->first + 1) && (mp->buffer[mp->first + 1] >= '0')
2153 && (mp->buffer[mp->first + 1] <= '9'))
2154 c = xord (c * 10 + mp->buffer[mp->first + 1] - '0' * 11);
2156 c = (ASCII_code) (c - '0');
2158 mp_get_next (mp); /* one-level recursive call of |error| is possible */
2159 @<Decrease the string reference count, if the current token is a string@>;
2165 mp->OK_to_interrupt = true;
2167 help_line[1] = "I have just deleted some text
, as you asked.
";
2168 help_line[0] = "You can now delete more
, or insert
, or whatever.
";
2169 mp_show_context (mp);
2174 @ Some wriggling with |help_line| is done here to avoid giving no
2175 information whatsoever, or presenting the same information twice
2178 @<Print the help info...@>=
2180 if (mp->use_err_help) {
2181 @<Print the string |err_help|, possibly on several lines@>;
2182 mp->use_err_help = false;
2184 if (help_ptr == 0) {
2186 help_line[1] = "Sorry
, I don't know how to help in this situation.
";
2187 help_line[0] = "Maybe you should try asking a human?
";
2191 mp_print (mp, help_line[help_ptr]);
2193 } while (help_ptr != 0);
2196 help_line[3] = "Sorry
, I already gave what help I could...
";
2197 help_line[2] = "Maybe you should try asking a human?
";
2198 help_line[1] = "An error might have occurred before I noticed any problems.
";
2199 help_line[0] = "``If all else fails
, read the instructions.''
";
2204 @ @<Print the string |err_help|, possibly on several lines@>=
2207 while (j < mp->err_help->len) {
2208 if (*(mp->err_help->str + j) != '%')
2209 mp_print (mp, (const char *) (mp->err_help->str + j));
2210 else if (j + 1 == mp->err_help->len)
2212 else if (*(mp->err_help->str + j) != '%')
2216 mp_print_char (mp, xord ('%'));
2223 @ @<Put help message on the transcript file@>=
2224 if (mp->interaction > mp_batch_mode)
2225 decr (mp->selector); /* avoid terminal output */
2226 if (mp->use_err_help) {
2227 mp_print_nl (mp, "");
2228 @<Print the string |err_help|, possibly on several lines@>;
2230 while (help_ptr > 0) {
2232 mp_print_nl (mp, help_line[help_ptr]);
2235 if (mp->interaction > mp_batch_mode)
2236 incr (mp->selector); /* re-enable terminal output */
2241 @ In anomalous cases, the print selector might be in an unknown state;
2242 the following subroutine is called to fix things just enough to keep
2243 running a bit longer.
2246 void mp_normalize_selector (MP mp) {
2248 mp->selector = term_and_log;
2250 mp->selector = term_only;
2251 if (mp->job_name == NULL)
2252 mp_open_log_file (mp);
2253 if (mp->interaction == mp_batch_mode)
2254 decr (mp->selector);
2258 @ The following procedure prints \MP's last words before dying.
2261 void mp_fatal_error (MP mp, const char *s) { /* prints |s|, and that's it */
2262 const char *hlp[] = {s, NULL} ;
2263 mp_normalize_selector (mp);
2264 if ( mp->interaction==mp_error_stop_mode )
2265 mp->interaction=mp_scroll_mode; /* no more interaction */
2266 if ( mp->log_opened )
2267 mp_error(mp, "Emergency stop
", hlp, true);
2268 mp->history=mp_fatal_error_stop;
2269 mp_jump_out(mp); /* irrecoverable error */
2274 @ @<Exported function ...@>=
2275 extern void mp_fatal_error (MP mp, const char *s);
2278 @ @<Internal library declarations@>=
2279 void mp_overflow (MP mp, const char *s, integer n);
2282 @ @<Error hand...@>=
2283 void mp_overflow (MP mp, const char *s, integer n) { /* stop due to finiteness */
2285 const char *hlp[] = {
2286 "If you really absolutely need more capacity
,",
2287 "you can ask a wizard to enlarge me.
",
2289 mp_normalize_selector (mp);
2290 mp_snprintf (msg, 256, "MetaPost capacity exceeded
, sorry
[%s
=%d
]", s, (int) n);
2291 @.MetaPost capacity exceeded ...@>;
2292 if ( mp->interaction==mp_error_stop_mode )
2293 mp->interaction=mp_scroll_mode; /* no more interaction */
2294 if ( mp->log_opened )
2295 mp_error(mp, msg, hlp, true);
2296 mp->history=mp_fatal_error_stop;
2297 mp_jump_out(mp); /* irrecoverable error */
2301 @ The program might sometime run completely amok, at which point there is
2302 no choice but to stop. If no previous error has been detected, that's bad
2303 news; a message is printed that is really intended for the \MP\
2304 maintenance person instead of the user (unless the user has been
2305 particularly diabolical). The index entries for `this can't happen' may
2306 help to pinpoint the problem.
2309 @<Internal library ...@>=
2310 void mp_confusion (MP mp, const char *s);
2312 @ Consistency check violated; |s| tells where.
2314 void mp_confusion (MP mp, const char *s) {
2316 const char *hlp[] = {
2317 "One of your faux pas seems to have wounded me deeply...
",
2318 "in fact
, I'm barely conscious. Please fix it and try again.
",
2320 mp_normalize_selector (mp);
2321 if (mp->history < mp_error_message_issued) {
2322 mp_snprintf (msg, 256, "This can't happen
(%s
)", s);
2323 @.This can't happen@>;
2324 hlp[0] = "I'm broken. Please show this to someone who can fix can fix
";
2327 mp_snprintf (msg, 256, "I can\'t go on meeting you like this
");
2328 @.I can't go on...@>;
2330 if ( mp->interaction==mp_error_stop_mode )
2331 mp->interaction=mp_scroll_mode; /* no more interaction */
2332 if ( mp->log_opened )
2333 mp_error(mp, msg, hlp, true);
2334 mp->history=mp_fatal_error_stop;
2335 mp_jump_out(mp); /* irrecoverable error */
2339 @ Users occasionally want to interrupt \MP\ while it's running.
2340 If the runtime system allows this, one can implement
2341 a routine that sets the global variable |interrupt| to some nonzero value
2342 when such an interrupt is signaled. Otherwise there is probably at least
2343 a way to make |interrupt| nonzero using the C debugger.
2344 @^system dependencies@>
2347 @d check_interrupt { if ( mp->interrupt!=0 )
2348 mp_pause_for_instructions(mp); }
2351 integer interrupt; /* should \MP\ pause for instructions? */
2352 boolean OK_to_interrupt; /* should interrupts be observed? */
2353 integer run_state; /* are we processing input ? */
2354 boolean finished; /* set true by |close_files_and_terminate| */
2355 boolean reading_preload;
2357 @ @<Allocate or ...@>=
2358 mp->OK_to_interrupt = true;
2359 mp->finished = false;
2361 @ When an interrupt has been detected, the program goes into its
2362 highest interaction level and lets the user have the full flexibility of
2363 the |error| routine. \MP\ checks for interrupts only at times when it is
2367 static void mp_pause_for_instructions (MP mp) {
2368 const char *hlp[] = { "You rang?
",
2369 "Try to insert some instructions for me
(e.g.
,`I show x'
),",
2370 "unless you just want to quit by typing `
X'.
",
2372 if (mp->OK_to_interrupt) {
2373 mp->interaction = mp_error_stop_mode;
2374 if ((mp->selector == log_only) || (mp->selector == no_print))
2375 incr (mp->selector);
2377 mp_error (mp, "Interruption
", hlp, false);
2383 @* Arithmetic with scaled numbers.
2384 The principal computations performed by \MP\ are done entirely in terms of
2385 integers less than $2^{31}$ in magnitude; thus, the arithmetic specified in this
2386 program can be carried out in exactly the same way on a wide variety of
2387 computers, including some small ones.
2390 But C does not rigidly define the |/| operation in the case of negative
2391 dividends; for example, the result of |(-2*n-1) / 2| is |-(n+1)| on some
2392 computers and |-n| on others (is this true ?). There are two principal
2393 types of arithmetic: ``translation-preserving,'' in which the identity
2394 |(a+q*b)/b=(a/b)+q| is valid; and ``negation-preserving,'' in which
2395 |(-a)/b=-(a/b)|. This leads to two \MP s, which can produce
2396 different results, although the differences should be negligible when the
2397 language is being used properly. The \TeX\ processor has been defined
2398 carefully so that both varieties of arithmetic will produce identical
2399 output, but it would be too inefficient to constrain \MP\ in a similar way.
2401 @d inf_t ((math_data *)mp->math)->inf_t
2403 @ A single computation might use several subroutine calls, and it is
2404 desirable to avoid producing multiple error messages in case of arithmetic
2405 overflow. So the routines below set the global variable |arith_error| to |true|
2406 instead of reporting errors directly to the user.
2407 @^overflow in arithmetic@>
2410 boolean arith_error; /* has arithmetic overflow occurred recently? */
2412 @ @<Allocate or ...@>=
2413 mp->arith_error = false;
2415 @ At crucial points the program will say |check_arith|, to test if
2416 an arithmetic error has been detected.
2418 @d check_arith() do {
2419 if ( mp->arith_error )
2424 static void mp_clear_arith (MP mp) {
2425 const char *hlp[] = {
2426 "Uh
, oh. A little while ago one of the quantities that I was
",
2427 "computing got too large
, so I'm afraid your answers will be
",
2428 "somewhat askew. You'll probably have to adopt different
",
2429 "tactics next time. But I shall try to carry on anyway.
",
2431 mp_error (mp, "Arithmetic overflow
", hlp, true);
2432 @.Arithmetic overflow@>;
2433 mp->arith_error = false;
2437 @ The definitions of these are set up by the math initialization.
2439 @d arc_tol_k ((math_data *)mp->math)->arc_tol_k
2440 @d coef_bound_k ((math_data *)mp->math)->coef_bound_k
2441 @d coef_bound_minus_1 ((math_data *)mp->math)->coef_bound_minus_1
2442 @d sqrt_8_e_k ((math_data *)mp->math)->sqrt_8_e_k
2443 @d twelve_ln_2_k ((math_data *)mp->math)->twelve_ln_2_k
2444 @d twelvebits_3 ((math_data *)mp->math)->twelvebits_3
2445 @d one_k ((math_data *)mp->math)->one_k
2446 @d epsilon_t ((math_data *)mp->math)->epsilon_t
2447 @d unity_t ((math_data *)mp->math)->unity_t
2448 @d zero_t ((math_data *)mp->math)->zero_t
2449 @d two_t ((math_data *)mp->math)->two_t
2450 @d three_t ((math_data *)mp->math)->three_t
2451 @d half_unit_t ((math_data *)mp->math)->half_unit_t
2452 @d three_quarter_unit_t ((math_data *)mp->math)->three_quarter_unit_t
2453 @d twentysixbits_sqrt2_t ((math_data *)mp->math)->twentysixbits_sqrt2_t
2454 @d twentyeightbits_d_t ((math_data *)mp->math)->twentyeightbits_d_t
2455 @d twentysevenbits_sqrt2_d_t ((math_data *)mp->math)->twentysevenbits_sqrt2_d_t
2456 @d warning_limit_t ((math_data *)mp->math)->warning_limit_t
2457 @d precision_default ((math_data *)mp->math)->precision_default
2458 @d precision_max ((math_data *)mp->math)->precision_max
2459 @d precision_min ((math_data *)mp->math)->precision_min
2461 @ In fact, the two sorts of scaling discussed above aren't quite
2462 sufficient; \MP\ has yet another, used internally to keep track of angles.
2464 @ We often want to print two scaled quantities in parentheses,
2465 separated by a comma.
2467 @<Basic printing...@>=
2468 void mp_print_two (MP mp, mp_number x, mp_number y) { /* prints `|(x,y)|' */
2469 mp_print_char (mp, xord ('('));
2471 mp_print_char (mp, xord (','));
2473 mp_print_char (mp, xord (')'));
2478 @d fraction_one_t ((math_data *)mp->math)->fraction_one_t
2479 @d fraction_half_t ((math_data *)mp->math)->fraction_half_t
2480 @d fraction_three_t ((math_data *)mp->math)->fraction_three_t
2481 @d fraction_four_t ((math_data *)mp->math)->fraction_four_t
2483 @d one_eighty_deg_t ((math_data *)mp->math)->one_eighty_deg_t
2484 @d three_sixty_deg_t ((math_data *)mp->math)->three_sixty_deg_t
2486 @ @<Local variables for initialization@>=
2487 integer k; /* all-purpose loop index */
2489 @ And now let's complete our collection of numeric utility routines
2490 by considering random number generation.
2491 \MP\ generates pseudo-random numbers with the additive scheme recommended
2492 in Section 3.6 of {\sl The Art of Computer Programming}; however, the
2493 results are random fractions between 0 and |fraction_one-1|, inclusive.
2495 There's an auxiliary array |randoms| that contains 55 pseudo-random
2496 fractions. Using the recurrence $x_n=(x_{n-55}-x_{n-31})\bmod 2^{28}$,
2497 we generate batches of 55 new $x_n$'s at a time by calling |new_randoms|.
2498 The global variable |j_random| tells which element has most recently
2500 The global variable |random_seed| was introduced in version 0.9,
2501 for the sole reason of stressing the fact that the initial value of the
2502 random seed is system-dependant. The initialization code below will initialize
2503 this variable to |(internal[mp_time] div unity)+internal[mp_day]|, but this
2504 is not good enough on modern fast machines that are capable of running
2505 multiple MetaPost processes within the same second.
2506 @^system dependencies@>
2509 mp_number randoms[55]; /* the last 55 random values generated */
2510 int j_random; /* the number of unused |randoms| */
2512 @ @<Option variables@>=
2513 int random_seed; /* the default random seed */
2515 @ @<Allocate or initialize ...@>=
2516 mp->random_seed = opt->random_seed;
2519 for (i=0;i<55;i++) {
2520 new_fraction (mp->randoms[i]);
2527 for (i=0;i<55;i++) {
2528 free_number (mp->randoms[i]);
2532 @ @<Internal library ...@>=
2533 void mp_new_randoms (MP mp);
2536 void mp_new_randoms (MP mp) {
2537 int k; /* index into |randoms| */
2538 mp_number x; /* accumulator */
2540 for (k = 0; k <= 23; k++) {
2541 set_number_from_substraction(x, mp->randoms[k], mp->randoms[k + 31]);
2542 if (number_negative(x))
2543 number_add (x, fraction_one_t);
2544 number_clone (mp->randoms[k], x);
2546 for (k = 24; k <= 54; k++) {
2547 set_number_from_substraction(x, mp->randoms[k], mp->randoms[k - 24]);
2548 if (number_negative(x))
2549 number_add (x, fraction_one_t);
2550 number_clone (mp->randoms[k], x);
2556 @ To consume a random fraction, the program below will say `|next_random|'.
2559 static void mp_next_random (MP mp, mp_number *ret) {
2560 if ( mp->j_random==0 )
2564 number_clone (*ret, mp->randoms[mp->j_random]);
2568 @ To produce a uniform random number in the range |0<=u<x| or |0>=u>x|
2569 or |0=u=x|, given a |scaled| value~|x|, we proceed as shown here.
2571 Note that the call of |take_fraction| will produce the values 0 and~|x|
2572 with about half the probability that it will produce any other particular
2573 values between 0 and~|x|, because it rounds its answers.
2576 static void mp_unif_rand (MP mp, mp_number *ret, mp_number x_orig) {
2577 mp_number y; /* trial value */
2584 number_clone (x, x_orig);
2585 number_clone (abs_x, x);
2587 mp_next_random(mp, &u);
2588 take_fraction (y, abs_x, u);
2590 if (number_equal(y, abs_x)) {
2591 set_number_to_zero(*ret);
2592 } else if (number_positive(x)) {
2593 number_clone (*ret, y);
2595 number_clone (*ret, y);
2596 number_negate (*ret);
2598 free_number (abs_x);
2604 @ Finally, a normal deviate with mean zero and unit standard deviation
2605 can readily be obtained with the ratio method (Algorithm 3.4.1R in
2606 {\sl The Art of Computer Programming\/}).
2609 static void mp_norm_rand (MP mp, mp_number *ret) {
2615 new_number (ab_vs_cd);
2625 mp_next_random(mp, &v);
2626 number_substract (v, fraction_half_t);
2627 take_fraction (xa, sqrt_8_e_k, v);
2629 mp_next_random(mp, &u);
2630 number_clone (abs_x, xa);
2632 } while (number_greaterequal (abs_x, u));
2633 make_fraction (r, xa, u);
2634 number_clone (xa, r);
2636 set_number_from_substraction(la, twelve_ln_2_k, la);
2637 ab_vs_cd (ab_vs_cd, one_k, la, xa, xa);
2638 } while (number_negative(ab_vs_cd));
2639 number_clone (*ret, xa);
2640 free_number (ab_vs_cd);
2642 free_number (abs_x);
2651 @d max_quarterword 0x3FFF /* largest allowable value in a |quarterword| */
2652 @d max_halfword 0xFFFFFFF /* largest allowable value in a |halfword| */
2654 @ The macros |qi| and |qo| are used for input to and output
2655 from quarterwords. These are legacy macros.
2656 @^system dependencies@>
2658 @d qo(A) (A) /* to read eight bits from a quarterword */
2659 @d qi(A) (quarterword)(A) /* to store eight bits in a quarterword */
2661 @ The reader should study the following definitions closely:
2662 @^system dependencies@>
2665 typedef struct mp_value_node_data *mp_value_node;
2666 typedef struct mp_node_data *mp_node;
2667 typedef struct mp_symbol_entry *mp_sym;
2668 typedef short quarterword; /* 1/4 of a word */
2669 typedef int halfword; /* 1/2 of a word */
2671 integer scale; /* only for |indep_scale|, used together with |serial| */
2672 integer serial; /* only for |indep_value|, used together with |scale| */
2673 } mp_independent_data;
2675 mp_independent_data indep;
2683 mp_variable_type type;
2687 quarterword b0, b1, b2, b3;
2695 @ The global variable |math_mode| has four settings, representing the
2696 math value type that will be used in this run.
2698 the typedef for |mp_number| is here because it has to come very early.
2702 mp_math_scaled_mode = 0,
2703 mp_math_double_mode = 1,
2704 mp_math_binary_mode = 2,
2705 mp_math_decimal_mode = 3
2708 @ @<Option variables@>=
2709 int math_mode; /* math mode */
2711 @ @<Allocate or initialize ...@>=
2712 mp->math_mode = opt->math_mode;
2715 @d xfree(A) do { mp_xfree(A); A=NULL; } while (0)
2716 @d xrealloc(P,A,B) mp_xrealloc(mp,P,(size_t)A,B)
2717 @d xmalloc(A,B) mp_xmalloc(mp,(size_t)A,B)
2718 @d xstrdup(A) mp_xstrdup(mp,A)
2719 @d XREALLOC(a,b,c) a = xrealloc(a,(b+1),sizeof(c));
2721 @<Declare helpers@>=
2722 extern void mp_xfree (void *x);
2723 extern void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size);
2724 extern void *mp_xmalloc (MP mp, size_t nmem, size_t size);
2725 extern void mp_do_snprintf (char *str, int size, const char *fmt, ...);
2726 extern void *do_alloc_node(MP mp, size_t size);
2728 @ This is an attempt to spend less time in |malloc()|:
2730 @d max_num_token_nodes 1000
2731 @d max_num_pair_nodes 1000
2732 @d max_num_knot_nodes 1000
2733 @d max_num_value_nodes 1000
2734 @d max_num_symbolic_nodes 1000
2737 mp_node token_nodes;
2738 int num_token_nodes;
2743 mp_node value_nodes;
2744 int num_value_nodes;
2745 mp_node symbolic_nodes;
2746 int num_symbolic_nodes;
2748 @ @<Allocate or initialize ...@>=
2749 mp->token_nodes = NULL;
2750 mp->num_token_nodes = 0;
2751 mp->pair_nodes = NULL;
2752 mp->num_pair_nodes = 0;
2753 mp->knot_nodes = NULL;
2754 mp->num_knot_nodes = 0;
2755 mp->value_nodes = NULL;
2756 mp->num_value_nodes = 0;
2757 mp->symbolic_nodes = NULL;
2758 mp->num_symbolic_nodes = 0;
2761 while (mp->value_nodes) {
2762 mp_node p = mp->value_nodes;
2763 mp->value_nodes = p->link;
2764 mp_free_node(mp,p,value_node_size);
2766 while (mp->symbolic_nodes) {
2767 mp_node p = mp->symbolic_nodes;
2768 mp->symbolic_nodes = p->link;
2769 mp_free_node(mp,p,symbolic_node_size);
2771 while (mp->pair_nodes) {
2772 mp_node p = mp->pair_nodes;
2773 mp->pair_nodes = p->link;
2774 mp_free_node(mp,p,pair_node_size);
2776 while (mp->token_nodes) {
2777 mp_node p = mp->token_nodes;
2778 mp->token_nodes = p->link;
2779 mp_free_node(mp,p,token_node_size);
2781 while (mp->knot_nodes) {
2782 mp_knot p = mp->knot_nodes;
2783 mp->knot_nodes = p->next;
2787 @ This is a nicer way of allocating nodes.
2789 @d malloc_node(A) do_alloc_node(mp,(A))
2793 void *do_alloc_node (MP mp, size_t size) {
2795 p = xmalloc(1,size);
2796 add_var_used (size);
2797 ((mp_node)p)->link = NULL;
2798 ((mp_node)p)->has_number = 0;
2803 @ The |max_size_test| guards against overflow, on the assumption that
2804 |size_t| is at least 31bits wide.
2806 @d max_size_test 0x7FFFFFFF
2809 void mp_xfree (void *x) {
2813 void *mp_xrealloc (MP mp, void *p, size_t nmem, size_t size) {
2815 if ((max_size_test / size) < nmem) {
2816 mp_fputs ("Memory size overflow
!\n
", mp->err_out);
2817 mp->history = mp_fatal_error_stop;
2820 w = realloc (p, (nmem * size));
2822 mp_fputs ("Out of memory
!\n
", mp->err_out);
2823 mp->history = mp_system_error_stop;
2828 void *mp_xmalloc (MP mp, size_t nmem, size_t size) {
2831 if ((max_size_test / size) < nmem) {
2832 mp_fputs ("Memory size overflow
!\n
", mp->err_out);
2833 mp->history = mp_fatal_error_stop;
2837 w = malloc (nmem * size);
2839 mp_fputs ("Out of memory
!\n
", mp->err_out);
2840 mp->history = mp_system_error_stop;
2846 @ @<Internal library declarations@>=
2847 # define mp_snprintf (void)snprintf
2849 @* Dynamic memory allocation.
2851 The \MP\ system does nearly all of its own memory allocation, so that it
2852 can readily be transported into environments that do not have automatic
2853 facilities for strings, garbage collection, etc., and so that it can be in
2854 control of what error messages the user receives.
2856 @d MP_VOID (mp_node)(1) /* |NULL+1|, a |NULL| pointer different from |NULL| */
2858 @d mp_link(A) (A)->link /* the |link| field of a node */
2859 @d set_mp_link(A,B) do {
2861 /* |printf("set link of
%p to
%p on line
%d\n
", (A), d, __LINE__);| */
2864 @d mp_type(A) (A)->type /* identifies what kind of value this is */
2865 @d mp_name_type(A) (A)->name_type /* a clue to the name of this value */
2867 @ @<MPlib internal header stuff@>=
2869 mp_variable_type type; \
2870 mp_name_type_type name_type; \
2871 unsigned short has_number; \
2872 struct mp_node_data *link
2873 typedef struct mp_node_data {
2877 typedef struct mp_node_data *mp_symbolic_node;
2879 @ Users who wish to study the memory requirements of particular applications can
2880 can use the special features that keep track of current and maximum memory usage.
2881 \MP\ will report these statistics when |mp_tracing_stats| is positive.
2883 @d add_var_used(a) do {
2885 if (mp->var_used>mp->var_used_max) mp->var_used_max=mp->var_used;
2889 size_t var_used; /* how much memory is in use */
2890 size_t var_used_max; /* how much memory was in use max */
2892 @ These redirect to function to aid in debugging.
2896 #define mp_sym_info(A) get_mp_sym_info(mp,(A))
2897 #define set_mp_sym_info(A,B) do_set_mp_sym_info(mp,(A),(B))
2898 #define mp_sym_sym(A) get_mp_sym_sym(mp,(A))
2899 #define set_mp_sym_sym(A,B) do_set_mp_sym_sym(mp,(A),(mp_sym)(B))
2900 static void do_set_mp_sym_info (MP mp, mp_node p, halfword v) {
2901 FUNCTION_TRACE3 ("do_set_mp_sym_info
(%p
,%d
)\n
", p, v);
2902 assert (p->type == mp_symbol_node);
2903 set_indep_value(p, v);
2905 static halfword get_mp_sym_info (MP mp, mp_node p) {
2906 FUNCTION_TRACE3 ("%d
= get_mp_sym_info
(%p
)\n
", indep_value (p), p);
2907 assert (p->type == mp_symbol_node);
2908 return indep_value(p);
2910 static void do_set_mp_sym_sym (MP mp, mp_node p, mp_sym v) {
2911 mp_symbolic_node pp = (mp_symbolic_node) p;
2912 FUNCTION_TRACE3 ("do_set_mp_sym_sym
(%p
,%p
)\n
", pp, v);
2913 assert (pp->type == mp_symbol_node);
2916 static mp_sym get_mp_sym_sym (MP mp, mp_node p) {
2917 mp_symbolic_node pp = (mp_symbolic_node) p;
2918 FUNCTION_TRACE3 ("%p
= get_mp_sym_sym
(%p
)\n
", pp->data.sym, pp);
2919 assert (pp->type == mp_symbol_node);
2920 return pp->data.sym;
2923 #define mp_sym_info(A) indep_value(A)
2924 #define set_mp_sym_info(A,B) set_indep_value(A, (B))
2925 #define mp_sym_sym(A) (A)->data.sym
2926 #define set_mp_sym_sym(A,B) (A)->data.sym = (mp_sym)(B)
2931 static void do_set_mp_sym_info (MP mp, mp_node A, halfword B);
2932 static halfword get_mp_sym_info (MP mp, mp_node p);
2933 static void do_set_mp_sym_sym (MP mp, mp_node A, mp_sym B);
2934 static mp_sym get_mp_sym_sym (MP mp, mp_node p);
2937 @ The function |get_symbolic_node| returns a pointer to a new symbolic node whose
2938 |link| field is null.
2941 @d symbolic_node_size sizeof(mp_node_data)
2943 static mp_node mp_get_symbolic_node (MP mp) {
2945 if (mp->symbolic_nodes) {
2946 p = (mp_symbolic_node)mp->symbolic_nodes;
2947 mp->symbolic_nodes = p->link;
2948 mp->num_symbolic_nodes--;
2951 p = malloc_node (symbolic_node_size);
2952 new_number(p->data.n);
2955 p->type = mp_symbol_node;
2956 p->name_type = mp_normal_sym;
2957 FUNCTION_TRACE2 ("%p
= mp_get_symbolic_node
()\n
", p);
2962 @ Conversely, when some node |p| of size |s| is no longer needed,
2963 the operation |free_node(p,s)| will make its words available, by inserting
2964 |p| as a new empty node just before where |rover| now points.
2966 A symbolic node is recycled by calling |free_symbolic_node|.
2969 void mp_free_node (MP mp, mp_node p, size_t siz) { /* node liberation */
2970 FUNCTION_TRACE3 ("mp_free_node
(%p
,%d
)\n
", p, (int)siz);
2972 mp->var_used -= siz;
2973 if (mp->math_mode > mp_math_double_mode) {
2974 if (p->has_number >= 1 && is_number(((mp_symbolic_node)p)->data.n)) {
2975 free_number(((mp_symbolic_node)p)->data.n);
2977 if (p->has_number == 2 && is_number(((mp_value_node)p)->subscript_)) {
2978 free_number(((mp_value_node)p)->subscript_);
2980 /* There was a quite large |switch| here first, but the |mp_dash_node|
2981 case was the only one that did anything ... */
2982 if (mp_type (p) == mp_dash_node_type) {
2983 free_number(((mp_dash_node)p)->start_x);
2984 free_number(((mp_dash_node)p)->stop_x);
2985 free_number(((mp_dash_node)p)->dash_y);
2990 void mp_free_symbolic_node (MP mp, mp_node p) { /* node liberation */
2991 FUNCTION_TRACE2 ("mp_free_symbolic_node
(%p
)\n
", p);
2993 if (mp->num_symbolic_nodes < max_num_symbolic_nodes) {
2994 p->link = mp->symbolic_nodes;
2995 mp->symbolic_nodes = p;
2996 mp->num_symbolic_nodes++;
2999 mp->var_used -= symbolic_node_size;
3002 void mp_free_value_node (MP mp, mp_node p) { /* node liberation */
3003 FUNCTION_TRACE2 ("mp_free_value_node
(%p
)\n
", p);
3005 if (mp->num_value_nodes < max_num_value_nodes) {
3006 p->link = mp->value_nodes;
3007 mp->value_nodes = p;
3008 mp->num_value_nodes++;
3011 mp->var_used -= value_node_size;
3012 assert(p->has_number == 2);
3013 if (mp->math_mode > mp_math_double_mode) {
3014 free_number(((mp_value_node)p)->data.n);
3015 free_number(((mp_value_node)p)->subscript_);
3021 @ @<Internal library declarations@>=
3022 void mp_free_node (MP mp, mp_node p, size_t siz);
3023 void mp_free_symbolic_node (MP mp, mp_node p);
3024 void mp_free_value_node (MP mp, mp_node p);
3027 Some nodes are created statically, since static allocation is
3028 more efficient than dynamic allocation when we can get away with it.
3031 mp_dash_node null_dash;
3032 mp_value_node dep_head;
3042 @ The following code gets the memory off to a good start.
3044 @<Initialize table entries@>=
3045 mp->spec_head = mp_get_symbolic_node (mp);
3046 mp->last_pending = mp->spec_head;
3047 mp->temp_head = mp_get_symbolic_node (mp);
3048 mp->hold_head = mp_get_symbolic_node (mp);
3050 @ @<Free table entries@>=
3051 mp_free_symbolic_node (mp, mp->spec_head);
3052 mp_free_symbolic_node (mp, mp->temp_head);
3053 mp_free_symbolic_node (mp, mp->hold_head);
3055 @ The procedure |flush_node_list(p)| frees an entire linked list of
3056 nodes that starts at a given position, until coming to a |NULL| pointer.
3060 static void mp_flush_node_list (MP mp, mp_node p) {
3061 mp_node q; /* the node being recycled */
3062 FUNCTION_TRACE2 ("mp_flush_node_list
(%p
)\n
", p);
3066 if (q->type != mp_symbol_node)
3067 mp_free_token_node (mp, q);
3069 mp_free_symbolic_node (mp, q);
3074 @* The command codes.
3075 Before we can go much further, we need to define symbolic names for the internal
3076 code numbers that represent the various commands obeyed by \MP. These codes
3077 are somewhat arbitrary, but not completely so. For example,
3078 some codes have been made adjacent so that |case| statements in the
3079 program need not consider cases that are widely spaced, or so that |case|
3080 statements can be replaced by |if| statements. A command can begin an
3081 expression if and only if its code lies between |min_primary_command| and
3082 |max_primary_command|, inclusive. The first token of a statement that doesn't
3083 begin with an expression has a command code between |min_command| and
3084 |max_statement_command|, inclusive. Anything less than |min_command| is
3085 eliminated during macro expansions, and anything no more than |max_pre_command|
3086 is eliminated when expanding \TeX\ material. Ranges such as
3087 |min_secondary_command..max_secondary_command| are used when parsing
3088 expressions, but the relative ordering within such a range is generally not
3091 The ordering of the highest-numbered commands
3092 (|comma<semicolon<end_group<stop|) is crucial for the parsing and
3093 error-recovery methods of this program as is the ordering |if_test<fi_or_else|
3094 for the smallest two commands. The ordering is also important in the ranges
3095 |numeric_token..plus_or_minus| and |left_brace..ampersand|.
3097 At any rate, here is the list, for future reference.
3099 @d mp_max_command_code mp_stop
3100 @d mp_max_pre_command mp_mpx_break
3101 @d mp_min_command (mp_defined_macro+1)
3102 @d mp_max_statement_command mp_type_name
3103 @d mp_min_primary_command mp_type_name
3104 @d mp_min_suffix_token mp_internal_quantity
3105 @d mp_max_suffix_token mp_numeric_token
3106 @d mp_max_primary_command mp_plus_or_minus /* should also be |numeric_token+1| */
3107 @d mp_min_tertiary_command mp_plus_or_minus
3108 @d mp_max_tertiary_command mp_tertiary_binary
3109 @d mp_min_expression_command mp_left_brace
3110 @d mp_max_expression_command mp_equals
3111 @d mp_min_secondary_command mp_and_command
3112 @d mp_max_secondary_command mp_secondary_binary
3113 @d mp_end_of_statement (cur_cmd()>mp_comma)
3116 @<Enumeration types@>=
3118 mp_start_tex=1, /* begin \TeX\ material (\&{btex}, \&{verbatimtex}) */
3119 mp_etex_marker, /* end \TeX\ material (\&{etex}) */
3120 mp_mpx_break, /* stop reading an \.{MPX} file (\&{mpxbreak}) */
3121 mp_if_test, /* conditional text (\&{if}) */
3122 mp_fi_or_else, /* delimiters for conditionals (\&{elseif}, \&{else}, \&{fi}) */
3123 mp_input, /* input a source file (\&{input}, \&{endinput}) */
3124 mp_iteration, /* iterate (\&{for}, \&{forsuffixes}, \&{forever}, \&{endfor}) */
3125 mp_repeat_loop, /* special command substituted for \&{endfor} */
3126 mp_exit_test, /* premature exit from a loop (\&{exitif}) */
3127 mp_relax, /* do nothing (\.{\char`\\}) */
3128 mp_scan_tokens, /* put a string into the input buffer */
3129 mp_runscript, /* put a script result string into the input buffer */
3130 mp_expand_after, /* look ahead one token */
3131 mp_defined_macro, /* a macro defined by the user */
3132 mp_save_command, /* save a list of tokens (\&{save}) */
3133 mp_interim_command, /* save an internal quantity (\&{interim}) */
3134 mp_let_command, /* redefine a symbolic token (\&{let}) */
3135 mp_new_internal, /* define a new internal quantity (\&{newinternal}) */
3136 mp_macro_def, /* define a macro (\&{def}, \&{vardef}, etc.) */
3137 mp_ship_out_command, /* output a character (\&{shipout}) */
3138 mp_add_to_command, /* add to edges (\&{addto}) */
3139 mp_bounds_command, /* add bounding path to edges (\&{setbounds}, \&{clip}) */
3140 mp_tfm_command, /* command for font metric info (\&{ligtable}, etc.) */
3141 mp_protection_command, /* set protection flag (\&{outer}, \&{inner}) */
3142 mp_show_command, /* diagnostic output (\&{show}, \&{showvariable}, etc.) */
3143 mp_mode_command, /* set interaction level (\&{batchmode}, etc.) */
3144 mp_random_seed, /* initialize random number generator (\&{randomseed}) */
3145 mp_message_command, /* communicate to user (\&{message}, \&{errmessage}) */
3146 mp_every_job_command, /* designate a starting token (\&{everyjob}) */
3147 mp_delimiters, /* define a pair of delimiters (\&{delimiters}) */
3148 mp_special_command, /* output special info (\&{special})
3149 or font map info (\&{fontmapfile}, \&{fontmapline}) */
3150 mp_write_command, /* write text to a file (\&{write}) */
3151 mp_type_name, /* declare a type (\&{numeric}, \&{pair}, etc.) */
3152 mp_left_delimiter, /* the left delimiter of a matching pair */
3153 mp_begin_group, /* beginning of a group (\&{begingroup}) */
3154 mp_nullary, /* an operator without arguments (e.g., \&{normaldeviate}) */
3155 mp_unary, /* an operator with one argument (e.g., \&{sqrt}) */
3156 mp_str_op, /* convert a suffix to a string (\&{str}) */
3157 mp_cycle, /* close a cyclic path (\&{cycle}) */
3158 mp_primary_binary, /* binary operation taking `\&{of}' (e.g., \&{point}) */
3159 mp_capsule_token, /* a value that has been put into a token list */
3160 mp_string_token, /* a string constant (e.g., |"hello
"|) */
3161 mp_internal_quantity, /* internal numeric parameter (e.g., \&{pausing}) */
3162 mp_tag_token, /* a symbolic token without a primitive meaning */
3163 mp_numeric_token, /* a numeric constant (e.g., \.{3.14159}) */
3164 mp_plus_or_minus, /* either `\.+' or `\.-' */
3165 mp_tertiary_secondary_macro, /* a macro defined by \&{secondarydef} */
3166 mp_tertiary_binary, /* an operator at the tertiary level (e.g., `\.{++}') */
3167 mp_left_brace, /* the operator `\.{\char`\{}' */
3168 mp_path_join, /* the operator `\.{..}' */
3169 mp_ampersand, /* the operator `\.\&' */
3170 mp_expression_tertiary_macro, /* a macro defined by \&{tertiarydef} */
3171 mp_expression_binary, /* an operator at the expression level (e.g., `\.<') */
3172 mp_equals, /* the operator `\.=' */
3173 mp_and_command, /* the operator `\&{and}' */
3174 mp_secondary_primary_macro, /* a macro defined by \&{primarydef} */
3175 mp_slash, /* the operator `\./' */
3176 mp_secondary_binary, /* an operator at the binary level (e.g., \&{shifted}) */
3177 mp_param_type, /* type of parameter (\&{primary}, \&{expr}, \&{suffix}, etc.) */
3178 mp_controls, /* specify control points explicitly (\&{controls}) */
3179 mp_tension, /* specify tension between knots (\&{tension}) */
3180 mp_at_least, /* bounded tension value (\&{atleast}) */
3181 mp_curl_command, /* specify curl at an end knot (\&{curl}) */
3182 mp_macro_special, /* special macro operators (\&{quote}, \.{\#\AT!}, etc.) */
3183 mp_right_delimiter, /* the right delimiter of a matching pair */
3184 mp_left_bracket, /* the operator `\.[' */
3185 mp_right_bracket, /* the operator `\.]' */
3186 mp_right_brace, /* the operator `\.{\char`\}}' */
3187 mp_with_option, /* option for filling (\&{withpen}, \&{withweight}, etc.) */
3189 /* variant of \&{addto} (\&{contour}, \&{doublepath}, \&{also}) */
3190 mp_of_token, /* the operator `\&{of}' */
3191 mp_to_token, /* the operator `\&{to}' */
3192 mp_step_token, /* the operator `\&{step}' */
3193 mp_until_token, /* the operator `\&{until}' */
3194 mp_within_token, /* the operator `\&{within}' */
3196 /* the operators `\&{kern}' and `\.{=:}' and `\.{=:\char'174}', etc. */
3197 mp_assignment, /* the operator `\.{:=}' */
3198 mp_skip_to, /* the operation `\&{skipto}' */
3199 mp_bchar_label, /* the operator `\.{\char'174\char'174:}' */
3200 mp_double_colon, /* the operator `\.{::}' */
3201 mp_colon, /* the operator `\.:' */
3203 mp_comma, /* the operator `\.,', must be |colon+1| */
3204 mp_semicolon, /* the operator `\.;', must be |comma+1| */
3205 mp_end_group, /* end a group (\&{endgroup}), must be |semicolon+1| */
3206 mp_stop, /* end a job (\&{end}, \&{dump}), must be |end_group+1| */
3207 mp_outer_tag, /* protection code added to command code */
3208 mp_undefined_cs, /* protection code added to command code */
3211 @ Variables and capsules in \MP\ have a variety of ``types,''
3212 distinguished by the code numbers defined here. These numbers are also
3213 not completely arbitrary. Things that get expanded must have types
3214 |>mp_independent|; a type remaining after expansion is numeric if and only if
3215 its code number is at least |numeric_type|; objects containing numeric
3216 parts must have types between |transform_type| and |pair_type|;
3217 all other types must be smaller than |transform_type|; and among the types
3218 that are not unknown or vacuous, the smallest two must be |boolean_type|
3219 and |string_type| in that order.
3221 @d unknown_tag 1 /* this constant is added to certain type codes below */
3222 @d unknown_types mp_unknown_boolean: case mp_unknown_string:
3223 case mp_unknown_pen: case mp_unknown_picture: case mp_unknown_path
3225 @<Enumeration types@>=
3227 mp_undefined = 0, /* no type has been declared */
3228 mp_vacuous, /* no expression was present */
3229 mp_boolean_type, /* \&{boolean} with a known value */
3231 mp_string_type, /* \&{string} with a known value */
3233 mp_pen_type, /* \&{pen} with a known value */
3235 mp_path_type, /* \&{path} with a known value */
3237 mp_picture_type, /* \&{picture} with a known value */
3239 mp_transform_type, /* \&{transform} variable or capsule */
3240 mp_color_type, /* \&{color} variable or capsule */
3241 mp_cmykcolor_type, /* \&{cmykcolor} variable or capsule */
3242 mp_pair_type, /* \&{pair} variable or capsule */
3243 mp_numeric_type, /* variable that has been declared \&{numeric} but not used */
3244 mp_known, /* \&{numeric} with a known value */
3245 mp_dependent, /* a linear combination with |fraction| coefficients */
3246 mp_proto_dependent, /* a linear combination with |scaled| coefficients */
3247 mp_independent, /* \&{numeric} with unknown value */
3248 mp_token_list, /* variable name or suffix argument or text argument */
3249 mp_structured, /* variable with subscripts and attributes */
3250 mp_unsuffixed_macro, /* variable defined with \&{vardef} but no \.{\AT!\#} */
3251 mp_suffixed_macro, /* variable defined with \&{vardef} and \.{\AT!\#} */
3252 /* here are some generic node types */
3257 mp_subscr_node_type,
3259 mp_transform_node_type,
3261 mp_cmykcolor_node_type,
3262 /* it is important that the next 7 items remain in this order, for export */
3264 mp_stroked_node_type,
3266 mp_start_clip_node_type,
3267 mp_start_bounds_node_type,
3268 mp_stop_clip_node_type,
3269 mp_stop_bounds_node_type,
3273 mp_edge_header_node_type,
3277 static void mp_print_type (MP mp, quarterword t);
3279 @ @<Basic printing procedures@>=
3280 static const char *mp_type_string (quarterword t) {
3281 const char *s = NULL;
3289 case mp_boolean_type:
3292 case mp_unknown_boolean:
3293 s = "unknown boolean
";
3295 case mp_string_type:
3298 case mp_unknown_string:
3299 s = "unknown string
";
3304 case mp_unknown_pen:
3310 case mp_unknown_path:
3313 case mp_picture_type:
3316 case mp_unknown_picture:
3317 s = "unknown picture
";
3319 case mp_transform_type:
3325 case mp_cmykcolor_type:
3332 s = "known numeric
";
3337 case mp_proto_dependent:
3338 s = "proto-dependent
";
3340 case mp_numeric_type:
3343 case mp_independent:
3350 s = "mp_structured
";
3352 case mp_unsuffixed_macro:
3353 s = "unsuffixed macro
";
3355 case mp_suffixed_macro:
3356 s = "suffixed macro
";
3358 case mp_symbol_node:
3361 case mp_token_node_type:
3364 case mp_value_node_type:
3367 case mp_attr_node_type:
3368 s = "attribute node
";
3370 case mp_subscr_node_type:
3371 s = "subscript node
";
3373 case mp_pair_node_type:
3376 case mp_transform_node_type:
3377 s = "transform node
";
3379 case mp_color_node_type:
3382 case mp_cmykcolor_node_type:
3383 s = "cmykcolor node
";
3385 case mp_fill_node_type:
3388 case mp_stroked_node_type:
3391 case mp_text_node_type:
3394 case mp_start_clip_node_type:
3395 s = "start clip node
";
3397 case mp_start_bounds_node_type:
3398 s = "start bounds node
";
3400 case mp_stop_clip_node_type:
3401 s = "stop clip node
";
3403 case mp_stop_bounds_node_type:
3404 s = "stop bounds node
";
3406 case mp_dash_node_type:
3409 case mp_dep_node_type:
3410 s = "dependency node
";
3412 case mp_if_node_type:
3415 case mp_edge_header_node_type:
3416 s = "edge header node
";
3421 mp_snprintf (ss, 256, "<unknown type
%d
>", t);
3428 void mp_print_type (MP mp, quarterword t) {
3429 if (t >= 0 && t <= mp_edge_header_node_type)
3430 mp_print (mp, mp_type_string (t));
3432 mp_print (mp, "unknown
");
3436 @ Values inside \MP\ are stored in non-symbolic nodes that have a |name_type|
3437 as well as a |type|. The possibilities for |name_type| are defined
3438 here; they will be explained in more detail later.
3440 @<Enumeration types...@>=
3442 mp_root = 0, /* |name_type| at the top level of a variable */
3443 mp_saved_root, /* same, when the variable has been saved */
3444 mp_structured_root, /* |name_type| where a |mp_structured| branch occurs */
3445 mp_subscr, /* |name_type| in a subscript node */
3446 mp_attr, /* |name_type| in an attribute node */
3447 mp_x_part_sector, /* |name_type| in the \&{xpart} of a node */
3448 mp_y_part_sector, /* |name_type| in the \&{ypart} of a node */
3449 mp_xx_part_sector, /* |name_type| in the \&{xxpart} of a node */
3450 mp_xy_part_sector, /* |name_type| in the \&{xypart} of a node */
3451 mp_yx_part_sector, /* |name_type| in the \&{yxpart} of a node */
3452 mp_yy_part_sector, /* |name_type| in the \&{yypart} of a node */
3453 mp_red_part_sector, /* |name_type| in the \&{redpart} of a node */
3454 mp_green_part_sector, /* |name_type| in the \&{greenpart} of a node */
3455 mp_blue_part_sector, /* |name_type| in the \&{bluepart} of a node */
3456 mp_cyan_part_sector, /* |name_type| in the \&{redpart} of a node */
3457 mp_magenta_part_sector, /* |name_type| in the \&{greenpart} of a node */
3458 mp_yellow_part_sector, /* |name_type| in the \&{bluepart} of a node */
3459 mp_black_part_sector, /* |name_type| in the \&{greenpart} of a node */
3460 mp_grey_part_sector, /* |name_type| in the \&{bluepart} of a node */
3461 mp_capsule, /* |name_type| in stashed-away subexpressions */
3462 mp_token, /* |name_type| in a numeric token or string token */
3463 /* Symbolic nodes also have |name_type|, which is a different enumeration */
3465 mp_internal_sym, /* for values of internals */
3466 mp_macro_sym, /* for macro names */
3467 mp_expr_sym, /* for macro parameters if type |expr| */
3468 mp_suffix_sym, /* for macro parameters if type |suffix| */
3469 mp_text_sym, /* for macro parameters if type |text| */
3471 } mp_name_type_type;
3473 @ Primitive operations that produce values have a secondary identification
3474 code in addition to their command code; it's something like genera and species.
3475 For example, `\.*' has the command code |primary_binary|, and its
3476 secondary identification is |times|. The secondary codes start such that
3477 they don't overlap with the type codes; some type codes (e.g., |mp_string_type|)
3478 are used as operators as well as type identifications. The relative values
3479 are not critical, except for |true_code..false_code|, |or_op..and_op|,
3480 and |filled_op..bounded_op|. The restrictions are that
3481 |and_op-false_code=or_op-true_code|, that the ordering of
3482 |x_part...blue_part| must match that of |x_part_sector..mp_blue_part_sector|,
3483 and the ordering of |filled_op..bounded_op| must match that of the code
3484 values they test for.
3486 @d mp_min_of mp_substring_of
3488 @<Operation codes@>=
3489 mp_true_code, /* operation code for \.{true} */
3490 mp_false_code, /* operation code for \.{false} */
3491 mp_null_picture_code, /* operation code for \.{nullpicture} */
3492 mp_null_pen_code, /* operation code for \.{nullpen} */
3493 mp_read_string_op, /* operation code for \.{readstring} */
3494 mp_pen_circle, /* operation code for \.{pencircle} */
3495 mp_normal_deviate, /* operation code for \.{normaldeviate} */
3496 mp_read_from_op, /* operation code for \.{readfrom} */
3497 mp_close_from_op, /* operation code for \.{closefrom} */
3498 mp_odd_op, /* operation code for \.{odd} */
3499 mp_known_op, /* operation code for \.{known} */
3500 mp_unknown_op, /* operation code for \.{unknown} */
3501 mp_not_op, /* operation code for \.{not} */
3502 mp_decimal, /* operation code for \.{decimal} */
3503 mp_reverse, /* operation code for \.{reverse} */
3504 mp_make_path_op, /* operation code for \.{makepath} */
3505 mp_make_pen_op, /* operation code for \.{makepen} */
3506 mp_oct_op, /* operation code for \.{oct} */
3507 mp_hex_op, /* operation code for \.{hex} */
3508 mp_ASCII_op, /* operation code for \.{ASCII} */
3509 mp_char_op, /* operation code for \.{char} */
3510 mp_length_op, /* operation code for \.{length} */
3511 mp_turning_op, /* operation code for \.{turningnumber} */
3512 mp_color_model_part, /* operation code for \.{colormodel} */
3513 mp_x_part, /* operation code for \.{xpart} */
3514 mp_y_part, /* operation code for \.{ypart} */
3515 mp_xx_part, /* operation code for \.{xxpart} */
3516 mp_xy_part, /* operation code for \.{xypart} */
3517 mp_yx_part, /* operation code for \.{yxpart} */
3518 mp_yy_part, /* operation code for \.{yypart} */
3519 mp_red_part, /* operation code for \.{redpart} */
3520 mp_green_part, /* operation code for \.{greenpart} */
3521 mp_blue_part, /* operation code for \.{bluepart} */
3522 mp_cyan_part, /* operation code for \.{cyanpart} */
3523 mp_magenta_part, /* operation code for \.{magentapart} */
3524 mp_yellow_part, /* operation code for \.{yellowpart} */
3525 mp_black_part, /* operation code for \.{blackpart} */
3526 mp_grey_part, /* operation code for \.{greypart} */
3527 mp_font_part, /* operation code for \.{fontpart} */
3528 mp_text_part, /* operation code for \.{textpart} */
3529 mp_path_part, /* operation code for \.{pathpart} */
3530 mp_pen_part, /* operation code for \.{penpart} */
3531 mp_dash_part, /* operation code for \.{dashpart} */
3532 mp_prescript_part, /* operation code for \.{prescriptpart} */
3533 mp_postscript_part, /* operation code for \.{postscriptpart} */
3534 mp_sqrt_op, /* operation code for \.{sqrt} */
3535 mp_m_exp_op, /* operation code for \.{mexp} */
3536 mp_m_log_op, /* operation code for \.{mlog} */
3537 mp_sin_d_op, /* operation code for \.{sind} */
3538 mp_cos_d_op, /* operation code for \.{cosd} */
3539 mp_floor_op, /* operation code for \.{floor} */
3540 mp_uniform_deviate, /* operation code for \.{uniformdeviate} */
3541 mp_char_exists_op, /* operation code for \.{charexists} */
3542 mp_font_size, /* operation code for \.{fontsize} */
3543 mp_ll_corner_op, /* operation code for \.{llcorner} */
3544 mp_lr_corner_op, /* operation code for \.{lrcorner} */
3545 mp_ul_corner_op, /* operation code for \.{ulcorner} */
3546 mp_ur_corner_op, /* operation code for \.{urcorner} */
3547 mp_arc_length, /* operation code for \.{arclength} */
3548 mp_angle_op, /* operation code for \.{angle} */
3549 mp_cycle_op, /* operation code for \.{cycle} */
3550 mp_filled_op, /* operation code for \.{filled} */
3551 mp_stroked_op, /* operation code for \.{stroked} */
3552 mp_textual_op, /* operation code for \.{textual} */
3553 mp_clipped_op, /* operation code for \.{clipped} */
3554 mp_bounded_op, /* operation code for \.{bounded} */
3555 mp_plus, /* operation code for \.+ */
3556 mp_minus, /* operation code for \.- */
3557 mp_times, /* operation code for \.* */
3558 mp_over, /* operation code for \./ */
3559 mp_pythag_add, /* operation code for \.{++} */
3560 mp_pythag_sub, /* operation code for \.{+-+} */
3561 mp_or_op, /* operation code for \.{or} */
3562 mp_and_op, /* operation code for \.{and} */
3563 mp_less_than, /* operation code for \.< */
3564 mp_less_or_equal, /* operation code for \.{<=} */
3565 mp_greater_than, /* operation code for \.> */
3566 mp_greater_or_equal, /* operation code for \.{>=} */
3567 mp_equal_to, /* operation code for \.= */
3568 mp_unequal_to, /* operation code for \.{<>} */
3569 mp_concatenate, /* operation code for \.\& */
3570 mp_rotated_by, /* operation code for \.{rotated} */
3571 mp_slanted_by, /* operation code for \.{slanted} */
3572 mp_scaled_by, /* operation code for \.{scaled} */
3573 mp_shifted_by, /* operation code for \.{shifted} */
3574 mp_transformed_by, /* operation code for \.{transformed} */
3575 mp_x_scaled, /* operation code for \.{xscaled} */
3576 mp_y_scaled, /* operation code for \.{yscaled} */
3577 mp_z_scaled, /* operation code for \.{zscaled} */
3578 mp_in_font, /* operation code for \.{infont} */
3579 mp_intersect, /* operation code for \.{intersectiontimes} */
3580 mp_double_dot, /* operation code for improper \.{..} */
3581 mp_substring_of, /* operation code for \.{substring} */
3582 mp_subpath_of, /* operation code for \.{subpath} */
3583 mp_direction_time_of, /* operation code for \.{directiontime} */
3584 mp_point_of, /* operation code for \.{point} */
3585 mp_precontrol_of, /* operation code for \.{precontrol} */
3586 mp_postcontrol_of, /* operation code for \.{postcontrol} */
3587 mp_pen_offset_of, /* operation code for \.{penoffset} */
3588 mp_arc_time_of, /* operation code for \.{arctime} */
3589 mp_version, /* operation code for \.{mpversion} */
3590 mp_envelope_of, /* operation code for \.{envelope} */
3591 mp_glyph_infont, /* operation code for \.{glyph} */
3592 mp_kern_flag /* operation code for \.{kern} */
3595 static void mp_print_op (MP mp, quarterword c) {
3596 if (c <= mp_numeric_type) {
3597 mp_print_type (mp, c);
3601 mp_print (mp, "true
");
3604 mp_print (mp, "false
");
3606 case mp_null_picture_code:
3607 mp_print (mp, "nullpicture
");
3609 case mp_null_pen_code:
3610 mp_print (mp, "nullpen
");
3612 case mp_read_string_op:
3613 mp_print (mp, "readstring
");
3616 mp_print (mp, "pencircle
");
3618 case mp_normal_deviate:
3619 mp_print (mp, "normaldeviate
");
3621 case mp_read_from_op:
3622 mp_print (mp, "readfrom
");
3624 case mp_close_from_op:
3625 mp_print (mp, "closefrom
");
3628 mp_print (mp, "odd
");
3631 mp_print (mp, "known
");
3634 mp_print (mp, "unknown
");
3637 mp_print (mp, "not
");
3640 mp_print (mp, "decimal
");
3643 mp_print (mp, "reverse
");
3645 case mp_make_path_op:
3646 mp_print (mp, "makepath
");
3648 case mp_make_pen_op:
3649 mp_print (mp, "makepen
");
3652 mp_print (mp, "oct
");
3655 mp_print (mp, "hex
");
3658 mp_print (mp, "ASCII
");
3661 mp_print (mp, "char
");
3664 mp_print (mp, "length
");
3667 mp_print (mp, "turningnumber
");
3670 mp_print (mp, "xpart
");
3673 mp_print (mp, "ypart
");
3676 mp_print (mp, "xxpart
");
3679 mp_print (mp, "xypart
");
3682 mp_print (mp, "yxpart
");
3685 mp_print (mp, "yypart
");
3688 mp_print (mp, "redpart
");
3691 mp_print (mp, "greenpart
");
3694 mp_print (mp, "bluepart
");
3697 mp_print (mp, "cyanpart
");
3699 case mp_magenta_part:
3700 mp_print (mp, "magentapart
");
3702 case mp_yellow_part:
3703 mp_print (mp, "yellowpart
");
3706 mp_print (mp, "blackpart
");
3709 mp_print (mp, "greypart
");
3711 case mp_color_model_part:
3712 mp_print (mp, "colormodel
");
3715 mp_print (mp, "fontpart
");
3718 mp_print (mp, "textpart
");
3720 case mp_prescript_part:
3721 mp_print (mp, "prescriptpart
");
3723 case mp_postscript_part:
3724 mp_print (mp, "postscriptpart
");
3727 mp_print (mp, "pathpart
");
3730 mp_print (mp, "penpart
");
3733 mp_print (mp, "dashpart
");
3736 mp_print (mp, "sqrt
");
3739 mp_print (mp, "mexp
");
3742 mp_print (mp, "mlog
");
3745 mp_print (mp, "sind
");
3748 mp_print (mp, "cosd
");
3751 mp_print (mp, "floor
");
3753 case mp_uniform_deviate:
3754 mp_print (mp, "uniformdeviate
");
3756 case mp_char_exists_op:
3757 mp_print (mp, "charexists
");
3760 mp_print (mp, "fontsize
");
3762 case mp_ll_corner_op:
3763 mp_print (mp, "llcorner
");
3765 case mp_lr_corner_op:
3766 mp_print (mp, "lrcorner
");
3768 case mp_ul_corner_op:
3769 mp_print (mp, "ulcorner
");
3771 case mp_ur_corner_op:
3772 mp_print (mp, "urcorner
");
3775 mp_print (mp, "arclength
");
3778 mp_print (mp, "angle
");
3781 mp_print (mp, "cycle
");
3784 mp_print (mp, "filled
");
3787 mp_print (mp, "stroked
");
3790 mp_print (mp, "textual
");
3793 mp_print (mp, "clipped
");
3796 mp_print (mp, "bounded
");
3799 mp_print_char (mp, xord ('+'));
3802 mp_print_char (mp, xord ('-'));
3805 mp_print_char (mp, xord ('*'));
3808 mp_print_char (mp, xord ('/'));
3811 mp_print (mp, "++");
3814 mp_print (mp, "+-+");
3817 mp_print (mp, "or
");
3820 mp_print (mp, "and
");
3823 mp_print_char (mp, xord ('<'));
3825 case mp_less_or_equal:
3826 mp_print (mp, "<=");
3828 case mp_greater_than:
3829 mp_print_char (mp, xord ('>'));
3831 case mp_greater_or_equal:
3832 mp_print (mp, ">=");
3835 mp_print_char (mp, xord ('='));
3838 mp_print (mp, "<>");
3840 case mp_concatenate:
3844 mp_print (mp, "rotated");
3847 mp_print (mp, "slanted");
3850 mp_print (mp, "scaled");
3853 mp_print (mp, "shifted");
3855 case mp_transformed_by:
3856 mp_print (mp, "transformed");
3859 mp_print (mp, "xscaled");
3862 mp_print (mp, "yscaled");
3865 mp_print (mp, "zscaled");
3868 mp_print (mp, "infont");
3871 mp_print (mp, "intersectiontimes");
3873 case mp_substring_of:
3874 mp_print (mp, "substring");
3877 mp_print (mp, "subpath");
3879 case mp_direction_time_of:
3880 mp_print (mp, "directiontime");
3883 mp_print (mp, "point");
3885 case mp_precontrol_of:
3886 mp_print (mp, "precontrol");
3888 case mp_postcontrol_of:
3889 mp_print (mp, "postcontrol");
3891 case mp_pen_offset_of:
3892 mp_print (mp, "penoffset");
3894 case mp_arc_time_of:
3895 mp_print (mp, "arctime");
3898 mp_print (mp, "mpversion");
3900 case mp_envelope_of:
3901 mp_print (mp, "envelope");
3903 case mp_glyph_infont:
3904 mp_print (mp, "glyph");
3907 mp_print (mp, "..");
3914 @ \MP\ also has a bunch of internal parameters that a user might want to
3915 fuss with. Every such parameter has an identifying code number, defined here.
3918 enum mp_given_internal {
3919 mp_output_template = 1, /* a string set up by \&{outputtemplate} */
3920 mp_output_filename, /* the output file name, accessible as \&{outputfilename} */
3921 mp_output_format, /* the output format set up by \&{outputformat} */
3922 mp_output_format_options, /* the output format options set up by \&{outputformatoptions} */
3923 mp_number_system, /* the number system as set up by \&{numbersystem} */
3924 mp_number_precision, /* the number system precision as set up by \&{numberprecision} */
3925 mp_job_name, /* the perceived jobname, as set up from the options stucture,
3926 the name of the input file, or by \&{jobname} */
3927 mp_tracing_titles, /* show titles online when they appear */
3928 mp_tracing_equations, /* show each variable when it becomes known */
3929 mp_tracing_capsules, /* show capsules too */
3930 mp_tracing_choices, /* show the control points chosen for paths */
3931 mp_tracing_specs, /* show path subdivision prior to filling with polygonal a pen */
3932 mp_tracing_commands, /* show commands and operations before they are performed */
3933 mp_tracing_restores, /* show when a variable or internal is restored */
3934 mp_tracing_macros, /* show macros before they are expanded */
3935 mp_tracing_output, /* show digitized edges as they are output */
3936 mp_tracing_stats, /* show memory usage at end of job */
3937 mp_tracing_lost_chars, /* show characters that aren't \&{infont} */
3938 mp_tracing_online, /* show long diagnostics on terminal and in the log file */
3939 mp_year, /* the current year (e.g., 1984) */
3940 mp_month, /* the current month (e.g., 3 $\equiv$ March) */
3941 mp_day, /* the current day of the month */
3942 mp_time, /* the number of minutes past midnight when this job started */
3943 mp_hour, /* the number of hours past midnight when this job started */
3944 mp_minute, /* the number of minutes in that hour when this job started */
3945 mp_char_code, /* the number of the next character to be output */
3946 mp_char_ext, /* the extension code of the next character to be output */
3947 mp_char_wd, /* the width of the next character to be output */
3948 mp_char_ht, /* the height of the next character to be output */
3949 mp_char_dp, /* the depth of the next character to be output */
3950 mp_char_ic, /* the italic correction of the next character to be output */
3951 mp_design_size, /* the unit of measure used for |mp_char_wd..mp_char_ic|, in points */
3952 mp_pausing, /* positive to display lines on the terminal before they are read */
3953 mp_showstopping, /* positive to stop after each \&{show} command */
3954 mp_fontmaking, /* positive if font metric output is to be produced */
3955 mp_linejoin, /* as in \ps: 0 for mitered, 1 for round, 2 for beveled */
3956 mp_linecap, /* as in \ps: 0 for butt, 1 for round, 2 for square */
3957 mp_miterlimit, /* controls miter length as in \ps */
3958 mp_warning_check, /* controls error message when variable value is large */
3959 mp_boundary_char, /* the right boundary character for ligatures */
3960 mp_prologues, /* positive to output conforming PostScript using built-in fonts */
3961 mp_true_corners, /* positive to make \&{llcorner} etc. ignore \&{setbounds} */
3962 mp_default_color_model, /* the default color model for unspecified items */
3963 mp_restore_clip_color,
3964 mp_procset, /* wether or not create PostScript command shortcuts */
3965 mp_hppp, /* horizontal pixels per point (for png output) */
3966 mp_vppp, /* vertical pixels per point (for png output) */
3967 mp_gtroffmode, /* whether the user specified |-troff| on the command line */
3975 @ @<MPlib internal header stuff@>=
3976 #define internal_value(A) mp->internal[(A)].v.data.n
3977 #define set_internal_from_number(A,B) do { \
3978 number_clone (internal_value ((A)),(B));\
3980 #define internal_string(A) (mp_string)mp->internal[(A)].v.data.str
3981 #define set_internal_string(A,B) mp->internal[(A)].v.data.str=(B)
3982 #define internal_name(A) mp->internal[(A)].intname
3983 #define set_internal_name(A,B) mp->internal[(A)].intname=(B)
3984 #define internal_type(A) (mp_variable_type)mp->internal[(A)].v.type
3985 #define set_internal_type(A,B) mp->internal[(A)].v.type=(B)
3986 #define set_internal_from_cur_exp(A) do { \
3987 if (internal_type ((A)) == mp_string_type) { \
3988 add_str_ref (cur_exp_str ()); \
3989 set_internal_string ((A), cur_exp_str ()); \
3991 set_internal_from_number ((A), cur_exp_value_number ()); \
3999 @d max_given_internal mp_gtroffmode
4002 mp_internal *internal; /* the values of internal quantities */
4003 int int_ptr; /* the maximum internal quantity defined so far */
4004 int max_internal; /* current maximum number of internal quantities */
4006 @ @<Option variables@>=
4009 @ @<Allocate or initialize ...@>=
4010 mp->max_internal = 2 * max_given_internal;
4011 mp->internal = xmalloc ((mp->max_internal + 1), sizeof (mp_internal));
4012 memset (mp->internal, 0,
4013 (size_t) (mp->max_internal + 1) * sizeof (mp_internal));
4016 for (i = 1; i <= mp->max_internal; i++) {
4017 new_number(mp->internal[i].v.data.n);
4019 for (i = 1; i <= max_given_internal; i++) {
4020 set_internal_type (i, mp_known);
4023 set_internal_type (mp_output_format, mp_string_type);
4024 set_internal_type (mp_output_filename, mp_string_type);
4025 set_internal_type (mp_output_format_options, mp_string_type);
4026 set_internal_type (mp_output_template, mp_string_type);
4027 set_internal_type (mp_number_system, mp_string_type);
4028 set_internal_type (mp_job_name, mp_string_type);
4029 mp->troff_mode = (opt->troff_mode > 0 ? true : false);
4031 @ @<Exported function ...@>=
4032 int mp_troff_mode (MP mp);
4035 int mp_troff_mode (MP mp) {
4036 return mp->troff_mode;
4040 @ @<Set initial ...@>=
4041 mp->int_ptr = max_given_internal;
4043 @ The symbolic names for internal quantities are put into \MP's hash table
4044 by using a routine called |primitive|, which will be defined later. Let us
4045 enter them now, so that we don't have to list all those names again
4048 @<Put each of \MP's primitives into the hash table@>=
4049 mp_primitive (mp, "tracingtitles", mp_internal_quantity, mp_tracing_titles);
4050 @:tracingtitles_}{\&{tracingtitles} primitive@>;
4051 mp_primitive (mp, "tracingequations", mp_internal_quantity, mp_tracing_equations);
4052 @:mp_tracing_equations_}{\&{tracingequations} primitive@>;
4053 mp_primitive (mp, "tracingcapsules", mp_internal_quantity, mp_tracing_capsules);
4054 @:mp_tracing_capsules_}{\&{tracingcapsules} primitive@>;
4055 mp_primitive (mp, "tracingchoices", mp_internal_quantity, mp_tracing_choices);
4056 @:mp_tracing_choices_}{\&{tracingchoices} primitive@>;
4057 mp_primitive (mp, "tracingspecs", mp_internal_quantity, mp_tracing_specs);
4058 @:mp_tracing_specs_}{\&{tracingspecs} primitive@>;
4059 mp_primitive (mp, "tracingcommands", mp_internal_quantity, mp_tracing_commands);
4060 @:mp_tracing_commands_}{\&{tracingcommands} primitive@>;
4061 mp_primitive (mp, "tracingrestores", mp_internal_quantity, mp_tracing_restores);
4062 @:mp_tracing_restores_}{\&{tracingrestores} primitive@>;
4063 mp_primitive (mp, "tracingmacros", mp_internal_quantity, mp_tracing_macros);
4064 @:mp_tracing_macros_}{\&{tracingmacros} primitive@>;
4065 mp_primitive (mp, "tracingoutput", mp_internal_quantity, mp_tracing_output);
4066 @:mp_tracing_output_}{\&{tracingoutput} primitive@>;
4067 mp_primitive (mp, "tracingstats", mp_internal_quantity, mp_tracing_stats);
4068 @:mp_tracing_stats_}{\&{tracingstats} primitive@>;
4069 mp_primitive (mp, "tracinglostchars", mp_internal_quantity, mp_tracing_lost_chars);
4070 @:mp_tracing_lost_chars_}{\&{tracinglostchars} primitive@>;
4071 mp_primitive (mp, "tracingonline", mp_internal_quantity, mp_tracing_online);
4072 @:mp_tracing_online_}{\&{tracingonline} primitive@>;
4073 mp_primitive (mp, "year", mp_internal_quantity, mp_year);
4074 @:mp_year_}{\&{year} primitive@>;
4075 mp_primitive (mp, "month", mp_internal_quantity, mp_month);
4076 @:mp_month_}{\&{month} primitive@>;
4077 mp_primitive (mp, "day", mp_internal_quantity, mp_day);
4078 @:mp_day_}{\&{day} primitive@>;
4079 mp_primitive (mp, "time", mp_internal_quantity, mp_time);
4080 @:time_}{\&{time} primitive@>;
4081 mp_primitive (mp, "hour", mp_internal_quantity, mp_hour);
4082 @:hour_}{\&{hour} primitive@>;
4083 mp_primitive (mp, "minute", mp_internal_quantity, mp_minute);
4084 @:minute_}{\&{minute} primitive@>;
4085 mp_primitive (mp, "charcode", mp_internal_quantity, mp_char_code);
4086 @:mp_char_code_}{\&{charcode} primitive@>;
4087 mp_primitive (mp, "charext", mp_internal_quantity, mp_char_ext);
4088 @:mp_char_ext_}{\&{charext} primitive@>;
4089 mp_primitive (mp, "charwd", mp_internal_quantity, mp_char_wd);
4090 @:mp_char_wd_}{\&{charwd} primitive@>;
4091 mp_primitive (mp, "charht", mp_internal_quantity, mp_char_ht);
4092 @:mp_char_ht_}{\&{charht} primitive@>;
4093 mp_primitive (mp, "chardp", mp_internal_quantity, mp_char_dp);
4094 @:mp_char_dp_}{\&{chardp} primitive@>;
4095 mp_primitive (mp, "charic", mp_internal_quantity, mp_char_ic);
4096 @:mp_char_ic_}{\&{charic} primitive@>;
4097 mp_primitive (mp, "designsize", mp_internal_quantity, mp_design_size);
4098 @:mp_design_size_}{\&{designsize} primitive@>;
4099 mp_primitive (mp, "pausing", mp_internal_quantity, mp_pausing);
4100 @:mp_pausing_}{\&{pausing} primitive@>;
4101 mp_primitive (mp, "showstopping", mp_internal_quantity, mp_showstopping);
4102 @:mp_showstopping_}{\&{showstopping} primitive@>;
4103 mp_primitive (mp, "fontmaking", mp_internal_quantity, mp_fontmaking);
4104 @:mp_fontmaking_}{\&{fontmaking} primitive@>;
4105 mp_primitive (mp, "linejoin", mp_internal_quantity, mp_linejoin);
4106 @:mp_linejoin_}{\&{linejoin} primitive@>;
4107 mp_primitive (mp, "linecap", mp_internal_quantity, mp_linecap);
4108 @:mp_linecap_}{\&{linecap} primitive@>;
4109 mp_primitive (mp, "miterlimit", mp_internal_quantity, mp_miterlimit);
4110 @:mp_miterlimit_}{\&{miterlimit} primitive@>;
4111 mp_primitive (mp, "warningcheck", mp_internal_quantity, mp_warning_check);
4112 @:mp_warning_check_}{\&{warningcheck} primitive@>;
4113 mp_primitive (mp, "boundarychar", mp_internal_quantity, mp_boundary_char);
4114 @:mp_boundary_char_}{\&{boundarychar} primitive@>;
4115 mp_primitive (mp, "prologues", mp_internal_quantity, mp_prologues);
4116 @:mp_prologues_}{\&{prologues} primitive@>;
4117 mp_primitive (mp, "truecorners", mp_internal_quantity, mp_true_corners);
4118 @:mp_true_corners_}{\&{truecorners} primitive@>;
4119 mp_primitive (mp, "mpprocset", mp_internal_quantity, mp_procset);
4120 @:mp_procset_}{\&{mpprocset} primitive@>;
4121 mp_primitive (mp, "troffmode", mp_internal_quantity, mp_gtroffmode);
4122 @:troffmode_}{\&{troffmode} primitive@>;
4123 mp_primitive (mp, "defaultcolormodel", mp_internal_quantity,
4124 mp_default_color_model);
4125 @:mp_default_color_model_}{\&{defaultcolormodel} primitive@>;
4126 mp_primitive (mp, "restoreclipcolor", mp_internal_quantity, mp_restore_clip_color);
4127 @:mp_restore_clip_color_}{\&{restoreclipcolor} primitive@>;
4128 mp_primitive (mp, "outputtemplate", mp_internal_quantity, mp_output_template);
4129 @:mp_output_template_}{\&{outputtemplate} primitive@>;
4130 mp_primitive (mp, "outputfilename", mp_internal_quantity, mp_output_filename);
4131 @:mp_output_filename_}{\&{outputfilename} primitive@>;
4132 mp_primitive (mp, "numbersystem", mp_internal_quantity, mp_number_system);
4133 @:mp_number_system_}{\&{numbersystem} primitive@>;
4134 mp_primitive (mp, "numberprecision", mp_internal_quantity, mp_number_precision);
4135 @:mp_number_precision_}{\&{numberprecision} primitive@>;
4136 mp_primitive (mp, "outputformat", mp_internal_quantity, mp_output_format);
4137 @:mp_output_format_}{\&{outputformat} primitive@>;
4138 mp_primitive (mp, "outputformatoptions", mp_internal_quantity, mp_output_format_options);
4139 @:mp_output_format_options_}{\&{outputformatoptions} primitive@>;
4140 mp_primitive (mp, "jobname", mp_internal_quantity, mp_job_name);
4141 @:mp_job_name_}{\&{jobname} primitive@>
4142 mp_primitive (mp, "hppp", mp_internal_quantity, mp_hppp);
4143 @:mp_hppp_}{\&{hppp} primitive@>;
4144 mp_primitive (mp, "vppp", mp_internal_quantity, mp_vppp);
4145 @:mp_vppp_}{\&{vppp} primitive@>;
4148 @ Colors can be specified in four color models. In the special
4149 case of |no_model|, MetaPost does not output any color operator to
4150 the postscript output.
4152 Note: these values are passed directly on to |with_option|. This only
4153 works because the other possible values passed to |with_option| are
4154 8 and 10 respectively (from |with_pen| and |with_picture|).
4156 There is a first state, that is only used for |gs_colormodel|. It flags
4157 the fact that there has not been any kind of color specification by
4158 the user so far in the game.
4160 @<MPlib header stuff@>=
4161 enum mp_color_model {
4166 mp_uninitialized_model = 9
4170 @ @<Initialize table entries@>=
4171 set_internal_from_number (mp_default_color_model, unity_t);
4172 number_multiply_int (internal_value (mp_default_color_model), mp_rgb_model);
4173 number_clone (internal_value (mp_restore_clip_color), unity_t);
4174 number_clone (internal_value (mp_hppp), unity_t);
4175 number_clone (internal_value (mp_vppp), unity_t);
4176 set_internal_string (mp_output_template, mp_intern (mp, "%j.%c"));
4177 set_internal_string (mp_output_filename, mp_intern (mp, ""));
4178 set_internal_string (mp_output_format, mp_intern (mp, "eps"));
4179 set_internal_string (mp_output_format_options, mp_intern (mp, ""));
4180 set_internal_string (mp_number_system, mp_intern (mp, "scaled"));
4181 set_internal_from_number (mp_number_precision, precision_default);
4183 number_clone (internal_value (mp_tracing_titles), three_t);
4184 number_clone (internal_value (mp_tracing_equations), three_t);
4185 number_clone (internal_value (mp_tracing_capsules), three_t);
4186 number_clone (internal_value (mp_tracing_choices), three_t);
4187 number_clone (internal_value (mp_tracing_specs), three_t);
4188 number_clone (internal_value (mp_tracing_commands), three_t);
4189 number_clone (internal_value (mp_tracing_restores), three_t);
4190 number_clone (internal_value (mp_tracing_macros), three_t);
4191 number_clone (internal_value (mp_tracing_output), three_t);
4192 number_clone (internal_value (mp_tracing_stats), three_t);
4193 number_clone (internal_value (mp_tracing_lost_chars), three_t);
4194 number_clone (internal_value (mp_tracing_online), three_t);
4197 @ Well, we do have to list the names one more time, for use in symbolic
4200 @<Initialize table...@>=
4201 set_internal_name (mp_tracing_titles, xstrdup ("tracingtitles"));
4202 set_internal_name (mp_tracing_equations, xstrdup ("tracingequations"));
4203 set_internal_name (mp_tracing_capsules, xstrdup ("tracingcapsules"));
4204 set_internal_name (mp_tracing_choices, xstrdup ("tracingchoices"));
4205 set_internal_name (mp_tracing_specs, xstrdup ("tracingspecs"));
4206 set_internal_name (mp_tracing_commands, xstrdup ("tracingcommands"));
4207 set_internal_name (mp_tracing_restores, xstrdup ("tracingrestores"));
4208 set_internal_name (mp_tracing_macros, xstrdup ("tracingmacros"));
4209 set_internal_name (mp_tracing_output, xstrdup ("tracingoutput"));
4210 set_internal_name (mp_tracing_stats, xstrdup ("tracingstats"));
4211 set_internal_name (mp_tracing_lost_chars, xstrdup ("tracinglostchars"));
4212 set_internal_name (mp_tracing_online, xstrdup ("tracingonline"));
4213 set_internal_name (mp_year, xstrdup ("year"));
4214 set_internal_name (mp_month, xstrdup ("month"));
4215 set_internal_name (mp_day, xstrdup ("day"));
4216 set_internal_name (mp_time, xstrdup ("time"));
4217 set_internal_name (mp_hour, xstrdup ("hour"));
4218 set_internal_name (mp_minute, xstrdup ("minute"));
4219 set_internal_name (mp_char_code, xstrdup ("charcode"));
4220 set_internal_name (mp_char_ext, xstrdup ("charext"));
4221 set_internal_name (mp_char_wd, xstrdup ("charwd"));
4222 set_internal_name (mp_char_ht, xstrdup ("charht"));
4223 set_internal_name (mp_char_dp, xstrdup ("chardp"));
4224 set_internal_name (mp_char_ic, xstrdup ("charic"));
4225 set_internal_name (mp_design_size, xstrdup ("designsize"));
4226 set_internal_name (mp_pausing, xstrdup ("pausing"));
4227 set_internal_name (mp_showstopping, xstrdup ("showstopping"));
4228 set_internal_name (mp_fontmaking, xstrdup ("fontmaking"));
4229 set_internal_name (mp_linejoin, xstrdup ("linejoin"));
4230 set_internal_name (mp_linecap, xstrdup ("linecap"));
4231 set_internal_name (mp_miterlimit, xstrdup ("miterlimit"));
4232 set_internal_name (mp_warning_check, xstrdup ("warningcheck"));
4233 set_internal_name (mp_boundary_char, xstrdup ("boundarychar"));
4234 set_internal_name (mp_prologues, xstrdup ("prologues"));
4235 set_internal_name (mp_true_corners, xstrdup ("truecorners"));
4236 set_internal_name (mp_default_color_model, xstrdup ("defaultcolormodel"));
4237 set_internal_name (mp_procset, xstrdup ("mpprocset"));
4238 set_internal_name (mp_gtroffmode, xstrdup ("troffmode"));
4239 set_internal_name (mp_restore_clip_color, xstrdup ("restoreclipcolor"));
4240 set_internal_name (mp_output_template, xstrdup ("outputtemplate"));
4241 set_internal_name (mp_output_filename, xstrdup ("outputfilename"));
4242 set_internal_name (mp_output_format, xstrdup ("outputformat"));
4243 set_internal_name (mp_output_format_options, xstrdup ("outputformatoptions"));
4244 set_internal_name (mp_job_name, xstrdup ("jobname"));
4245 set_internal_name (mp_number_system, xstrdup ("numbersystem"));
4246 set_internal_name (mp_number_precision, xstrdup ("numberprecision"));
4247 set_internal_name (mp_hppp, xstrdup ("hppp"));
4248 set_internal_name (mp_vppp, xstrdup ("vppp"));
4250 @ The following procedure, which is called just before \MP\ initializes its
4251 input and output, establishes the initial values of the date and time.
4252 @^system dependencies@>
4254 Note that the values are |scaled| integers. Hence \MP\ can no longer
4255 be used after the year 32767.
4258 static void mp_fix_date_and_time (MP mp) {
4259 time_t aclock = time ((time_t *) 0);
4260 struct tm *tmptr = localtime (&aclock);
4261 set_internal_from_number (mp_time, unity_t);
4262 number_multiply_int (internal_value(mp_time), (tmptr->tm_hour * 60 + tmptr->tm_min));
4263 set_internal_from_number (mp_hour, unity_t);
4264 number_multiply_int (internal_value(mp_hour), (tmptr->tm_hour));
4265 set_internal_from_number (mp_minute, unity_t);
4266 number_multiply_int (internal_value(mp_minute), (tmptr->tm_min));
4267 set_internal_from_number (mp_day, unity_t);
4268 number_multiply_int (internal_value(mp_day), (tmptr->tm_mday));
4269 set_internal_from_number (mp_month, unity_t);
4270 number_multiply_int (internal_value(mp_month), (tmptr->tm_mon + 1));
4271 set_internal_from_number (mp_year, unity_t);
4272 number_multiply_int (internal_value(mp_year), (tmptr->tm_year + 1900));
4277 static void mp_fix_date_and_time (MP mp);
4279 @ \MP\ is occasionally supposed to print diagnostic information that
4280 goes only into the transcript file, unless |mp_tracing_online| is positive.
4281 Now that we have defined |mp_tracing_online| we can define
4282 two routines that adjust the destination of print commands:
4285 static void mp_begin_diagnostic (MP mp);
4286 static void mp_end_diagnostic (MP mp, boolean blank_line);
4287 static void mp_print_diagnostic (MP mp, const char *s, const char *t,
4290 @ @<Basic printing...@>=
4291 void mp_begin_diagnostic (MP mp) { /* prepare to do some tracing */
4292 mp->old_setting = mp->selector;
4293 if (number_nonpositive(internal_value (mp_tracing_online))
4294 && (mp->selector == term_and_log)) {
4295 decr (mp->selector);
4296 if (mp->history == mp_spotless)
4297 mp->history = mp_warning_issued;
4301 void mp_end_diagnostic (MP mp, boolean blank_line) {
4302 /* restore proper conditions after tracing */
4303 mp_print_nl (mp, "");
4306 mp->selector = mp->old_setting;
4313 unsigned int old_setting;
4315 @ We will occasionally use |begin_diagnostic| in connection with line-number
4316 printing, as follows. (The parameter |s| is typically |"Path"| or
4317 |"Cycle spec"|, etc.)
4319 @<Basic printing...@>=
4320 void mp_print_diagnostic (MP mp, const char *s, const char *t, boolean nuline) {
4321 mp_begin_diagnostic (mp);
4323 mp_print_nl (mp, s);
4326 mp_print (mp, " at line ");
4327 mp_print_int (mp, mp_true_line (mp));
4329 mp_print_char (mp, xord (':'));
4333 @ The 256 |ASCII_code| characters are grouped into classes by means of
4334 the |char_class| table. Individual class numbers have no semantic
4335 or syntactic significance, except in a few instances defined here.
4336 There's also |max_class|, which can be used as a basis for additional
4337 class numbers in nonstandard extensions of \MP.
4339 @d digit_class 0 /* the class number of \.{0123456789} */
4340 @d period_class 1 /* the class number of `\..' */
4341 @d space_class 2 /* the class number of spaces and nonstandard characters */
4342 @d percent_class 3 /* the class number of `\.\%' */
4343 @d string_class 4 /* the class number of `\."' */
4344 @d right_paren_class
8 /* the class number of `\.
)'
*/
4345 @d isolated_classes
5: case
6: case
7: case
8 /* characters that make length-one tokens only
*/
4346 @d letter_class
9 /* letters and the underline character
*/
4347 @d mp_left_bracket_class
17 /* `\.
['
*/
4348 @d mp_right_bracket_class
18 /* `\.
]'
*/
4349 @d invalid_class
20 /* bad character in the input
*/
4350 @d max_class
20 /* the largest class number
*/
4353 #define digit_class
0 /* the class number of \.
{0123456789} */
4354 int char_class
[256]; /* the class numbers
*/
4356 @ If changes are made to accommodate non-ASCII character sets
, they should
4357 follow the guidelines in Appendix~C of
{\sl The
{\logos METAFONT\
/}book
}.
4358 @
:METAFONTbook
}{\sl The
{\logos METAFONT\
/}book@
>
4359 @^system dependencies@
>
4361 @
<Set initial ...@
>=
4362 for
(k
= '
0'
; k
<= '
9'
; k
++)
4363 mp-
>char_class
[k
] = digit_class
;
4364 mp-
>char_class
['.'
] = period_class
;
4365 mp-
>char_class
[' '
] = space_class
;
4366 mp-
>char_class
['
%'
] = percent_class
;
4367 mp-
>char_class
['
"'] = string_class;
4368 mp->char_class[','] = 5;
4369 mp->char_class[';'] = 6;
4370 mp->char_class['('] = 7;
4371 mp->char_class[')'] = right_paren_class;
4372 for (k = 'A'; k <= 'Z'; k++)
4373 mp->char_class[k] = letter_class;
4374 for (k = 'a'; k <= 'z'; k++)
4375 mp->char_class[k] = letter_class;
4376 mp->char_class['_'] = letter_class;
4377 mp->char_class['<'] = 10;
4378 mp->char_class['='] = 10;
4379 mp->char_class['>'] = 10;
4380 mp->char_class[':'] = 10;
4381 mp->char_class['|'] = 10;
4382 mp->char_class['`'] = 11;
4383 mp->char_class['\''] = 11;
4384 mp->char_class['+'] = 12;
4385 mp->char_class['-'] = 12;
4386 mp->char_class['/'] = 13;
4387 mp->char_class['*'] = 13;
4388 mp->char_class['\\'] = 13;
4389 mp->char_class['!'] = 14;
4390 mp->char_class['?'] = 14;
4391 mp->char_class['#'] = 15;
4392 mp->char_class['&'] = 15;
4393 mp->char_class['@@'] = 15;
4394 mp->char_class['$'] = 15;
4395 mp->char_class['^'] = 16;
4396 mp->char_class['~'] = 16;
4397 mp->char_class['['] = mp_left_bracket_class;
4398 mp->char_class[']'] = mp_right_bracket_class;
4399 mp->char_class['{'] = 19;
4400 mp->char_class['}'] = 19;
4401 for (k = 0; k < ' '; k++)
4402 mp->char_class[k] = invalid_class;
4403 mp->char_class['\t'] = space_class;
4404 mp->char_class['\f'] = space_class;
4405 for (k = 127; k <= 255; k++)
4406 mp->char_class[k] = invalid_class;
4410 Symbolic tokens are stored in and retrieved from an AVL tree. This
4411 is not as fast as an actual hash table, but it is easily extensible.
4413 A symbolic token contains a pointer to the |mp_string| that
4414 contains the string representation of the symbol, a |halfword|
4415 that holds the current command value of the token, and an
4416 |mp_value| for the associated equivalent.
4419 FUNCTION_TRACE3 ("set_text
(%p
, %p
)\n
",(A),(B));
4423 @d set_eq_type(A,B) do {
4424 FUNCTION_TRACE3 ("set_eq_type
(%p
, %d
)\n
",(A),(B));
4428 @d set_equiv(A,B) do {
4429 FUNCTION_TRACE3 ("set_equiv
(%p
, %d
)\n
",(A),(B));
4430 (A)->v.data.node=NULL ;
4431 (A)->v.data.indep.serial=(B);
4434 @d set_equiv_node(A,B) do {
4435 FUNCTION_TRACE3 ("set_equiv_node
(%p
, %p
)\n
",(A),(B));
4436 (A)->v.data.node=(B) ;
4437 (A)->v.data.indep.serial=0;
4440 @d set_equiv_sym(A,B) do {
4441 FUNCTION_TRACE3 ("set_equiv_sym
(%p
, %p
)\n
",(A),(B));
4442 (A)->v.data.node=(mp_node)(B);
4443 (A)->v.data.indep.serial=0;
4448 #define text(A) do_get_text(mp, (A))
4449 #define eq_type(A) do_get_eq_type(mp, (A))
4450 #define equiv(A) do_get_equiv(mp, (A))
4451 #define equiv_node(A) do_get_equiv_node(mp, (A))
4452 #define equiv_sym(A) do_get_equiv_sym(mp, (A))
4453 static mp_string do_get_text (MP mp, mp_sym A) {
4454 FUNCTION_TRACE3 ("%d
= do_get_text
(%p
)\n
",A->text,A);
4457 static halfword do_get_eq_type (MP mp, mp_sym A) {
4458 FUNCTION_TRACE3 ("%d
= do_get_eq_type
(%p
)\n
",A->type,A);
4461 static halfword do_get_equiv (MP mp, mp_sym A) {
4462 FUNCTION_TRACE3 ("%d
= do_get_equiv
(%p
)\n
",A->v.data.indep.serial,A);
4463 return A->v.data.indep.serial;
4465 static mp_node do_get_equiv_node (MP mp, mp_sym A) {
4466 FUNCTION_TRACE3 ("%p
= do_get_equiv_node
(%p
)\n
",A->v.data.node,A);
4467 return A->v.data.node;
4469 static mp_sym do_get_equiv_sym (MP mp, mp_sym A) {
4470 FUNCTION_TRACE3 ("%p
= do_get_equiv_sym
(%p
)\n
",A->v.data.node,A);
4471 return (mp_sym)A->v.data.node;
4474 #define text(A) (A)->text
4475 #define eq_type(A) (A)->type
4476 #define equiv(A) (A)->v.data.indep.serial
4477 #define equiv_node(A) (A)->v.data.node
4478 #define equiv_sym(A) (mp_sym)(A)->v.data.node
4481 @ @<Declarations...@>=
4483 static mp_string do_get_text (MP mp, mp_sym A);
4484 static halfword do_get_eq_type (MP mp, mp_sym A);
4485 static halfword do_get_equiv (MP mp, mp_sym A);
4486 static mp_node do_get_equiv_node (MP mp, mp_sym A);
4487 static mp_sym do_get_equiv_sym (MP mp, mp_sym A);
4491 typedef struct mp_symbol_entry {
4499 integer st_count; /* total number of known identifiers */
4500 avl_tree symbols; /* avl tree of symbolic tokens */
4501 avl_tree frozen_symbols; /* avl tree of frozen symbolic tokens */
4502 mp_sym frozen_bad_vardef;
4503 mp_sym frozen_colon;
4504 mp_sym frozen_end_def;
4505 mp_sym frozen_end_for;
4506 mp_sym frozen_end_group;
4509 mp_sym frozen_inaccessible;
4510 mp_sym frozen_left_bracket;
4511 mp_sym frozen_mpx_break;
4512 mp_sym frozen_repeat_loop;
4513 mp_sym frozen_right_delimiter;
4514 mp_sym frozen_semicolon;
4515 mp_sym frozen_slash;
4516 mp_sym frozen_undefined;
4520 @ Here are the functions needed for the avl construction.
4523 static int comp_symbols_entry (void *p, const void *pa, const void *pb);
4524 static void *copy_symbols_entry (const void *p);
4525 static void *delete_symbols_entry (void *p);
4528 @ The avl comparison function is a straightword version of |strcmp|,
4529 except that checks for the string lengths first.
4532 static int comp_symbols_entry (void *p, const void *pa, const void *pb) {
4533 const mp_symbol_entry *a = (const mp_symbol_entry *) pa;
4534 const mp_symbol_entry *b = (const mp_symbol_entry *) pb;
4536 if (a->text->len != b->text->len) {
4537 return (a->text->len > b->text->len ? 1 : -1);
4539 return strncmp ((const char *) a->text->str, (const char *) b->text->str,
4544 @ Copying a symbol happens when an item is inserted into an AVL tree.
4545 The |text| and |mp_number| needs to be deep copied, every thing else
4549 static void *copy_symbols_entry (const void *p) {
4552 const mp_symbol_entry *fp;
4553 fp = (const mp_symbol_entry *) p;
4554 mp = (MP)fp->parent;
4555 ff = malloc (sizeof (mp_symbol_entry));
4558 ff->text = copy_strings_entry (fp->text);
4559 if (ff->text == NULL)
4562 ff->type = fp->type;
4564 new_number(ff->v.data.n);
4565 number_clone(ff->v.data.n, fp->v.data.n);
4570 @ In the current implementation, symbols are not freed until the
4574 static void *delete_symbols_entry (void *p) {
4576 mp_sym ff = (mp_sym) p;
4577 mp = (MP)ff->parent;
4578 free_number(ff->v.data.n);
4579 mp_xfree (ff->text->str);
4580 mp_xfree (ff->text);
4586 @ @<Allocate or initialize ...@>=
4587 mp->symbols = avl_create (comp_symbols_entry,
4589 delete_symbols_entry, malloc, free, NULL);
4590 mp->frozen_symbols = avl_create (comp_symbols_entry,
4592 delete_symbols_entry, malloc, free, NULL);
4594 @ @<Dealloc variables@>=
4595 if (mp->symbols != NULL)
4596 avl_destroy (mp->symbols);
4597 if (mp->frozen_symbols != NULL)
4598 avl_destroy (mp->frozen_symbols);
4600 @ Actually creating symbols is done by |id_lookup|, but in order to
4601 do so it needs a way to create a new, empty symbol structure.
4604 static mp_sym new_symbols_entry (MP mp, unsigned char *nam, size_t len);
4607 static mp_sym new_symbols_entry (MP mp, unsigned char *nam, size_t len) {
4609 ff = mp_xmalloc (mp, 1, sizeof (mp_symbol_entry));
4610 memset (ff, 0, sizeof (mp_symbol_entry));
4612 ff->text = mp_xmalloc (mp, 1, sizeof (mp_lstring));
4613 ff->text->str = nam;
4614 ff->text->len = len;
4615 ff->type = mp_tag_token;
4616 ff->v.type = mp_known;
4617 new_number(ff->v.data.n);
4618 FUNCTION_TRACE4 ("%p
= new_symbols_entry
(\
"%s\",%d
)\n
", ff, nam, (int)len);
4623 @ There is one global variable so that |id_lookup| does not always have to
4624 create a new entry just for testing. This is not freed because it creates
4625 a double-free thanks to the |NULL| init.
4628 mp_sym id_lookup_test;
4630 @ @<Initialize table entries@>=
4631 mp->id_lookup_test = new_symbols_entry (mp, NULL, 0);
4633 @ Certain symbols are ``frozen'' and not redefinable, since they are
4637 @<Initialize table entries@>=
4639 mp->frozen_bad_vardef = mp_frozen_primitive (mp, "a bad variable
", mp_tag_token, 0);
4640 mp->frozen_right_delimiter = mp_frozen_primitive (mp, ")", mp_right_delimiter, 0);
4641 mp->frozen_inaccessible = mp_frozen_primitive (mp, " INACCESSIBLE
", mp_tag_token, 0);
4642 mp->frozen_undefined = mp_frozen_primitive (mp, " UNDEFINED
", mp_tag_token, 0);
4644 @ Here is the subroutine that searches the avl tree for an identifier
4645 that matches a given string of length~|l| appearing in |buffer[j..
4646 (j+l-1)]|. If the identifier is not found, it is inserted if
4647 |insert_new| is |true|, and the corresponding symbol will be returned.
4649 There are two variations on the lookup function: one for the normal
4650 symbol table, and one for the table of error recovery symbols.
4652 @d mp_id_lookup(A,B,C,D) mp_do_id_lookup ((A), mp->symbols, (B), (C), (D))
4655 static mp_sym mp_do_id_lookup (MP mp, avl_tree symbols, char *j,
4656 size_t l, boolean insert_new) {
4657 /* search an avl tree */
4659 mp->id_lookup_test->text->str = (unsigned char *)j;
4660 mp->id_lookup_test->text->len = l;
4661 str = (mp_sym) avl_find (mp->id_lookup_test, symbols);
4662 if (str == NULL && insert_new) {
4663 unsigned char *nam = (unsigned char *) mp_xstrldup (mp, j, l);
4664 mp_sym s = new_symbols_entry (mp, nam, l);
4666 assert (avl_ins (s, symbols, avl_false) > 0);
4667 str = (mp_sym) avl_find (s, symbols);
4668 delete_symbols_entry (s);
4672 static mp_sym mp_frozen_id_lookup (MP mp, char *j, size_t l,
4673 boolean insert_new) {
4674 /* search the error recovery symbol table */
4675 return mp_do_id_lookup (mp, mp->frozen_symbols, j, l, insert_new);
4678 /* see mp_print_sym (mp_sym sym) */
4680 double mp_get_numeric_value (MP mp, const char *s, size_t l) {
4681 char *ss = mp_xstrdup(mp,s);
4683 mp_sym sym = mp_id_lookup(mp,ss,l,false);
4685 if (mp_type(sym->v.data.node) == mp_known) {
4687 return number_to_double(sym->v.data.node->data.n) ;
4695 int mp_get_boolean_value (MP mp, const char *s, size_t l) {
4696 char *ss = mp_xstrdup(mp,s);
4698 mp_sym sym = mp_id_lookup(mp,ss,l,false);
4700 if (mp_type(sym->v.data.node) == mp_boolean_type) {
4701 if (number_to_boolean (sym->v.data.node->data.n) == mp_true_code) {
4712 char *mp_get_string_value (MP mp, const char *s, size_t l) {
4713 char *ss = mp_xstrdup(mp,s);
4715 mp_sym sym = mp_id_lookup(mp,ss,l,false);
4717 if (mp_type(sym->v.data.node) == mp_string_type) {
4719 return (char *) sym->v.data.node->data.str->str;
4727 @ @<Exported function headers@>=
4728 double mp_get_numeric_value(MP mp,const char *s,size_t l);
4729 int mp_get_boolean_value(MP mp,const char *s,size_t l);
4730 char *mp_get_string_value(MP mp,const char *s,size_t l);
4732 @ We need to put \MP's ``primitive'' symbolic tokens into the hash
4733 table, together with their command code (which will be the |eq_type|)
4734 and an operand (which will be the |equiv|). The |primitive| procedure
4735 does this, in a way that no \MP\ user can. The global value |cur_sym|
4736 contains the new |eqtb| pointer after |primitive| has acted.
4739 static void mp_primitive (MP mp, const char *ss, halfword c, halfword o) {
4740 char *s = mp_xstrdup (mp, ss);
4741 set_cur_sym (mp_id_lookup (mp, s, strlen (s), true));
4743 set_eq_type (cur_sym(), c);
4744 set_equiv (cur_sym(), o);
4748 @ Some other symbolic tokens only exist for error recovery.
4751 static mp_sym mp_frozen_primitive (MP mp, const char *ss, halfword c,
4753 char *s = mp_xstrdup (mp, ss);
4754 mp_sym str = mp_frozen_id_lookup (mp, s, strlen (ss), true);
4757 str->v.data.indep.serial = o;
4762 @ This routine returns |true| if the argument is an un-redefinable symbol
4763 because it is one of the error recovery tokens (as explained elsewhere,
4764 |frozen_inaccessible| actuall is redefinable).
4767 static boolean mp_is_frozen (MP mp, mp_sym sym) {
4768 mp_sym temp = mp_frozen_id_lookup (mp, (char *) sym->text->str, sym->text->len, false);
4769 if (temp==mp->frozen_inaccessible)
4771 return (temp == sym);
4775 @ Many of \MP's primitives need no |equiv|, since they are identifiable
4776 by their |eq_type| alone. These primitives are loaded into the hash table
4779 @<Put each of \MP's primitives into the hash table@>=
4780 mp_primitive (mp, "..
", mp_path_join, 0);
4781 @:.._}{\.{..} primitive@>;
4782 mp_primitive (mp, "[", mp_left_bracket, 0);
4783 mp->frozen_left_bracket = mp_frozen_primitive (mp, "[", mp_left_bracket, 0);
4784 @:[ }{\.{[} primitive@>;
4785 mp_primitive (mp, "]", mp_right_bracket, 0);
4786 @:] }{\.{]} primitive@>;
4787 mp_primitive (mp, "}", mp_right_brace, 0);
4788 @:]]}{\.{\char`\}} primitive@>;
4789 mp_primitive (mp, "{", mp_left_brace, 0);
4790 @:][}{\.{\char`\{} primitive@>;
4791 mp_primitive (mp, ":", mp_colon, 0);
4792 mp->frozen_colon = mp_frozen_primitive (mp, ":", mp_colon, 0);
4793 @:: }{\.{:} primitive@>;
4794 mp_primitive (mp, "::", mp_double_colon, 0);
4795 @::: }{\.{::} primitive@>;
4796 mp_primitive (mp, "||
:", mp_bchar_label, 0);
4797 @:::: }{\.{\char'174\char'174:} primitive@>;
4798 mp_primitive (mp, ":=", mp_assignment, 0);
4799 @::=_}{\.{:=} primitive@>;
4800 mp_primitive (mp, ",", mp_comma, 0);
4801 @:, }{\., primitive@>;
4802 mp_primitive (mp, ";", mp_semicolon, 0);
4803 mp->frozen_semicolon = mp_frozen_primitive (mp, ";", mp_semicolon, 0);
4804 @:; }{\.; primitive@>;
4805 mp_primitive (mp, "\\
", mp_relax, 0);
4806 @:]]\\}{\.{\char`\\} primitive@>;
4807 mp_primitive (mp, "addto
", mp_add_to_command, 0);
4808 @:add_to_}{\&{addto} primitive@>;
4809 mp_primitive (mp, "atleast
", mp_at_least, 0);
4810 @:at_least_}{\&{atleast} primitive@>;
4811 mp_primitive (mp, "begingroup
", mp_begin_group, 0);
4812 mp->bg_loc = cur_sym();
4813 @:begin_group_}{\&{begingroup} primitive@>;
4814 mp_primitive (mp, "controls
", mp_controls, 0);
4815 @:controls_}{\&{controls} primitive@>;
4816 mp_primitive (mp, "curl
", mp_curl_command, 0);
4817 @:curl_}{\&{curl} primitive@>;
4818 mp_primitive (mp, "delimiters
", mp_delimiters, 0);
4819 @:delimiters_}{\&{delimiters} primitive@>;
4820 mp_primitive (mp, "endgroup
", mp_end_group, 0);
4821 mp->eg_loc = cur_sym();
4822 mp->frozen_end_group = mp_frozen_primitive (mp, "endgroup
", mp_end_group, 0);
4823 @:endgroup_}{\&{endgroup} primitive@>;
4824 mp_primitive (mp, "everyjob
", mp_every_job_command, 0);
4825 @:every_job_}{\&{everyjob} primitive@>;
4826 mp_primitive (mp, "exitif
", mp_exit_test, 0);
4827 @:exit_if_}{\&{exitif} primitive@>;
4828 mp_primitive (mp, "expandafter
", mp_expand_after, 0);
4829 @:expand_after_}{\&{expandafter} primitive@>;
4830 mp_primitive (mp, "interim
", mp_interim_command, 0);
4831 @:interim_}{\&{interim} primitive@>;
4832 mp_primitive (mp, "let
", mp_let_command, 0);
4833 @:let_}{\&{let} primitive@>;
4834 mp_primitive (mp, "newinternal
", mp_new_internal, 0);
4835 @:new_internal_}{\&{newinternal} primitive@>;
4836 mp_primitive (mp, "of
", mp_of_token, 0);
4837 @:of_}{\&{of} primitive@>;
4838 mp_primitive (mp, "randomseed
", mp_random_seed, 0);
4839 @:mp_random_seed_}{\&{randomseed} primitive@>;
4840 mp_primitive (mp, "save
", mp_save_command, 0);
4841 @:save_}{\&{save} primitive@>;
4842 mp_primitive (mp, "scantokens
", mp_scan_tokens, 0);
4843 @:scan_tokens_}{\&{scantokens} primitive@>;
4845 mp_primitive (mp, "runscript
", mp_runscript, 0);
4846 @:run_script_}{\&{runscript} primitive@>;
4848 mp_primitive (mp, "shipout
", mp_ship_out_command, 0);
4849 @:ship_out_}{\&{shipout} primitive@>;
4850 mp_primitive (mp, "skipto
", mp_skip_to, 0);
4851 @:skip_to_}{\&{skipto} primitive@>;
4852 mp_primitive (mp, "special
", mp_special_command, 0);
4853 @:special}{\&{special} primitive@>;
4854 mp_primitive (mp, "fontmapfile
", mp_special_command, 1);
4855 @:fontmapfile}{\&{fontmapfile} primitive@>;
4856 mp_primitive (mp, "fontmapline
", mp_special_command, 2);
4857 @:fontmapline}{\&{fontmapline} primitive@>;
4858 mp_primitive (mp, "step
", mp_step_token, 0);
4859 @:step_}{\&{step} primitive@>;
4860 mp_primitive (mp, "str
", mp_str_op, 0);
4861 @:str_}{\&{str} primitive@>;
4862 mp_primitive (mp, "tension
", mp_tension, 0);
4863 @:tension_}{\&{tension} primitive@>;
4864 mp_primitive (mp, "to
", mp_to_token, 0);
4865 @:to_}{\&{to} primitive@>;
4866 mp_primitive (mp, "until
", mp_until_token, 0);
4867 @:until_}{\&{until} primitive@>;
4868 mp_primitive (mp, "within
", mp_within_token, 0);
4869 @:within_}{\&{within} primitive@>;
4870 mp_primitive (mp, "write
", mp_write_command, 0);
4871 @:write_}{\&{write} primitive@>
4874 @ Each primitive has a corresponding inverse, so that it is possible to
4875 display the cryptic numeric contents of |eqtb| in symbolic form.
4876 Every call of |primitive| in this program is therefore accompanied by some
4877 straightforward code that forms part of the |print_cmd_mod| routine
4880 @<Cases of |print_cmd_mod| for symbolic printing of primitives@>=
4881 case mp_add_to_command:
4882 mp_print (mp, "addto
");
4885 mp_print (mp, ":=");
4888 mp_print (mp, "atleast
");
4890 case mp_bchar_label:
4891 mp_print (mp, "||
:");
4893 case mp_begin_group:
4894 mp_print (mp, "begingroup
");
4903 mp_print (mp, "controls
");
4905 case mp_curl_command:
4906 mp_print (mp, "curl
");
4909 mp_print (mp, "delimiters
");
4911 case mp_double_colon:
4912 mp_print (mp, "::");
4915 mp_print (mp, "endgroup
");
4917 case mp_every_job_command:
4918 mp_print (mp, "everyjob
");
4921 mp_print (mp, "exitif
");
4923 case mp_expand_after:
4924 mp_print (mp, "expandafter
");
4926 case mp_interim_command:
4927 mp_print (mp, "interim
");
4932 case mp_left_bracket:
4935 case mp_let_command:
4936 mp_print (mp, "let
");
4938 case mp_new_internal:
4939 mp_print (mp, "newinternal
");
4942 mp_print (mp, "of
");
4945 mp_print (mp, "..
");
4947 case mp_random_seed:
4948 mp_print (mp, "randomseed
");
4951 mp_print_char (mp, xord ('\\'));
4953 case mp_right_brace:
4954 mp_print_char (mp, xord ('}'));
4956 case mp_right_bracket:
4957 mp_print_char (mp, xord (']'));
4959 case mp_save_command:
4960 mp_print (mp, "save
");
4962 case mp_scan_tokens:
4963 mp_print (mp, "scantokens
");
4966 mp_print (mp, "runscript
");
4969 mp_print_char (mp, xord (';'));
4971 case mp_ship_out_command:
4972 mp_print (mp, "shipout
");
4975 mp_print (mp, "skipto
");
4977 case mp_special_command:
4979 mp_print (mp, "fontmapline
");
4981 mp_print (mp, "fontmapfile
");
4983 mp_print (mp, "special
");
4986 mp_print (mp, "step
");
4989 mp_print (mp, "str
");
4992 mp_print (mp, "tension
");
4995 mp_print (mp, "to
");
4997 case mp_until_token:
4998 mp_print (mp, "until
");
5000 case mp_within_token:
5001 mp_print (mp, "within
");
5003 case mp_write_command:
5004 mp_print (mp, "write
");
5007 @ We will deal with the other primitives later, at some point in the program
5008 where their |eq_type| and |equiv| values are more meaningful. For example,
5009 the primitives for macro definitions will be loaded when we consider the
5010 routines that define macros. It is easy to find where each particular
5011 primitive was treated by looking in the index at the end; for example, the
5012 section where |"def
"| entered |eqtb| is listed under `\&{def} primitive'.
5016 A \MP\ token is either symbolic or numeric or a string, or it denotes a macro
5017 parameter or capsule or an internal; so there are six corresponding ways to
5018 encode it internally:
5021 (1)~A symbolic token for symbol |p| is represented by the pointer |p|,
5022 in the |sym_sym| field of a symbolic node in~|mem|. The |type| field is |symbol_node|;
5023 and it has a |name_type| to differentiate various subtypes of symbolic tokens,
5024 which is usually |normal_sym|, but |macro_sym| for macro names.
5026 (2)~A numeric token whose |scaled| value is~|v| is
5027 represented in a non-symbolic node of~|mem|; the |type| field is |known|,
5028 the |name_type| field is |token|, and the |value| field holds~|v|.
5030 (3)~A string token is also represented in a non-symbolic node; the |type|
5031 field is |mp_string_type|, the |name_type| field is |token|, and the
5032 |value| field holds the corresponding |mp_string|.
5034 (4)~Capsules have |name_type=capsule|, and their |type| and |value| fields
5035 represent arbitrary values, with |type| different from |symbol_node|
5036 (in ways to be explained later).
5038 (5)~Macro parameters appear in |sym_info| fields of symbolic nodes. The |type|
5039 field is |symbol_node|; the $k$th parameter is represented by |k| in |sym_info|;
5040 and |expr_sym| in |name_type|, if it is of type \&{expr}, or |suffix_sym| if it
5041 is of type \&{suffix}, or by |text_sym| if it is of type \&{text}.
5043 (6)~The $k$th internal is also represented by |k| in |sym_info|; the |type| field is
5044 |symbol_node| as for the other symbolic tokens; and |internal_sym| is its |name_type|;
5046 Actual values of the parameters and internals are kept in a separate
5047 stack, as we will see later.
5049 Note that the `\\{type}' field of a node has nothing to do with ``type'' in a
5050 printer's sense. It's curious that the same word is used in such different ways.
5052 @d token_node_size sizeof(mp_node_data) /* the number of words in a large token node */
5054 @d set_value_sym(A,B) do_set_value_sym(mp, (mp_token_node)(A), (B))
5055 @d set_value_number(A,B) do_set_value_number(mp, (mp_token_node)(A), (B))
5056 @d set_value_node(A,B) do_set_value_node(mp, (mp_token_node)(A), (B))
5057 @d set_value_str(A,B) do_set_value_str(mp, (mp_token_node)(A), (B))
5058 @d set_value_knot(A,B) do_set_value_knot(mp, (mp_token_node)A, (B))
5060 @d value_sym_NEW(A) (mp_sym)mp_link(A)
5061 @d set_value_sym_NEW(A,B) set_mp_link(A,(mp_node)B)
5063 @<MPlib internal header stuff@>=
5064 typedef struct mp_node_data *mp_token_node;
5068 #define value_sym(A) do_get_value_sym(mp,(mp_token_node)(A))
5069 /* |#define value_number(A) do_get_value_number(mp,(mp_token_node)(A))| */
5070 #define value_number(A) ((mp_token_node)(A))->data.n
5071 #define value_node(A) do_get_value_node(mp,(mp_token_node)(A))
5072 #define value_str(A) do_get_value_str(mp,(mp_token_node)(A))
5073 #define value_knot(A) do_get_value_knot(mp,(mp_token_node)(A))
5075 #define value_sym(A) ((mp_token_node)(A))->data.sym
5076 #define value_number(A) ((mp_token_node)(A))->data.n
5077 #define value_node(A) ((mp_token_node)(A))->data.node
5078 #define value_str(A) ((mp_token_node)(A))->data.str
5079 #define value_knot(A) ((mp_token_node)(A))->data.p
5081 static void do_set_value_sym(MP mp, mp_token_node A, mp_sym B) {
5082 FUNCTION_TRACE3 ("set_value_sym
(%p
,%p
)\n
", (A),(B));
5085 static void do_set_value_number(MP mp, mp_token_node A, mp_number B) {
5086 FUNCTION_TRACE3 ("set_value
(%p
,%s
)\n
", (A), number_tostring(B));
5089 A->data.node = NULL;
5090 number_clone (A->data.n, B);
5092 static void do_set_value_str(MP mp, mp_token_node A, mp_string B) {
5093 FUNCTION_TRACE3 ("set_value_str
(%p
,%p
)\n
", (A),(B));
5094 assert (A->type != mp_structured);
5098 A->data.node = NULL;
5099 number_clone (A->data.n, zero_t);
5101 static void do_set_value_node(MP mp, mp_token_node A, mp_node B) {
5102 /* store the value in a large token node */
5103 FUNCTION_TRACE3 ("set_value_node
(%p
,%p
)\n
", A,B);
5104 assert (A->type != mp_structured);
5108 number_clone (A->data.n, zero_t);
5110 static void do_set_value_knot(MP mp, mp_token_node A, mp_knot B) {
5111 FUNCTION_TRACE3 ("set_value_knot
(%p
,%p
)\n
", (A),(B));
5112 assert (A->type != mp_structured);
5115 A->data.node = NULL;
5116 number_clone (A->data.n, zero_t);
5122 static mp_sym do_get_value_sym (MP mp, mp_token_node A) {
5123 /* |A->type| can be structured in this case */
5124 FUNCTION_TRACE3 ("%p
= get_value_sym
(%p
)\n
", A->data.sym, A);
5125 return A->data.sym ;
5127 static mp_node do_get_value_node (MP mp, mp_token_node A) {
5128 assert (A->type != mp_structured);
5129 FUNCTION_TRACE3 ("%p
= get_value_node
(%p
)\n
", A->data.node, A);
5130 return A->data.node ;
5132 static mp_string do_get_value_str (MP mp, mp_token_node A) {
5133 assert (A->type != mp_structured);
5134 FUNCTION_TRACE3 ("%p
= get_value_str
(%p
)\n
", A->data.str, A);
5135 return A->data.str ;
5137 static mp_knot do_get_value_knot (MP mp, mp_token_node A) {
5138 assert (A->type != mp_structured);
5139 FUNCTION_TRACE3 ("%p
= get_value_knot
(%p
)\n
", A->data.p, A);
5142 static mp_number do_get_value_number (MP mp, mp_token_node A) {
5143 assert (A->type != mp_structured);
5144 FUNCTION_TRACE3 ("%d
= get_value_number
(%p
)\n
", A->data.n.type, A);
5151 static mp_number do_get_value_number (MP mp, mp_token_node A);
5152 static mp_sym do_get_value_sym (MP mp, mp_token_node A);
5153 static mp_node do_get_value_node (MP mp, mp_token_node A);
5154 static mp_string do_get_value_str (MP mp, mp_token_node A) ;
5155 static mp_knot do_get_value_knot (MP mp, mp_token_node A) ;
5157 static void do_set_value_sym (MP mp, mp_token_node A, mp_sym B);
5158 static void do_set_value_number (MP mp, mp_token_node A, mp_number B);
5159 static void do_set_value_node (MP mp, mp_token_node A, mp_node B);
5160 static void do_set_value_str (MP mp, mp_token_node A, mp_string B);
5161 static void do_set_value_knot (MP mp, mp_token_node A, mp_knot B);
5165 static mp_node mp_get_token_node (MP mp) {
5167 if (mp->token_nodes) {
5168 p = mp->token_nodes;
5169 mp->token_nodes = p->link;
5170 mp->num_token_nodes--;
5173 p = malloc_node (token_node_size);
5174 new_number(p->data.n);
5177 p->type = mp_token_node_type;
5178 FUNCTION_TRACE2 ("%p
= mp_get_token_node
()\n
", p);
5183 static void mp_free_token_node (MP mp, mp_node p) {
5184 FUNCTION_TRACE2 ("mp_free_token_node
(%p
)\n
", p);
5186 if (mp->num_token_nodes < max_num_token_nodes) {
5187 p->link = mp->token_nodes;
5188 mp->token_nodes = p;
5189 mp->num_token_nodes++;
5192 mp->var_used -= token_node_size;
5193 if (mp->math_mode > mp_math_double_mode) {
5194 free_number(((mp_value_node)p)->data.n);
5200 static void mp_free_token_node (MP mp, mp_node p);
5202 @ A numeric token is created by the following trivial routine.
5205 static mp_node mp_new_num_tok (MP mp, mp_number v) {
5206 mp_node p; /* the new node */
5207 p = mp_get_token_node (mp);
5208 set_value_number (p, v);
5210 p->name_type = mp_token;
5211 FUNCTION_TRACE3 ("%p
= mp_new_num_tok
(%p
)\n
", p, v);
5216 @ A token list is a singly linked list of nodes in |mem|, where
5217 each node contains a token and a link. Here's a subroutine that gets rid
5218 of a token list when it is no longer needed.
5221 static void mp_flush_token_list (MP mp, mp_node p) {
5222 mp_node q; /* the node being recycled */
5223 FUNCTION_TRACE2 ("mp_flush_token_list
(%p
)\n
", p);
5227 if (mp_type (q) == mp_symbol_node) {
5228 mp_free_symbolic_node (mp, q);
5230 switch (mp_type (q)) {
5232 case mp_boolean_type:
5235 case mp_string_type:
5236 delete_str_ref (value_str (q));
5241 case mp_picture_type:
5244 case mp_cmykcolor_type:
5245 case mp_transform_type:
5247 case mp_proto_dependent:
5248 case mp_independent:
5249 mp_recycle_value (mp, q);
5252 mp_confusion (mp, "token
");
5253 @:this can't happen token}{\quad token@>;
5255 mp_free_token_node (mp, q);
5261 @ The procedure |show_token_list|, which prints a symbolic form of
5262 the token list that starts at a given node |p|, illustrates these
5263 conventions. The token list being displayed should not begin with a reference
5266 An additional parameter |q| is also given; this parameter is either NULL
5267 or it points to a node in the token list where a certain magic computation
5268 takes place that will be explained later. (Basically, |q| is non-NULL when
5269 we are printing the two-line context information at the time of an error
5270 message; |q| marks the place corresponding to where the second line
5273 The generation will stop, and `\.{\char`\ ETC.}' will be printed, if the length
5274 of printing exceeds a given limit~|l|; the length of printing upon entry is
5275 assumed to be a given amount called |null_tally|. (Note that
5276 |show_token_list| sometimes uses itself recursively to print
5277 variable names within a capsule.)
5280 Unusual entries are printed in the form of all-caps tokens
5281 preceded by a space, e.g., `\.{\char`\ BAD}'.
5284 static void mp_show_token_list (MP mp, mp_node p, mp_node q, integer l,
5285 integer null_tally);
5288 void mp_show_token_list (MP mp, mp_node p, mp_node q, integer l,
5289 integer null_tally) {
5290 quarterword cclass, c; /* the |char_class| of previous and new tokens */
5291 cclass = percent_class;
5292 mp->tally = null_tally;
5293 while ((p != NULL) && (mp->tally < l)) {
5297 /* Display token |p| and set |c| to its class; but |return| if there are problems */
5298 c = letter_class; /* the default */
5299 if (mp_type (p) != mp_symbol_node) {
5300 /* Display non-symbolic token */
5301 if (mp_name_type (p) == mp_token) {
5302 if (mp_type (p) == mp_known) {
5303 /* Display a numeric token */
5304 if (cclass == digit_class)
5305 mp_print_char (mp, xord (' '));
5306 if (number_negative (value_number (p))) {
5307 if (cclass == mp_left_bracket_class)
5308 mp_print_char (mp, xord (' '));
5309 mp_print_char (mp, xord ('['));
5310 print_number (value_number (p));
5311 mp_print_char (mp, xord (']'));
5312 c = mp_right_bracket_class;
5314 print_number (value_number (p));
5318 } else if (mp_type (p) != mp_string_type) {
5319 mp_print (mp, " BAD
");
5321 mp_print_char (mp, xord ('"'
));
5322 mp_print_str
(mp
, value_str
(p
));
5323 mp_print_char
(mp
, xord
('
"'));
5326 } else if ((mp_name_type (p) != mp_capsule) || (mp_type (p) < mp_vacuous)
5327 || (mp_type (p) > mp_independent)) {
5328 mp_print (mp, " BAD
");
5330 mp_print_capsule (mp, p);
5331 c = right_paren_class;
5335 if (mp_name_type (p) == mp_expr_sym ||
5336 mp_name_type (p) == mp_suffix_sym || mp_name_type (p) == mp_text_sym) {
5337 integer r; /* temporary register */
5338 r = mp_sym_info (p);
5339 if (mp_name_type (p) == mp_expr_sym) {
5340 mp_print (mp, "(EXPR
");
5341 } else if (mp_name_type (p) == mp_suffix_sym) {
5342 mp_print (mp, "(SUFFIX
");
5344 mp_print (mp, "(TEXT");
5346 mp_print_int (mp, r);
5347 mp_print_char (mp, xord (')'));
5348 c = right_paren_class;
5350 mp_sym sr = mp_sym_sym (p);
5351 if (sr == collective_subscript) {
5352 /* Display a collective subscript */
5353 if (cclass == mp_left_bracket_class)
5354 mp_print_char (mp, xord (' '));
5355 mp_print (mp, "[]");
5356 c = mp_right_bracket_class;
5359 mp_string rr = text (sr);
5360 if (rr == NULL || rr->str == NULL) {
5361 mp_print (mp, " NONEXISTENT
");
5363 /* Print string |r| as a symbolic token and set |c| to its class */
5364 c = (quarterword) mp->char_class[(rr->str[0])];
5368 mp_print_char (mp, xord ('.'));
5370 case isolated_classes:
5373 mp_print_char (mp, xord (' '));
5377 mp_print_str (mp, rr);
5388 mp_print (mp, " ETC.
");
5394 static void mp_print_capsule (MP mp, mp_node p);
5396 @ @<Declare miscellaneous procedures that were declared |forward|@>=
5397 void mp_print_capsule (MP mp, mp_node p) {
5398 mp_print_char (mp, xord ('('));
5399 mp_print_exp (mp, p, 0);
5400 mp_print_char (mp, xord (')'));
5404 @ Macro definitions are kept in \MP's memory in the form of token lists
5405 that have a few extra symbolic nodes at the beginning.
5407 The first node contains a reference count that is used to tell when the
5408 list is no longer needed. To emphasize the fact that a reference count is
5409 present, we shall refer to the |sym_info| field of this special node as the
5411 @^reference counts@>
5413 The next node or nodes after the reference count serve to describe the
5414 formal parameters. They consist of zero or more parameter tokens followed
5415 by a code for the type of macro.
5417 /* reference count preceding a macro definition or picture header */
5418 @d ref_count(A) indep_value(A)
5419 @d set_ref_count(A,B) set_indep_value(A,B)
5420 @d add_mac_ref(A) set_ref_count((A),ref_count((A))+1) /* make a new reference to a macro list */
5421 @d decr_mac_ref(A) set_ref_count((A),ref_count((A))-1) /* remove a reference to a macro list */
5425 mp_general_macro, /* preface to a macro defined with a parameter list */
5426 mp_primary_macro, /* preface to a macro with a \&{primary} parameter */
5427 mp_secondary_macro, /* preface to a macro with a \&{secondary} parameter */
5428 mp_tertiary_macro, /* preface to a macro with a \&{tertiary} parameter */
5429 mp_expr_macro, /* preface to a macro with an undelimited \&{expr} parameter */
5430 mp_of_macro, /* preface to a macro with undelimited `\&{expr} |x| \&{of}~|y|' parameters */
5431 mp_suffix_macro, /* preface to a macro with an undelimited \&{suffix} parameter */
5432 mp_text_macro, /* preface to a macro with an undelimited \&{text} parameter */
5433 mp_expr_param, /* used by \.{expr} primitive */
5434 mp_suffix_param, /* used by \.{suffix} primitive */
5435 mp_text_param /* used by \.{text} primitive */
5439 static void mp_delete_mac_ref (MP mp, mp_node p) {
5440 /* |p| points to the reference count of a macro list that is
5441 losing one reference */
5442 if (ref_count (p) == 0)
5443 mp_flush_token_list (mp, p);
5449 @ The following subroutine displays a macro, given a pointer to its
5453 static void mp_show_macro (MP mp, mp_node p, mp_node q, integer l) {
5454 mp_node r; /* temporary storage */
5455 p = mp_link (p); /* bypass the reference count */
5456 while (mp_name_type (p) != mp_macro_sym) {
5459 mp_show_token_list (mp, p, NULL, l, 0);
5466 } /* control printing of `\.{ETC.}' */
5469 switch (mp_sym_info (p)) {
5470 case mp_general_macro:
5471 mp_print (mp, "->");
5474 case mp_primary_macro:
5475 case mp_secondary_macro:
5476 case mp_tertiary_macro:
5477 mp_print_char (mp, xord ('<'));
5478 mp_print_cmd_mod (mp, mp_param_type, mp_sym_info (p));
5479 mp_print (mp, ">->");
5482 mp_print (mp, "<expr
>->");
5485 mp_print (mp, "<expr
>of
<primary
>->");
5487 case mp_suffix_macro:
5488 mp_print (mp, "<suffix
>->");
5491 mp_print (mp, "<text
>->");
5493 } /* there are no other cases */
5494 mp_show_token_list (mp, mp_link (p), q, l - mp->tally, 0);
5498 @* Data structures for variables.
5499 The variables of \MP\ programs can be simple, like `\.x', or they can
5500 combine the structural properties of arrays and records, like `\.{x20a.b}'.
5501 A \MP\ user assigns a type to a variable like \.{x20a.b} by saying, for
5502 example, `\.{boolean} \.{x[]a.b}'. It's time for us to study how such
5503 things are represented inside of the computer.
5505 Each variable value occupies two consecutive words, either in a non-symbolic
5506 node called a value node, or as a non-symbolic subfield of a larger node. One
5507 of those two words is called the |value| field; it is an integer,
5508 containing either a |scaled| numeric value or the representation of some
5509 other type of quantity. (It might also be subdivided into halfwords, in
5510 which case it is referred to by other names instead of |value|.) The other
5511 word is broken into subfields called |type|, |name_type|, and |link|. The
5512 |type| field is a quarterword that specifies the variable's type, and
5513 |name_type| is a quarterword from which \MP\ can reconstruct the
5514 variable's name (sometimes by using the |link| field as well). Thus, only
5515 1.25 words are actually devoted to the value itself; the other
5516 three-quarters of a word are overhead, but they aren't wasted because they
5517 allow \MP\ to deal with sparse arrays and to provide meaningful diagnostics.
5519 In this section we shall be concerned only with the structural aspects of
5520 variables, not their values. Later parts of the program will change the
5521 |type| and |value| fields, but we shall treat those fields as black boxes
5522 whose contents should not be touched.
5524 However, if the |type| field is |mp_structured|, there is no |value| field,
5525 and the second word is broken into two pointer fields called |attr_head|
5526 and |subscr_head|. Those fields point to additional nodes that
5527 contain structural information, as we shall see.
5529 TH Note: DEK and JDH had a nice theoretical split between |value|,
5530 |attr| and |subscr| nodes, as documented above and further
5531 below. However, all three types had a bad habit of transmuting into
5532 each other in practice while pointers to them still lived on
5533 elsewhere, so using three different C structures is simply not
5534 workable. All three are now represented as a single C structure called
5537 There is a potential union in this structure in the interest of space
5538 saving: |subscript_| and |hashloc_| are mutually exclusive.
5540 Actually, so are |attr_head_| + |subscr_head_| on one side and and
5541 |value_| on the other, but because of all the access macros that are
5542 used in the code base to get at values, those cannot be folded into a
5543 union (yet); this would have required creating a similar union in
5544 |mp_token_node| where it would only serve to confuse things.
5546 Finally, |parent_| only applies in |attr| nodes (the ones that have
5547 |hashloc_|), but creating an extra substructure inside the union just
5548 for that does not save space and the extra complication in the
5549 structure is not worth the minimal extra code clarification.
5551 @d attr_head(A) do_get_attr_head(mp,(mp_value_node)(A))
5552 @d set_attr_head(A,B) do_set_attr_head(mp,(mp_value_node)(A),(mp_node)(B))
5554 @d subscr_head(A) do_get_subscr_head(mp,(mp_value_node)(A))
5555 @d set_subscr_head(A,B) do_set_subscr_head(mp,(mp_value_node)(A),(mp_node)(B))
5557 @<MPlib internal header stuff@>=
5558 typedef struct mp_value_node_data {
5561 mp_number subscript_;
5565 mp_node subscr_head_;
5566 } mp_value_node_data;
5569 static mp_node do_get_attr_head (MP mp, mp_value_node A) {
5570 assert (A->type == mp_structured);
5571 FUNCTION_TRACE3 ("%p
= get_attr_head
(%p
)\n
", A->attr_head_, A);
5572 return A->attr_head_;
5574 static mp_node do_get_subscr_head (MP mp, mp_value_node A) {
5575 assert (A->type == mp_structured);
5576 FUNCTION_TRACE3 ("%p
= get_subscr_head
(%p
)\n
", A->subscr_head_, A);
5577 return A->subscr_head_;
5579 static void do_set_attr_head (MP mp, mp_value_node A, mp_node d) {
5580 FUNCTION_TRACE4 ("set_attr_head
(%p
,%p
) on line
%d\n
", (A), d, __LINE__);
5581 assert (A->type == mp_structured);
5584 static void do_set_subscr_head (MP mp, mp_value_node A, mp_node d) {
5585 FUNCTION_TRACE4 ("set_subscr_head
(%p
,%p
) on line
%d\n
", (A), d, __LINE__);
5586 assert (A->type == mp_structured);
5587 A->subscr_head_ = d;
5591 static mp_node do_get_subscr_head (MP mp, mp_value_node A);
5592 static mp_node do_get_attr_head (MP mp, mp_value_node A);
5593 static void do_set_attr_head (MP mp, mp_value_node A, mp_node d);
5594 static void do_set_subscr_head (MP mp, mp_value_node A, mp_node d);
5596 @ It would have been nicer to make |mp_get_value_node| return
5597 |mp_value_node| variables, but with |eqtb| as it stands that
5598 became messy: lots of typecasts. So, it returns a simple
5601 @d value_node_size sizeof(struct mp_value_node_data)
5604 static mp_node mp_get_value_node (MP mp) {
5606 if (mp->value_nodes) {
5607 p = (mp_value_node)mp->value_nodes;
5608 mp->value_nodes = p->link;
5609 mp->num_value_nodes--;
5612 p = malloc_node (value_node_size);
5613 new_number(p->data.n);
5614 new_number(p->subscript_);
5617 mp_type (p) = mp_value_node_type;
5618 FUNCTION_TRACE2 ("%p
= mp_get_value_node
()\n
", p);
5622 static void debug_dump_value_node (mp_node x) {
5623 mp_value_node qq = (mp_value_node)x;
5624 fprintf (stdout, "\nnode
%p
:\n
", qq);
5625 fprintf (stdout, " type
=%s\n
", mp_type_string(qq->type));
5626 fprintf (stdout, " name_type
=%d\n
", qq->name_type);
5627 fprintf (stdout, " link
=%p\n
", qq->link);
5628 fprintf (stdout, " data.n
=%d\n
", qq->data.n.type);
5629 if (is_number(qq->data.n)) {
5630 fprintf (stdout, " data.n.data.val
=%d\n
", qq->data.n.data.val);
5631 fprintf (stdout, " data.n.data.dval
=%f\n
", qq->data.n.data.dval);
5633 fprintf (stdout, " data.str
=%p\n
", qq->data.str);
5634 if (qq->data.str != NULL) {
5635 fprintf (stdout, " data.str-
>len
=%d\n
", (int)qq->data.str->len);
5636 fprintf (stdout, " data.str-
>str
=%s\n
", qq->data.str->str);
5638 fprintf (stdout, " data.indep.serial
=%d\n data.indep.scale
=%d\n
", qq->data.indep.serial,
5639 qq->data.indep.scale);
5640 fprintf (stdout, " data.sym
=%p\n
", qq->data.sym);
5641 fprintf (stdout, " data.p
=%p\n
", qq->data.p);
5642 fprintf (stdout, " data.node
=%p\n
", qq->data.node);
5643 fprintf (stdout, " subscript
=%d\n
", qq->subscript_.type);
5644 if (is_number(qq->subscript_)) {
5645 fprintf (stdout, " subscript_.data.val
=%d\n
", qq->subscript_.data.val);
5646 fprintf (stdout, " subscript_.data.dval
=%f\n
", qq->subscript_.data.dval);
5648 fprintf (stdout, " hashloc
=%p\n
", qq->hashloc_);
5649 fprintf (stdout, " parent
=%p\n
", qq->parent_);
5650 fprintf (stdout, " attr_head
=%p\n
", qq->attr_head_);
5651 fprintf (stdout, " subscr_head
=%p\n\n
", qq->subscr_head_);
5656 static mp_node mp_get_value_node (MP mp);
5658 static void debug_dump_value_node (mp_node x);
5661 @ An attribute node is three words long. Two of these words contain |type|
5662 and |value| fields as described above, and the third word contains
5663 additional information: There is an |hashloc| field, which contains the
5664 hash address of the token that names this attribute; and there's also a
5665 |parent| field, which points to the value node of |mp_structured| type at the
5666 next higher level (i.e., at the level to which this attribute is
5667 subsidiary). The |name_type| in an attribute node is `|attr|'. The
5668 |link| field points to the next attribute with the same parent; these are
5669 arranged in increasing order, so that |hashloc(mp_link(p))>hashloc(p)|. The
5670 final attribute node links to the constant |end_attr|, whose |hashloc|
5671 field is greater than any legal hash address. The |attr_head| in the
5672 parent points to a node whose |name_type| is |mp_structured_root|; this
5673 node represents the NULL attribute, i.e., the variable that is relevant
5674 when no attributes are attached to the parent. The |attr_head| node
5675 has the fields of either
5676 a value node, a subscript node, or an attribute node, depending on what
5677 the parent would be if it were not structured; but the subscript and
5678 attribute fields are ignored, so it effectively contains only the data of
5679 a value node. The |link| field in this special node points to an attribute
5680 node whose |hashloc| field is zero; the latter node represents a collective
5681 subscript `\.{[]}' attached to the parent, and its |link| field points to
5682 the first non-special attribute node (or to |end_attr| if there are none).
5684 A subscript node likewise occupies three words, with |type| and |value| fields
5685 plus extra information; its |name_type| is |subscr|. In this case the
5686 third word is called the |subscript| field, which is a |scaled| integer.
5687 The |link| field points to the subscript node with the next larger
5688 subscript, if any; otherwise the |link| points to the attribute node
5689 for collective subscripts at this level. We have seen that the latter node
5690 contains an upward pointer, so that the parent can be deduced.
5692 The |name_type| in a parent-less value node is |root|, and the |link|
5693 is the hash address of the token that names this value.
5695 In other words, variables have a hierarchical structure that includes
5696 enough threads running around so that the program is able to move easily
5697 between siblings, parents, and children. An example should be helpful:
5698 (The reader is advised to draw a picture while reading the following
5699 description, since that will help to firm up the ideas.)
5700 Suppose that `\.x' and `\.{x.a}' and `\.{x[]b}' and `\.{x5}'
5701 and `\.{x20b}' have been mentioned in a user's program, where
5702 \.{x[]b} has been declared to be of \&{boolean} type. Let |h(x)|, |h(a)|,
5703 and |h(b)| be the hash addresses of \.x, \.a, and~\.b. Then
5704 |eq_type(h(x))=name| and |equiv(h(x))=p|, where |p|~is a non-symbolic value
5705 node with |mp_name_type(p)=root| and |mp_link(p)=h(x)|. We have |type(p)=mp_structured|,
5706 |attr_head(p)=q|, and |subscr_head(p)=r|, where |q| points to a value
5707 node and |r| to a subscript node. (Are you still following this? Use
5708 a pencil to draw a diagram.) The lone variable `\.x' is represented by
5709 |type(q)| and |value(q)|; furthermore
5710 |mp_name_type(q)=mp_structured_root| and |mp_link(q)=q1|, where |q1| points
5711 to an attribute node representing `\.{x[]}'. Thus |mp_name_type(q1)=attr|,
5712 |hashloc(q1)=collective_subscript=0|, |parent(q1)=p|,
5713 |type(q1)=mp_structured|, |attr_head(q1)=qq|, and |subscr_head(q1)=qq1|;
5714 |qq| is a three-word ``attribute-as-value'' node with |type(qq)=numeric_type|
5715 (assuming that \.{x5} is numeric, because |qq| represents `\.{x[]}'
5716 with no further attributes), |mp_name_type(qq)=structured_root|,
5717 |hashloc(qq)=0|, |parent(qq)=p|, and
5718 |mp_link(qq)=qq1|. (Now pay attention to the next part.) Node |qq1| is
5719 an attribute node representing `\.{x[][]}', which has never yet
5720 occurred; its |type| field is |undefined|, and its |value| field is
5721 undefined. We have |mp_name_type(qq1)=attr|, |hashloc(qq1)=collective_subscript|,
5722 |parent(qq1)=q1|, and |mp_link(qq1)=qq2|. Since |qq2| represents
5723 `\.{x[]b}', |type(qq2)=mp_unknown_boolean|; also |hashloc(qq2)=h(b)|,
5724 |parent(qq2)=q1|, |mp_name_type(qq2)=attr|, |mp_link(qq2)=end_attr|.
5725 (Maybe colored lines will help untangle your picture.)
5726 Node |r| is a subscript node with |type| and |value|
5727 representing `\.{x5}'; |mp_name_type(r)=subscr|, |subscript(r)=5.0|,
5728 and |mp_link(r)=r1| is another subscript node. To complete the picture,
5729 see if you can guess what |mp_link(r1)| is; give up? It's~|q1|.
5730 Furthermore |subscript(r1)=20.0|, |mp_name_type(r1)=subscr|,
5731 |type(r1)=mp_structured|, |attr_head(r1)=qqq|, |subscr_head(r1)=qqq1|,
5732 and we finish things off with three more nodes
5733 |qqq|, |qqq1|, and |qqq2| hung onto~|r1|. (Perhaps you should start again
5734 with a larger sheet of paper.) The value of variable \.{x20b}
5735 appears in node~|qqq2|, as you can well imagine.
5737 If the example in the previous paragraph doesn't make things crystal
5738 clear, a glance at some of the simpler subroutines below will reveal how
5739 things work out in practice.
5741 The only really unusual thing about these conventions is the use of
5742 collective subscript attributes. The idea is to avoid repeating a lot of
5743 type information when many elements of an array are identical macros
5744 (for which distinct values need not be stored) or when they don't have
5745 all of the possible attributes. Branches of the structure below collective
5746 subscript attributes do not carry actual values except for macro identifiers;
5747 branches of the structure below subscript nodes do not carry significant
5748 information in their collective subscript attributes.
5753 #define hashloc(A) do_get_hashloc(mp,(mp_value_node)(A))
5754 #define set_hashloc(A,B) do_set_hashloc (mp,(mp_value_node)A, B)
5755 #define parent(A) do_get_parent(mp, A)
5756 #define set_parent(A,B) do_set_parent (mp,(mp_value_node)A, B)
5757 static mp_sym do_get_hashloc (MP mp, mp_value_node A) {
5758 assert((A)->type == mp_attr_node_type || (A)->name_type == mp_attr);
5759 return (A)->hashloc_;
5761 static void do_set_hashloc (MP mp, mp_value_node A, mp_sym B) {
5762 FUNCTION_TRACE4 ("set_hashloc
(%p
,%p
) on line
%d\n
", (A), (B), __LINE__);
5763 assert((A)->type == mp_attr_node_type || (A)->name_type == mp_attr);
5766 static mp_node do_get_parent (MP mp, mp_value_node A) {
5767 assert((A)->type == mp_attr_node_type || (A)->name_type == mp_attr);
5768 return (A)->parent_; /* pointer to |mp_structured| variable */
5770 static void do_set_parent (MP mp, mp_value_node A, mp_node d) {
5771 assert((A)->type == mp_attr_node_type || (A)->name_type == mp_attr);
5772 FUNCTION_TRACE4 ("set_parent
(%p
,%p
) on line
%d\n
", (A), d, __LINE__);
5776 #define hashloc(A) ((mp_value_node)(A))->hashloc_
5777 #define set_hashloc(A,B) ((mp_value_node)(A))->hashloc_ = B
5778 #define parent(A) ((mp_value_node)(A))->parent_
5779 #define set_parent(A,B) ((mp_value_node)(A))->parent_ = B
5783 @d mp_free_attr_node(a,b) do {
5784 assert((b)->type == mp_attr_node_type || (b)->name_type == mp_attr);
5785 mp_free_value_node(a,b);
5789 static mp_value_node mp_get_attr_node (MP mp) {
5790 mp_value_node p = (mp_value_node) mp_get_value_node (mp);
5791 mp_type (p) = mp_attr_node_type;
5796 @ Setting the |hashloc| field of |end_attr| to a value greater than
5797 any legal hash address is done by assigning $-1$ typecasted to
5798 |mp_sym|, hopefully resulting in all bits being set. On systems that
5799 support negative pointer values or where typecasting $-1$ does not
5800 result in all bits in a pointer being set, something else needs to be done.
5801 @^system dependencies@>
5803 @<Initialize table...@>=
5804 mp->end_attr = (mp_node) mp_get_attr_node (mp);
5805 set_hashloc (mp->end_attr, (mp_sym)-1);
5806 set_parent ((mp_value_node) mp->end_attr, NULL);
5808 @ @<Free table...@>=
5809 mp_free_attr_node (mp, mp->end_attr);
5812 @d collective_subscript (void *)0 /* code for the attribute `\.{[]}' */
5813 @d subscript(A) ((mp_value_node)(A))->subscript_
5814 @d set_subscript(A,B) do_set_subscript (mp, (mp_value_node)(A), B)
5817 static void do_set_subscript (MP mp, mp_value_node A, mp_number B) {
5818 FUNCTION_TRACE3("set_subscript
(%p
,%p
)\n
", (A), (B));
5819 assert((A)->type == mp_subscr_node_type || (A)->name_type == mp_subscr);
5820 number_clone(A->subscript_,B); /* subscript of this variable */
5825 static mp_value_node mp_get_subscr_node (MP mp) {
5826 mp_value_node p = (mp_value_node) mp_get_value_node (mp);
5827 mp_type (p) = mp_subscr_node_type;
5832 @ Variables of type \&{pair} will have values that point to four-word
5833 nodes containing two numeric values. The first of these values has
5834 |name_type=mp_x_part_sector| and the second has |name_type=mp_y_part_sector|;
5835 the |link| in the first points back to the node whose |value| points
5836 to this four-word node.
5838 @d x_part(A) ((mp_pair_node)(A))->x_part_ /* where the \&{xpart} is found in a pair node */
5839 @d y_part(A) ((mp_pair_node)(A))->y_part_ /* where the \&{ypart} is found in a pair node */
5841 @<MPlib internal header stuff@>=
5842 typedef struct mp_pair_node_data {
5846 } mp_pair_node_data;
5847 typedef struct mp_pair_node_data *mp_pair_node;
5850 @d pair_node_size sizeof(struct mp_pair_node_data) /* the number of words in a subscript node */
5853 static mp_node mp_get_pair_node (MP mp) {
5855 if (mp->pair_nodes) {
5857 mp->pair_nodes = p->link;
5858 mp->num_pair_nodes--;
5861 p = malloc_node (pair_node_size);
5863 mp_type (p) = mp_pair_node_type;
5864 FUNCTION_TRACE2("get_pair_node
(): %p\n
", p);
5869 void mp_free_pair_node (MP mp, mp_node p);
5872 void mp_free_pair_node (MP mp, mp_node p) {
5873 FUNCTION_TRACE2 ("mp_free_pair_node
(%p
)\n
", p);
5875 if (mp->num_pair_nodes < max_num_pair_nodes) {
5876 p->link = mp->pair_nodes;
5878 mp->num_pair_nodes++;
5881 mp->var_used -= pair_node_size;
5886 @ If |type(p)=mp_pair_type| or if |value(p)=NULL|, the procedure call |init_pair_node(p)| will
5887 allocate a pair node for~|p|. The individual parts of such nodes are initially of type
5891 static void mp_init_pair_node (MP mp, mp_node p) {
5892 mp_node q; /* the new node */
5893 mp_type (p) = mp_pair_type;
5894 q = mp_get_pair_node (mp);
5895 y_part (q) = mp_get_value_node (mp);
5896 mp_new_indep (mp, y_part (q)); /* sets |type(q)| and |value(q)| */
5897 mp_name_type (y_part (q)) = (quarterword) (mp_y_part_sector);
5898 mp_link (y_part (q)) = p;
5899 x_part (q) = mp_get_value_node (mp);
5900 mp_new_indep (mp, x_part (q)); /* sets |type(q)| and |value(q)| */
5901 mp_name_type (x_part (q)) = (quarterword) (mp_x_part_sector);
5902 mp_link (x_part (q)) = p;
5903 set_value_node (p, q);
5908 Variables of type \&{transform} are similar, but in this case their
5909 |value| points to a 12-word node containing six values, identified by
5910 |x_part_sector|, |y_part_sector|, |mp_xx_part_sector|, |mp_xy_part_sector|,
5911 |mp_yx_part_sector|, and |mp_yy_part_sector|.
5913 @d tx_part(A) ((mp_transform_node)(A))->tx_part_ /* where the \&{xpart} is found in a transform node */
5914 @d ty_part(A) ((mp_transform_node)(A))->ty_part_ /* where the \&{ypart} is found in a transform node */
5915 @d xx_part(A) ((mp_transform_node)(A))->xx_part_ /* where the \&{xxpart} is found in a transform node */
5916 @d xy_part(A) ((mp_transform_node)(A))->xy_part_ /* where the \&{xypart} is found in a transform node */
5917 @d yx_part(A) ((mp_transform_node)(A))->yx_part_ /* where the \&{yxpart} is found in a transform node */
5918 @d yy_part(A) ((mp_transform_node)(A))->yy_part_ /* where the \&{yypart} is found in a transform node */
5920 @<MPlib internal header stuff@>=
5921 typedef struct mp_transform_node_data {
5929 } mp_transform_node_data;
5930 typedef struct mp_transform_node_data *mp_transform_node;
5933 @d transform_node_size sizeof(struct mp_transform_node_data) /* the number of words in a subscript node */
5936 static mp_node mp_get_transform_node (MP mp) {
5937 mp_transform_node p = (mp_transform_node) malloc_node (transform_node_size);
5938 mp_type (p) = mp_transform_node_type;
5944 static void mp_init_transform_node (MP mp, mp_node p) {
5945 mp_node q; /* the new node */
5946 mp_type (p) = mp_transform_type;
5947 q = mp_get_transform_node (mp); /* big node */
5948 yy_part (q) = mp_get_value_node (mp);
5949 mp_new_indep (mp, yy_part (q)); /* sets |type(q)| and |value(q)| */
5950 mp_name_type (yy_part (q)) = (quarterword) (mp_yy_part_sector);
5951 mp_link (yy_part (q)) = p;
5952 yx_part (q) = mp_get_value_node (mp);
5953 mp_new_indep (mp, yx_part (q)); /* sets |type(q)| and |value(q)| */
5954 mp_name_type (yx_part (q)) = (quarterword) (mp_yx_part_sector);
5955 mp_link (yx_part (q)) = p;
5956 xy_part (q) = mp_get_value_node (mp);
5957 mp_new_indep (mp, xy_part (q)); /* sets |type(q)| and |value(q)| */
5958 mp_name_type (xy_part (q)) = (quarterword) (mp_xy_part_sector);
5959 mp_link (xy_part (q)) = p;
5960 xx_part (q) = mp_get_value_node (mp);
5961 mp_new_indep (mp, xx_part (q)); /* sets |type(q)| and |value(q)| */
5962 mp_name_type (xx_part (q)) = (quarterword) (mp_xx_part_sector);
5963 mp_link (xx_part (q)) = p;
5964 ty_part (q) = mp_get_value_node (mp);
5965 mp_new_indep (mp, ty_part (q)); /* sets |type(q)| and |value(q)| */
5966 mp_name_type (ty_part (q)) = (quarterword) (mp_y_part_sector);
5967 mp_link (ty_part (q)) = p;
5968 tx_part (q) = mp_get_value_node (mp);
5969 mp_new_indep (mp, tx_part (q)); /* sets |type(q)| and |value(q)| */
5970 mp_name_type (tx_part (q)) = (quarterword) (mp_x_part_sector);
5971 mp_link (tx_part (q)) = p;
5972 set_value_node (p, q);
5977 Variables of type \&{color} have 3~values in 6~words identified by |mp_red_part_sector|,
5978 |mp_green_part_sector|, and |mp_blue_part_sector|.
5980 @d red_part(A) ((mp_color_node)(A))->red_part_ /* where the \&{redpart} is found in a color node */
5981 @d green_part(A) ((mp_color_node)(A))->green_part_ /* where the \&{greenpart} is found in a color node */
5982 @d blue_part(A) ((mp_color_node)(A))->blue_part_ /* where the \&{bluepart} is found in a color node */
5984 @d grey_part(A) red_part(A) /* where the \&{greypart} is found in a color node */
5986 @<MPlib internal header stuff@>=
5987 typedef struct mp_color_node_data {
5990 mp_node green_part_;
5992 } mp_color_node_data;
5993 typedef struct mp_color_node_data *mp_color_node;
5996 @d color_node_size sizeof(struct mp_color_node_data) /* the number of words in a subscript node */
5999 static mp_node mp_get_color_node (MP mp) {
6000 mp_color_node p = (mp_color_node) malloc_node (color_node_size);
6001 mp_type (p) = mp_color_node_type;
6009 static void mp_init_color_node (MP mp, mp_node p) {
6010 mp_node q; /* the new node */
6011 mp_type (p) = mp_color_type;
6012 q = mp_get_color_node (mp); /* big node */
6013 blue_part (q) = mp_get_value_node (mp);
6014 mp_new_indep (mp, blue_part (q)); /* sets |type(q)| and |value(q)| */
6015 mp_name_type (blue_part (q)) = (quarterword) (mp_blue_part_sector);
6016 mp_link (blue_part (q)) = p;
6017 green_part (q) = mp_get_value_node (mp);
6018 mp_new_indep (mp, green_part (q)); /* sets |type(q)| and |value(q)| */
6019 mp_name_type (y_part (q)) = (quarterword) (mp_green_part_sector);
6020 mp_link (green_part (q)) = p;
6021 red_part (q) = mp_get_value_node (mp);
6022 mp_new_indep (mp, red_part (q)); /* sets |type(q)| and |value(q)| */
6023 mp_name_type (red_part (q)) = (quarterword) (mp_red_part_sector);
6024 mp_link (red_part (q)) = p;
6025 set_value_node (p, q);
6029 @ Finally, variables of type |cmykcolor|.
6031 @d cyan_part(A) ((mp_cmykcolor_node)(A))->cyan_part_ /* where the \&{cyanpart} is found in a color node */
6032 @d magenta_part(A) ((mp_cmykcolor_node)(A))->magenta_part_ /* where the \&{magentapart} is found in a color node */
6033 @d yellow_part(A) ((mp_cmykcolor_node)(A))->yellow_part_ /* where the \&{yellowpart} is found in a color node */
6034 @d black_part(A) ((mp_cmykcolor_node)(A))->black_part_ /* where the \&{blackpart} is found in a color node */
6036 @<MPlib internal header stuff@>=
6037 typedef struct mp_cmykcolor_node_data {
6040 mp_node magenta_part_;
6041 mp_node yellow_part_;
6042 mp_node black_part_;
6043 } mp_cmykcolor_node_data;
6044 typedef struct mp_cmykcolor_node_data *mp_cmykcolor_node;
6047 @d cmykcolor_node_size sizeof(struct mp_cmykcolor_node_data) /* the number of words in a subscript node */
6050 static mp_node mp_get_cmykcolor_node (MP mp) {
6051 mp_cmykcolor_node p = (mp_cmykcolor_node) malloc_node (cmykcolor_node_size);
6052 mp_type (p) = mp_cmykcolor_node_type;
6060 static void mp_init_cmykcolor_node (MP mp, mp_node p) {
6061 mp_node q; /* the new node */
6062 mp_type (p) = mp_cmykcolor_type;
6063 q = mp_get_cmykcolor_node (mp); /* big node */
6064 black_part (q) = mp_get_value_node (mp);
6065 mp_new_indep (mp, black_part (q)); /* sets |type(q)| and |value(q)| */
6066 mp_name_type (black_part (q)) = (quarterword) (mp_black_part_sector);
6067 mp_link (black_part (q)) = p;
6068 yellow_part (q) = mp_get_value_node (mp);
6069 mp_new_indep (mp, yellow_part (q)); /* sets |type(q)| and |value(q)| */
6070 mp_name_type (yellow_part (q)) = (quarterword) (mp_yellow_part_sector);
6071 mp_link (yellow_part (q)) = p;
6072 magenta_part (q) = mp_get_value_node (mp);
6073 mp_new_indep (mp, magenta_part (q)); /* sets |type(q)| and |value(q)| */
6074 mp_name_type (magenta_part (q)) = (quarterword) (mp_magenta_part_sector);
6075 mp_link (magenta_part (q)) = p;
6076 cyan_part (q) = mp_get_value_node (mp);
6077 mp_new_indep (mp, cyan_part (q)); /* sets |type(q)| and |value(q)| */
6078 mp_name_type (cyan_part (q)) = (quarterword) (mp_cyan_part_sector);
6079 mp_link (cyan_part (q)) = p;
6080 set_value_node (p, q);
6084 @ When an entire structured variable is saved, the |root| indication
6085 is temporarily replaced by |saved_root|.
6087 Some variables have no name; they just are used for temporary storage
6088 while expressions are being evaluated. We call them {\sl capsules}.
6090 @ The |id_transform| function creates a capsule for the
6091 identity transformation.
6094 static mp_node mp_id_transform (MP mp) {
6095 mp_node p, q; /* list manipulation registers */
6096 p = mp_get_value_node (mp);
6097 mp_name_type (p) = mp_capsule;
6098 set_value_number (p, zero_t); /* todo: this was |null| */
6099 mp_init_transform_node (mp, p);
6101 mp_type (tx_part (q)) = mp_known;
6102 set_value_number (tx_part (q), zero_t);
6103 mp_type (ty_part (q)) = mp_known;
6104 set_value_number (ty_part (q), zero_t);
6105 mp_type (xy_part (q)) = mp_known;
6106 set_value_number (xy_part (q), zero_t);
6107 mp_type (yx_part (q)) = mp_known;
6108 set_value_number (yx_part (q), zero_t);
6109 mp_type (xx_part (q)) = mp_known;
6110 set_value_number (xx_part (q), unity_t);
6111 mp_type (yy_part (q)) = mp_known;
6112 set_value_number (yy_part (q), unity_t);
6117 @ Tokens are of type |tag_token| when they first appear, but they point
6118 to |NULL| until they are first used as the root of a variable.
6119 The following subroutine establishes the root node on such grand occasions.
6122 static void mp_new_root (MP mp, mp_sym x) {
6123 mp_node p; /* the new node */
6124 p = mp_get_value_node (mp);
6125 mp_type (p) = mp_undefined;
6126 mp_name_type (p) = mp_root;
6127 set_value_sym (p, x);
6128 set_equiv_node (x, p);
6132 @ These conventions for variable representation are illustrated by the
6133 |print_variable_name| routine, which displays the full name of a
6134 variable given only a pointer to its value.
6137 static void mp_print_variable_name (MP mp, mp_node p);
6140 void mp_print_variable_name (MP mp, mp_node p) {
6141 mp_node q; /* a token list that will name the variable's suffix */
6142 mp_node r; /* temporary for token list creation */
6143 while (mp_name_type (p) >= mp_x_part_sector) {
6144 switch (mp_name_type (p)) {
6145 case mp_x_part_sector: mp_print (mp, "xpart
"); break;
6146 case mp_y_part_sector: mp_print (mp, "ypart
"); break;
6147 case mp_xx_part_sector: mp_print (mp, "xxpart
"); break;
6148 case mp_xy_part_sector: mp_print (mp, "xypart
"); break;
6149 case mp_yx_part_sector: mp_print (mp, "yxpart
"); break;
6150 case mp_yy_part_sector: mp_print (mp, "yypart
"); break;
6151 case mp_red_part_sector: mp_print (mp, "redpart
"); break;
6152 case mp_green_part_sector: mp_print (mp, "greenpart
"); break;
6153 case mp_blue_part_sector: mp_print (mp, "bluepart
"); break;
6154 case mp_cyan_part_sector: mp_print (mp, "cyanpart
"); break;
6155 case mp_magenta_part_sector:mp_print (mp, "magentapart
");break;
6156 case mp_yellow_part_sector: mp_print (mp, "yellowpart
"); break;
6157 case mp_black_part_sector: mp_print (mp, "blackpart
"); break;
6158 case mp_grey_part_sector: mp_print (mp, "greypart
"); break;
6159 case mp_capsule: mp_printf (mp, "%%CAPSULE
%p
",p); return; break;
6160 /* this is to please the compiler: the remaining cases are operation codes */
6166 while (mp_name_type (p) > mp_saved_root) {
6167 /* Ascend one level, pushing a token onto list |q|
6168 and replacing |p| by its parent */
6169 if (mp_name_type (p) == mp_subscr) {
6170 r = mp_new_num_tok (mp, subscript (p));
6173 } while (mp_name_type (p) != mp_attr);
6174 } else if (mp_name_type (p) == mp_structured_root) {
6178 if (mp_name_type (p) != mp_attr)
6179 mp_confusion (mp, "var
");
6180 r = mp_get_symbolic_node (mp);
6181 set_mp_sym_sym (r, hashloc (p)); /* the hash address */
6186 p = parent ((mp_value_node) p);
6189 /* now |link(p)| is the hash address of |p|, and
6190 |name_type(p)| is either |root| or |saved_root|.
6191 Have to prepend a token to |q| for |show_token_list|. */
6192 r = mp_get_symbolic_node (mp);
6193 set_mp_sym_sym (r, value_sym (p));
6195 if (mp_name_type (p) == mp_saved_root)
6196 mp_print (mp, "(SAVED
)");
6197 mp_show_token_list (mp, r, NULL, max_integer, mp->tally);
6198 mp_flush_token_list (mp, r);
6201 @ The |interesting| function returns |true| if a given variable is not
6202 in a capsule, or if the user wants to trace capsules.
6205 static boolean mp_interesting (MP mp, mp_node p) {
6206 mp_name_type_type t; /* a |name_type| */
6207 if (number_positive(internal_value (mp_tracing_capsules))) {
6210 t = mp_name_type (p);
6211 if (t >= mp_x_part_sector && t != mp_capsule) {
6212 mp_node tt = value_node(mp_link(p));
6214 case mp_x_part_sector:
6215 t = mp_name_type (x_part (tt));
6217 case mp_y_part_sector:
6218 t = mp_name_type (y_part (tt));
6220 case mp_xx_part_sector:
6221 t = mp_name_type (xx_part (tt));
6223 case mp_xy_part_sector:
6224 t = mp_name_type (xy_part (tt));
6226 case mp_yx_part_sector:
6227 t = mp_name_type (yx_part (tt));
6229 case mp_yy_part_sector:
6230 t = mp_name_type (yy_part (tt));
6232 case mp_red_part_sector:
6233 t = mp_name_type (red_part (tt));
6235 case mp_green_part_sector:
6236 t = mp_name_type (green_part (tt));
6238 case mp_blue_part_sector:
6239 t = mp_name_type (blue_part (tt));
6241 case mp_cyan_part_sector:
6242 t = mp_name_type (cyan_part (tt));
6244 case mp_magenta_part_sector:
6245 t = mp_name_type (magenta_part (tt));
6247 case mp_yellow_part_sector:
6248 t = mp_name_type (yellow_part (tt));
6250 case mp_black_part_sector:
6251 t = mp_name_type (black_part (tt));
6253 case mp_grey_part_sector:
6254 t = mp_name_type (grey_part (tt));
6261 return (t != mp_capsule);
6265 @ Now here is a subroutine that converts an unstructured type into an
6266 equivalent structured type, by inserting a |mp_structured| node that is
6267 capable of growing. This operation is done only when |mp_name_type(p)=root|,
6268 |subscr|, or |attr|.
6270 The procedure returns a pointer to the new node that has taken node~|p|'s
6271 place in the structure. Node~|p| itself does not move, nor are its
6272 |value| or |type| fields changed in any way.
6275 static mp_node mp_new_structure (MP mp, mp_node p) {
6276 mp_node q, r = NULL; /* list manipulation registers */
6278 switch (mp_name_type (p)) {
6282 r = mp_get_value_node (mp);
6283 set_equiv_node (qq, r);
6287 /* Link a new subscript node |r| in place of node |p| */
6293 } while (mp_name_type (q) != mp_attr);
6294 q = parent ((mp_value_node) q);
6296 set_mp_link (r, subscr_head (q));
6301 r = (mp_node) mp_get_subscr_node (mp);
6302 if (q_new == mp->temp_head) {
6303 set_subscr_head (q, r);
6305 set_mp_link (q_new, r);
6307 set_subscript (r, subscript (p));
6312 /* Link a new attribute node |r| in place of node |p| */
6313 /* If the attribute is |collective_subscript|, there are two pointers to
6314 node~|p|, so we must change both of them. */
6317 q = parent ((mp_value_node) p);
6323 rr = mp_get_attr_node (mp);
6325 set_mp_link (q, (mp_node) rr);
6326 set_hashloc (rr, hashloc (p));
6327 set_parent (rr, parent ((mp_value_node) p));
6328 if (hashloc (p) == collective_subscript) {
6330 set_mp_link (q, subscr_head (parent ((mp_value_node) p)));
6331 while (mp_link (q) != p)
6333 if (q == mp->temp_head)
6334 set_subscr_head (parent ((mp_value_node) p), (mp_node) rr);
6336 set_mp_link (q, (mp_node) rr);
6342 mp_confusion (mp, "struct
");
6345 set_mp_link (r, mp_link (p));
6346 set_value_sym (r, value_sym (p));
6347 mp_type (r) = mp_structured;
6348 mp_name_type (r) = mp_name_type (p);
6349 set_attr_head (r, p);
6350 mp_name_type (p) = mp_structured_root;
6352 mp_value_node qqr = mp_get_attr_node (mp);
6353 set_mp_link (p, (mp_node) qqr);
6354 set_subscr_head (r, (mp_node) qqr);
6355 set_parent (qqr, r);
6356 mp_type (qqr) = mp_undefined;
6357 mp_name_type (qqr) = mp_attr;
6358 set_mp_link (qqr, mp->end_attr);
6359 set_hashloc (qqr, collective_subscript);
6364 @ The |find_variable| routine is given a pointer~|t| to a nonempty token
6365 list of suffixes; it returns a pointer to the corresponding non-symbolic
6366 value. For example, if |t| points to token \.x followed by a numeric
6367 token containing the value~7, |find_variable| finds where the value of
6368 \.{x7} is stored in memory. This may seem a simple task, and it
6369 usually is, except when \.{x7} has never been referenced before.
6370 Indeed, \.x may never have even been subscripted before; complexities
6371 arise with respect to updating the collective subscript information.
6373 If a macro type is detected anywhere along path~|t|, or if the first
6374 item on |t| isn't a |tag_token|, the value |NULL| is returned.
6375 Otherwise |p| will be a non-NULL pointer to a node such that
6376 |undefined<type(p)<mp_structured|.
6379 static mp_node mp_find_variable (MP mp, mp_node t) {
6380 mp_node p, q, r, s; /* nodes in the ``value'' line */
6382 mp_node pp, qq, rr, ss; /* nodes in the ``collective'' line */
6384 p_sym = mp_sym_sym (t);
6386 if ((eq_type (p_sym) % mp_outer_tag) != mp_tag_token)
6388 if (equiv_node (p_sym) == NULL)
6389 mp_new_root (mp, p_sym);
6390 p = equiv_node (p_sym);
6393 /* Make sure that both nodes |p| and |pp| are of |mp_structured| type */
6394 /* Although |pp| and |p| begin together, they diverge when a subscript occurs;
6395 |pp|~stays in the collective line while |p|~goes through actual subscript
6397 if (mp_type (pp) != mp_structured) {
6398 if (mp_type (pp) > mp_structured)
6400 ss = mp_new_structure (mp, pp);
6404 } /* now |type(pp)=mp_structured| */
6405 if (mp_type (p) != mp_structured) { /* it cannot be |>mp_structured| */
6406 p = mp_new_structure (mp, p); /* now |type(p)=mp_structured| */
6409 if (mp_type (t) != mp_symbol_node) {
6410 /* Descend one level for the subscript |value(t)| */
6411 /* We want this part of the program to be reasonably fast, in case there are
6412 lots of subscripts at the same level of the data structure. Therefore
6413 we store an ``infinite'' value in the word that appears at the end of the
6414 subscript list, even though that word isn't part of a subscript node. */
6415 mp_number nn, save_subscript; /* temporary storage */
6417 new_number (save_subscript);
6418 number_clone (nn, value_number (t));
6419 pp = mp_link (attr_head (pp)); /* now |hashloc(pp)=collective_subscript| */
6420 q = mp_link (attr_head (p));
6421 number_clone (save_subscript, subscript (q));
6422 set_number_to_inf(subscript (q));
6424 set_mp_link (s, subscr_head (p));
6428 } while (number_greater (nn, subscript (s)));
6429 if (number_equal(nn, subscript (s))) {
6432 mp_value_node p1 = mp_get_subscr_node (mp);
6433 if (r == mp->temp_head)
6434 set_subscr_head (p, (mp_node) p1);
6436 set_mp_link (r, (mp_node) p1);
6437 set_mp_link (p1, s);
6438 number_clone (subscript (p1), nn);
6439 mp_name_type (p1) = mp_subscr;
6440 mp_type (p1) = mp_undefined;
6443 number_clone (subscript (q), save_subscript);
6444 free_number (save_subscript);
6447 /* Descend one level for the attribute |mp_sym_info(t)| */
6448 mp_sym nn1 = mp_sym_sym (t);
6449 ss = attr_head (pp);
6453 } while (nn1 > hashloc (ss));
6454 if (nn1 < hashloc (ss)) {
6455 qq = (mp_node) mp_get_attr_node (mp);
6456 set_mp_link (rr, qq);
6457 set_mp_link (qq, ss);
6458 set_hashloc (qq, nn1);
6459 mp_name_type (qq) = mp_attr;
6460 mp_type (qq) = mp_undefined;
6461 set_parent ((mp_value_node) qq, pp);
6473 } while (nn1 > hashloc (s));
6474 if (nn1 == hashloc (s)) {
6477 q = (mp_node) mp_get_attr_node (mp);
6480 set_hashloc (q, nn1);
6481 mp_name_type (q) = mp_attr;
6482 mp_type (q) = mp_undefined;
6483 set_parent ((mp_value_node) q, p);
6490 if (mp_type (pp) >= mp_structured) {
6491 if (mp_type (pp) == mp_structured)
6492 pp = attr_head (pp);
6496 if (mp_type (p) == mp_structured)
6498 if (mp_type (p) == mp_undefined) {
6499 if (mp_type (pp) == mp_undefined) {
6500 mp_type (pp) = mp_numeric_type;
6501 set_value_number (pp, zero_t);
6503 mp_type (p) = mp_type (pp);
6504 set_value_number (p, zero_t);
6510 @ Variables lose their former values when they appear in a type declaration,
6511 or when they are defined to be macros or \&{let} equal to something else.
6512 A subroutine will be defined later that recycles the storage associated
6513 with any particular |type| or |value|; our goal now is to study a higher
6514 level process called |flush_variable|, which selectively frees parts of a
6517 This routine has some complexity because of examples such as
6518 `\hbox{\tt numeric x[]a[]b}'
6519 which recycles all variables of the form \.{x[i]a[j]b} (and no others), while
6520 `\hbox{\tt vardef x[]a[]=...}'
6521 discards all variables of the form \.{x[i]a[j]} followed by an arbitrary
6522 suffix, except for the collective node \.{x[]a[]} itself. The obvious way
6523 to handle such examples is to use recursion; so that's what we~do.
6526 Parameter |p| points to the root information of the variable;
6527 parameter |t| points to a list of symbolic nodes that represent
6528 suffixes, with |info=collective_subscript| for subscripts.
6531 void mp_flush_cur_exp (MP mp, mp_value v);
6534 static void mp_flush_variable (MP mp, mp_node p, mp_node t,
6535 boolean discard_suffixes) {
6536 mp_node q, r = NULL; /* list manipulation */
6537 mp_sym n; /* attribute to match */
6539 if (mp_type (p) != mp_structured) {
6544 if (n == collective_subscript) {
6545 q = subscr_head (p);
6546 while (mp_name_type (q) == mp_subscr) {
6547 mp_flush_variable (mp, q, t, discard_suffixes);
6549 if (mp_type (q) == mp_structured) {
6553 set_subscr_head (p, mp_link (q));
6555 set_mp_link (r, mp_link (q));
6556 mp_free_value_node (mp, q);
6561 q = (r==NULL ? subscr_head (p) : mp_link (r));
6567 } while (hashloc (p) < n);
6568 if (hashloc (p) != n) {
6572 if (discard_suffixes) {
6573 mp_flush_below_variable (mp, p);
6575 if (mp_type (p) == mp_structured) {
6578 mp_recycle_value (mp, p);
6583 @ The next procedure is simpler; it wipes out everything but |p| itself,
6584 which becomes undefined.
6587 static void mp_flush_below_variable (MP mp, mp_node p);
6590 void mp_flush_below_variable (MP mp, mp_node p) {
6591 mp_node q, r; /* list manipulation registers */
6592 FUNCTION_TRACE2 ("mp_flush_below_variable
(%p
)\n
", p);
6593 if (mp_type (p) != mp_structured) {
6594 mp_recycle_value (mp, p); /* this sets |type(p)=undefined| */
6596 q = subscr_head (p);
6597 while (mp_name_type (q) == mp_subscr) {
6598 mp_flush_below_variable (mp, q);
6601 mp_free_value_node (mp, r);
6605 mp_recycle_value (mp, r);
6606 mp_free_value_node (mp, r);
6608 mp_flush_below_variable (mp, q);
6611 mp_free_value_node (mp, r);
6612 } while (q != mp->end_attr);
6613 mp_type (p) = mp_undefined;
6618 @ Just before assigning a new value to a variable, we will recycle the
6619 old value and make the old value undefined. The |und_type| routine
6620 determines what type of undefined value should be given, based on
6621 the current type before recycling.
6624 static quarterword mp_und_type (MP mp, mp_node p) {
6626 switch (mp_type (p)) {
6628 return mp_undefined;
6629 case mp_boolean_type:
6630 case mp_unknown_boolean:
6631 return mp_unknown_boolean;
6632 case mp_string_type:
6633 case mp_unknown_string:
6634 return mp_unknown_string;
6636 case mp_unknown_pen:
6637 return mp_unknown_pen;
6639 case mp_unknown_path:
6640 return mp_unknown_path;
6641 case mp_picture_type:
6642 case mp_unknown_picture:
6643 return mp_unknown_picture;
6644 case mp_transform_type:
6646 case mp_cmykcolor_type:
6648 case mp_numeric_type:
6652 case mp_proto_dependent:
6653 case mp_independent:
6654 return mp_numeric_type;
6655 default: /* there are no other valid cases, but please the compiler */
6662 @ The |clear_symbol| routine is used when we want to redefine the equivalent
6663 of a symbolic token. It must remove any variable structure or macro
6664 definition that is currently attached to that symbol. If the |saving|
6665 parameter is true, a subsidiary structure is saved instead of destroyed.
6668 static void mp_clear_symbol (MP mp, mp_sym p, boolean saving) {
6669 mp_node q; /* |equiv(p)| */
6670 FUNCTION_TRACE3 ("mp_clear_symbol
(%p
,%d
)\n
", p, saving);
6672 switch (eq_type (p) % mp_outer_tag) {
6673 case mp_defined_macro:
6674 case mp_secondary_primary_macro:
6675 case mp_tertiary_secondary_macro:
6676 case mp_expression_tertiary_macro:
6678 mp_delete_mac_ref (mp, q);
6683 mp_name_type (q) = mp_saved_root;
6685 mp_flush_below_variable (mp, q);
6686 mp_free_value_node (mp, q);
6693 set_equiv (p, mp->frozen_undefined->v.data.indep.serial);
6694 set_eq_type (p, mp->frozen_undefined->type);
6698 @* Saving and restoring equivalents.
6699 The nested structure given by \&{begingroup} and \&{endgroup}
6700 allows |eqtb| entries to be saved and restored, so that temporary changes
6701 can be made without difficulty. When the user requests a current value to
6702 be saved, \MP\ puts that value into its ``save stack.'' An appearance of
6703 \&{endgroup} ultimately causes the old values to be removed from the save
6704 stack and put back in their former places.
6706 The save stack is a linked list containing three kinds of entries,
6707 distinguished by their |type| fields. If |p| points to a saved item,
6711 |p->type=0| stands for a group boundary; each \&{begingroup} contributes
6712 such an item to the save stack and each \&{endgroup} cuts back the stack
6713 until the most recent such entry has been removed.
6716 |p->type=mp_normal_sym| means that |p->value| holds the former
6717 contents of |eqtb[q]| (saved in the |knot| field of the value, which
6718 is otherwise unused for variables). Such save stack entries are generated by \&{save}
6722 |p->type=mp_internal_sym| means that |p->value| is a |mp_internal|
6723 to be restored to internal parameter number~|q| (saved in the |serial| field of the value, which
6724 is otherwise unused for internals). Such entries are generated by \&{interim} commands.
6727 The global variable |save_ptr| points to the top item on the save stack.
6730 typedef struct mp_save_data {
6733 struct mp_save_data *link;
6737 mp_save_data *save_ptr; /* the most recently saved item */
6740 mp->save_ptr = NULL;
6742 @ Saving a boundary item
6744 static void mp_save_boundary (MP mp) {
6745 mp_save_data *p; /* temporary register */
6746 FUNCTION_TRACE1 ("mp_save_boundary
()\n
");
6747 p = xmalloc (1, sizeof (mp_save_data));
6749 p->link = mp->save_ptr;
6754 @ The |save_variable| routine is given a hash address |q|; it salts this
6755 address in the save stack, together with its current equivalent,
6756 then makes token~|q| behave as though it were brand new.
6758 Nothing is stacked when |save_ptr=NULL|, however; there's no way to remove
6759 things from the stack when the program is not inside a group, so there's
6760 no point in wasting the space.
6763 static void mp_save_variable (MP mp, mp_sym q) {
6764 mp_save_data *p; /* temporary register */
6765 FUNCTION_TRACE2 ("mp_save_variable
(%p
)\n
", q);
6766 if (mp->save_ptr != NULL) {
6767 p = xmalloc (1, sizeof (mp_save_data));
6768 p->type = mp_normal_sym;
6769 p->link = mp->save_ptr;
6770 p->value.v.data.indep.scale = eq_type (q);
6771 p->value.v.data.indep.serial = equiv(q);
6772 p->value.v.data.node = equiv_node(q);
6773 p->value.v.data.p = (mp_knot)q;
6776 mp_clear_symbol (mp, q, (mp->save_ptr != NULL));
6778 static void mp_unsave_variable (MP mp) {
6779 mp_sym q = (mp_sym)mp->save_ptr->value.v.data.p;
6780 if (number_positive(internal_value (mp_tracing_restores))) {
6781 mp_begin_diagnostic (mp);
6782 mp_print_nl (mp, "{restoring
");
6784 mp_print_char (mp, xord ('}'));
6785 mp_end_diagnostic (mp, false);
6787 mp_clear_symbol (mp, q, false);
6788 set_eq_type(q, mp->save_ptr->value.v.data.indep.scale);
6789 set_equiv (q,mp->save_ptr->value.v.data.indep.serial);
6790 q->v.data.node = mp->save_ptr->value.v.data.node;
6791 if (eq_type (q) % mp_outer_tag == mp_tag_token) {
6792 mp_node pp = q->v.data.node;
6794 mp_name_type (pp) = mp_root;
6798 @ Similarly, |save_internal| is given the location |q| of an internal
6799 quantity like |mp_tracing_pens|. It creates a save stack entry of the
6803 static void mp_save_internal (MP mp, halfword q) {
6804 mp_save_data *p; /* new item for the save stack */
6805 FUNCTION_TRACE2 ("mp_save_internal
(%d
)\n
", q);
6806 if (mp->save_ptr != NULL) {
6807 p = xmalloc (1, sizeof (mp_save_data));
6808 p->type = mp_internal_sym;
6809 p->link = mp->save_ptr;
6810 p->value = mp->internal[q];
6811 p->value.v.data.indep.serial = q;
6812 new_number(p->value.v.data.n);
6813 number_clone(p->value.v.data.n, mp->internal[q].v.data.n);
6818 static void mp_unsave_internal (MP mp) {
6819 halfword q = mp->save_ptr->value.v.data.indep.serial;
6820 mp_internal saved = mp->save_ptr->value;
6821 if (number_positive(internal_value (mp_tracing_restores))) {
6822 mp_begin_diagnostic (mp);
6823 mp_print_nl (mp, "{restoring
");
6824 mp_print (mp, internal_name (q));
6825 mp_print_char (mp, xord ('='));
6826 if (internal_type (q) == mp_known) {
6827 print_number (saved.v.data.n);
6828 } else if (internal_type (q) == mp_string_type) {
6829 char *s = mp_str (mp, saved.v.data.str);
6832 mp_confusion (mp, "internal_restore
");
6834 mp_print_char (mp, xord ('}'));
6835 mp_end_diagnostic (mp, false);
6837 free_number (mp->internal[q].v.data.n);
6838 mp->internal[q] = saved;
6841 @ At the end of a group, the |unsave| routine restores all of the saved
6842 equivalents in reverse order. This routine will be called only when there
6843 is at least one boundary item on the save stack.
6846 static void mp_unsave (MP mp) {
6847 mp_save_data *p; /* saved item */
6848 FUNCTION_TRACE1 ("mp_unsave
()\n
");
6849 while (mp->save_ptr->type != 0) {
6850 if (mp->save_ptr->type == mp_internal_sym) {
6851 mp_unsave_internal(mp);
6853 mp_unsave_variable(mp);
6855 p = mp->save_ptr->link;
6856 xfree (mp->save_ptr);
6859 p = mp->save_ptr->link;
6860 xfree (mp->save_ptr);
6865 @* Data structures for paths.
6866 When a \MP\ user specifies a path, \MP\ will create a list of knots
6867 and control points for the associated cubic spline curves. If the
6868 knots are $z_0$, $z_1$, \dots, $z_n$, there are control points
6869 $z_k^+$ and $z_{k+1}^-$ such that the cubic splines between knots
6870 $z_k$ and $z_{k+1}$ are defined by B\'ezier's formula
6871 @:Bezier}{B\'ezier, Pierre Etienne@>
6872 $$\eqalign{z(t)&=B(z_k,z_k^+,z_{k+1}^-,z_{k+1};t)\cr
6873 &=(1-t)^3z_k+3(1-t)^2tz_k^++3(1-t)t^2z_{k+1}^-+t^3z_{k+1}\cr}$$
6876 There is a 8-word node for each knot $z_k$, containing one word of
6877 control information and six words for the |x| and |y| coordinates of
6878 $z_k^-$ and $z_k$ and~$z_k^+$. The control information appears in the
6879 |mp_left_type| and |mp_right_type| fields, which each occupy a quarter of
6880 the first word in the node; they specify properties of the curve as it
6881 enters and leaves the knot. There's also a halfword |link| field,
6882 which points to the following knot, and a final supplementary word (of
6883 which only a quarter is used).
6885 If the path is a closed contour, knots 0 and |n| are identical;
6886 i.e., the |link| in knot |n-1| points to knot~0. But if the path
6887 is not closed, the |mp_left_type| of knot~0 and the |mp_right_type| of knot~|n|
6888 are equal to |endpoint|. In the latter case the |link| in knot~|n| points
6889 to knot~0, and the control points $z_0^-$ and $z_n^+$ are not used.
6891 @d mp_next_knot(A) (A)->next /* the next knot in this list */
6892 @d mp_left_type(A) (A)->data.types.left_type /* characterizes the path entering this knot */
6893 @d mp_right_type(A) (A)->data.types.right_type /* characterizes the path leaving this knot */
6894 @d mp_prev_knot(A) (A)->data.prev /* the previous knot in this list (only for pens) */
6895 @d mp_knot_info(A) (A)->data.info /* temporary info, used during splitting */
6897 @<Exported types...@>=
6898 typedef struct mp_knot_data *mp_knot;
6899 typedef struct mp_knot_data {
6900 mp_number x_coord; /* the |x| coordinate of this knot */
6901 mp_number y_coord; /* the |y| coordinate of this knot */
6902 mp_number left_x; /* the |x| coordinate of previous control point */
6903 mp_number left_y; /* the |y| coordinate of previous control point */
6904 mp_number right_x; /* the |x| coordinate of next control point */
6905 mp_number right_y; /* the |y| coordinate of next control point */
6909 unsigned short left_type;
6910 unsigned short right_type;
6915 unsigned char originator;
6920 @d mp_gr_next_knot(A) (A)->next /* the next knot in this list */
6922 @<Exported types...@>=
6923 typedef struct mp_gr_knot_data *mp_gr_knot;
6924 typedef struct mp_gr_knot_data {
6934 unsigned short left_type;
6935 unsigned short right_type;
6940 unsigned char originator;
6944 @ @<MPlib header stuff@>=
6946 mp_endpoint = 0, /* |mp_left_type| at path beginning and |mp_right_type| at path end */
6947 mp_explicit, /* |mp_left_type| or |mp_right_type| when control points are known */
6948 mp_given, /* |mp_left_type| or |mp_right_type| when a direction is given */
6949 mp_curl, /* |mp_left_type| or |mp_right_type| when a curl is desired */
6950 mp_open, /* |mp_left_type| or |mp_right_type| when \MP\ should choose the direction */
6954 @ Before the B\'ezier control points have been calculated, the memory
6955 space they will ultimately occupy is taken up by information that can be
6956 used to compute them. There are four cases:
6959 \textindent{$\bullet$} If |mp_right_type=mp_open|, the curve should leave
6960 the knot in the same direction it entered; \MP\ will figure out a
6964 \textindent{$\bullet$} If |mp_right_type=mp_curl|, the curve should leave the
6965 knot in a direction depending on the angle at which it enters the next
6966 knot and on the curl parameter stored in |right_curl|.
6969 \textindent{$\bullet$} If |mp_right_type=mp_given|, the curve should leave the
6970 knot in a nonzero direction stored as an |angle| in |right_given|.
6973 \textindent{$\bullet$} If |mp_right_type=mp_explicit|, the B\'ezier control
6974 point for leaving this knot has already been computed; it is in the
6975 |mp_right_x| and |mp_right_y| fields.
6978 The rules for |mp_left_type| are similar, but they refer to the curve entering
6979 the knot, and to \\{left} fields instead of \\{right} fields.
6981 Non-|explicit| control points will be chosen based on ``tension'' parameters
6982 in the |left_tension| and |right_tension| fields. The
6983 `\&{atleast}' option is represented by negative tension values.
6984 @:at_least_}{\&{atleast} primitive@>
6986 For example, the \MP\ path specification
6987 $$\.{z0..z1..tension atleast 1..\{curl 2\}z2..z3\{-1,-2\}..tension
6989 where \.p is the path `\.{z4..controls z45 and z54..z5}', will be represented
6991 \def\lodash{\hbox to 1.1em{\thinspace\hrulefill\thinspace}}
6992 $$\vbox{\halign{#\hfil&&\qquad#\hfil\cr
6993 |mp_left_type|&\\{left} info&|x_coord,y_coord|&|mp_right_type|&\\{right} info\cr
6995 |endpoint|&\lodash$,\,$\lodash&$x_0,y_0$&|curl|&$1.0,1.0$\cr
6996 |open|&\lodash$,1.0$&$x_1,y_1$&|open|&\lodash$,-1.0$\cr
6997 |curl|&$2.0,-1.0$&$x_2,y_2$&|curl|&$2.0,1.0$\cr
6998 |given|&$d,1.0$&$x_3,y_3$&|given|&$d,3.0$\cr
6999 |open|&\lodash$,4.0$&$x_4,y_4$&|explicit|&$x_{45},y_{45}$\cr
7000 |explicit|&$x_{54},y_{54}$&$x_5,y_5$&|endpoint|&\lodash$,\,$\lodash\cr}}$$
7001 Here |d| is the |angle| obtained by calling |n_arg(-unity,-two)|.
7002 Of course, this example is more complicated than anything a normal user
7005 These types must satisfy certain restrictions because of the form of \MP's
7007 (i)~|open| type never appears in the same node together with |endpoint|,
7009 (ii)~The |mp_right_type| of a node is |explicit| if and only if the
7010 |mp_left_type| of the following node is |explicit|.
7011 (iii)~|endpoint| types occur only at the ends, as mentioned above.
7013 @d left_curl left_x /* curl information when entering this knot */
7014 @d left_given left_x /* given direction when entering this knot */
7015 @d left_tension left_y /* tension information when entering this knot */
7016 @d right_curl right_x /* curl information when leaving this knot */
7017 @d right_given right_x /* given direction when leaving this knot */
7018 @d right_tension right_y /* tension information when leaving this knot */
7020 @ Knots can be user-supplied, or they can be created by program code,
7021 like the |split_cubic| function, or |copy_path|. The distinction is
7022 needed for the cleanup routine that runs after |split_cubic|, because
7023 it should only delete knots it has previously inserted, and never
7024 anything that was user-supplied. In order to be able to differentiate
7025 one knot from another, we will set |originator(p):=mp_metapost_user| when
7026 it appeared in the actual metapost program, and
7027 |originator(p):=mp_program_code| in all other cases.
7029 @d mp_originator(A) (A)->originator /* the creator of this knot */
7032 enum mp_knot_originator {
7033 mp_program_code = 0, /* not created by a user */
7034 mp_metapost_user /* created by a user */
7037 @ Here is a routine that prints a given knot list
7038 in symbolic form. It illustrates the conventions discussed above,
7039 and checks for anomalies that might arise while \MP\ is being debugged.
7042 static void mp_pr_path (MP mp, mp_knot h);
7045 void mp_pr_path (MP mp, mp_knot h) {
7046 mp_knot p, q; /* for list traversal */
7049 q = mp_next_knot (p);
7050 if ((p == NULL) || (q == NULL)) {
7051 mp_print_nl (mp, "???
");
7052 return; /* this won't happen */
7055 @<Print information for adjacent knots |p| and |q|@>;
7058 if (p && ((p != h) || (mp_left_type (h) != mp_endpoint))) {
7059 @<Print two dots, followed by |given| or |curl| if present@>;
7062 if (mp_left_type (h) != mp_endpoint)
7063 mp_print (mp, "cycle
");
7067 @ @<Print information for adjacent knots...@>=
7068 mp_print_two (mp, p->x_coord, p->y_coord);
7069 switch (mp_right_type (p)) {
7071 if (mp_left_type (p) == mp_open)
7072 mp_print (mp, "{open?
}"); /* can't happen */
7074 if ((mp_left_type (q) != mp_endpoint) || (q != h))
7075 q = NULL; /* force an error */
7079 @<Print control points between |p| and |q|, then |goto done1|@>;
7082 @<Print information for a curve that begins |open|@>;
7086 @<Print information for a curve that begins |curl| or |given|@>;
7089 mp_print (mp, "???
"); /* can't happen */
7093 if (mp_left_type (q) <= mp_explicit) {
7094 mp_print (mp, "..control?
"); /* can't happen */
7096 } else if ((!number_equal(p->right_tension, unity_t)) || (!number_equal(q->left_tension, unity_t))) {
7097 @<Print tension between |p| and |q|@>;
7100 @ Since |n_sin_cos| produces |fraction| results, which we will print as if they
7101 were |scaled|, the magnitude of a |given| direction vector will be~4096.
7103 @<Print two dots...@>=
7105 mp_number n_sin, n_cos;
7106 new_fraction (n_sin);
7107 new_fraction (n_cos);
7108 mp_print_nl (mp, " ..
");
7109 if (mp_left_type (p) == mp_given) {
7110 n_sin_cos (p->left_given, n_cos, n_sin);
7111 mp_print_char (mp, xord ('{'));
7112 print_number (n_cos);
7113 mp_print_char (mp, xord (','));
7114 print_number (n_sin);
7115 mp_print_char (mp, xord ('}'));
7116 } else if (mp_left_type (p) == mp_curl) {
7117 mp_print (mp, "{curl
");
7118 print_number (p->left_curl);
7119 mp_print_char (mp, xord ('}'));
7121 free_number (n_sin);
7122 free_number (n_cos);
7126 @ @<Print tension between |p| and |q|@>=
7130 mp_print (mp, "..tension
");
7131 if (number_negative(p->right_tension))
7132 mp_print (mp, "atleast
");
7133 number_clone (v1, p->right_tension);
7136 if (!number_equal(p->right_tension, q->left_tension)) {
7137 mp_print (mp, " and
");
7138 if (number_negative(q->left_tension))
7139 mp_print (mp, "atleast
");
7140 number_clone (v1, p->left_tension);
7148 @ @<Print control points between |p| and |q|, then |goto done1|@>=
7150 mp_print (mp, "..controls
");
7151 mp_print_two (mp, p->right_x, p->right_y);
7152 mp_print (mp, " and
");
7153 if (mp_left_type (q) != mp_explicit) {
7154 mp_print (mp, "??
"); /* can't happen */
7157 mp_print_two (mp, q->left_x, q->left_y);
7163 @ @<Print information for a curve that begins |open|@>=
7164 if ((mp_left_type (p) != mp_explicit) && (mp_left_type (p) != mp_open)) {
7165 mp_print (mp, "{open?
}"); /* can't happen */
7169 @ A curl of 1 is shown explicitly, so that the user sees clearly that
7170 \MP's default curl is present.
7172 @<Print information for a curve that begins |curl|...@>=
7174 if (mp_left_type (p) == mp_open)
7175 mp_print (mp, "??
"); /* can't happen */
7177 if (mp_right_type (p) == mp_curl) {
7178 mp_print (mp, "{curl
");
7179 print_number (p->right_curl);
7181 mp_number n_sin, n_cos;
7182 new_fraction (n_sin);
7183 new_fraction (n_cos);
7184 n_sin_cos (p->right_given, n_cos, n_sin);
7185 mp_print_char (mp, xord ('{'));
7186 print_number (n_cos);
7187 mp_print_char (mp, xord (','));
7188 print_number (n_sin);
7189 free_number (n_sin);
7190 free_number (n_cos);
7192 mp_print_char (mp, xord ('}'));
7196 @ It is convenient to have another version of |pr_path| that prints the path
7197 as a diagnostic message.
7200 static void mp_print_path (MP mp, mp_knot h, const char *s, boolean nuline);
7203 void mp_print_path (MP mp, mp_knot h, const char *s, boolean nuline) {
7204 mp_print_diagnostic (mp, "Path
", s, nuline);
7206 @.Path at line...@>;
7208 mp_end_diagnostic (mp, true);
7213 static mp_knot mp_new_knot (MP mp);
7216 static mp_knot mp_new_knot (MP mp) {
7218 if (mp->knot_nodes) {
7220 mp->knot_nodes = q->next;
7221 mp->num_knot_nodes--;
7223 q = mp_xmalloc (mp, 1, sizeof (struct mp_knot_data));
7225 memset(q,0,sizeof (struct mp_knot_data));
7226 new_number(q->x_coord);
7227 new_number(q->y_coord);
7228 new_number(q->left_x);
7229 new_number(q->left_y);
7230 new_number(q->right_x);
7231 new_number(q->right_y);
7237 static mp_gr_knot mp_gr_new_knot (MP mp);
7240 static mp_gr_knot mp_gr_new_knot (MP mp) {
7241 mp_gr_knot q = mp_xmalloc (mp, 1, sizeof (struct mp_gr_knot_data));
7246 @ If we want to duplicate a knot node, we can say |copy_knot|:
7249 static mp_knot mp_copy_knot (MP mp, mp_knot p) {
7251 if (mp->knot_nodes) {
7253 mp->knot_nodes = q->next;
7254 mp->num_knot_nodes--;
7256 q = mp_xmalloc (mp, 1, sizeof (struct mp_knot_data));
7258 memcpy (q, p, sizeof (struct mp_knot_data));
7259 if (mp->math_mode > mp_math_double_mode) {
7260 new_number(q->x_coord);
7261 new_number(q->y_coord);
7262 new_number(q->left_x);
7263 new_number(q->left_y);
7264 new_number(q->right_x);
7265 new_number(q->right_y);
7266 number_clone(q->x_coord, p->x_coord);
7267 number_clone(q->y_coord, p->y_coord);
7268 number_clone(q->left_x, p->left_x);
7269 number_clone(q->left_y, p->left_y);
7270 number_clone(q->right_x, p->right_x);
7271 number_clone(q->right_y, p->right_y);
7273 mp_next_knot (q) = NULL;
7277 @ If we want to export a knot node, we can say |export_knot|:
7280 static mp_gr_knot mp_export_knot (MP mp, mp_knot p) {
7281 mp_gr_knot q; /* the copy */
7282 q = mp_gr_new_knot (mp);
7283 q->x_coord = number_to_double(p->x_coord);
7284 q->y_coord = number_to_double(p->y_coord);
7285 q->left_x = number_to_double(p->left_x);
7286 q->left_y = number_to_double(p->left_y);
7287 q->right_x = number_to_double(p->right_x);
7288 q->right_y = number_to_double(p->right_y);
7289 q->data.types.left_type = mp_left_type(p);
7290 q->data.types.right_type = mp_left_type(p);
7291 q->data.info = mp_knot_info(p);
7292 mp_gr_next_knot (q) = NULL;
7297 @ The |copy_path| routine makes a clone of a given path.
7300 static mp_knot mp_copy_path (MP mp, mp_knot p) {
7301 mp_knot q, pp, qq; /* for list manipulation */
7304 q = mp_copy_knot (mp, p);
7306 pp = mp_next_knot (p);
7308 mp_next_knot (qq) = mp_copy_knot (mp, pp);
7309 qq = mp_next_knot (qq);
7310 pp = mp_next_knot (pp);
7312 mp_next_knot (qq) = q;
7316 @ The |export_path| routine makes a clone of a given path
7317 and converts the |value|s therein to |double|s.
7320 static mp_gr_knot mp_export_path (MP mp, mp_knot p) {
7321 mp_knot pp; /* for list manipulation */
7325 q = mp_export_knot (mp, p);
7327 pp = mp_next_knot (p);
7329 mp_gr_next_knot (qq) = mp_export_knot (mp, pp);
7330 qq = mp_gr_next_knot (qq);
7331 pp = mp_next_knot (pp);
7333 mp_gr_next_knot (qq) = q;
7337 @ If we want to import a knot node, we can say |import_knot|:
7340 static mp_knot mp_import_knot (MP mp, mp_gr_knot p) {
7341 mp_knot q; /* the copy */
7342 q = mp_new_knot (mp);
7343 set_number_from_double(q->x_coord, p->x_coord);
7344 set_number_from_double(q->y_coord, p->y_coord);
7345 set_number_from_double(q->left_x, p->left_x);
7346 set_number_from_double(q->left_y, p->left_y);
7347 set_number_from_double(q->right_x, p->right_x);
7348 set_number_from_double(q->right_y, p->right_y);
7349 mp_left_type(q) = p->data.types.left_type;
7350 mp_left_type(q) = p->data.types.right_type;
7351 mp_knot_info(q) = p->data.info;
7352 mp_next_knot (q) = NULL;
7357 @ The |import_path| routine makes a clone of a given path
7358 and converts the |value|s therein to |scaled|s.
7361 static mp_knot mp_import_path (MP mp, mp_gr_knot p) {
7362 mp_gr_knot pp; /* for list manipulation */
7366 q = mp_import_knot (mp, p);
7368 pp = mp_gr_next_knot (p);
7370 mp_next_knot (qq) = mp_import_knot (mp, pp);
7371 qq = mp_next_knot (qq);
7372 pp = mp_gr_next_knot (pp);
7374 mp_next_knot (qq) = q;
7379 @ Just before |ship_out|, knot lists are exported for printing.
7381 @ The |export_knot_list| routine therefore also makes a clone
7385 static mp_gr_knot mp_export_knot_list (MP mp, mp_knot p) {
7386 mp_gr_knot q; /* the exported copy */
7389 q = mp_export_path (mp, p);
7392 static mp_knot mp_import_knot_list (MP mp, mp_gr_knot q) {
7393 mp_knot p; /* the imported copy */
7396 p = mp_import_path (mp, q);
7400 @ Similarly, there's a way to copy the {\sl reverse\/} of a path. This procedure
7401 returns a pointer to the first node of the copy, if the path is a cycle,
7402 but to the final node of a non-cyclic copy. The global
7403 variable |path_tail| will point to the final node of the original path;
7404 this trick makes it easier to implement `\&{doublepath}'.
7406 All node types are assumed to be |endpoint| or |explicit| only.
7409 static mp_knot mp_htap_ypoc (MP mp, mp_knot p) {
7410 mp_knot q, pp, qq, rr; /* for list manipulation */
7411 q = mp_new_knot (mp); /* this will correspond to |p| */
7415 mp_right_type (qq) = mp_left_type (pp);
7416 mp_left_type (qq) = mp_right_type (pp);
7417 number_clone (qq->x_coord, pp->x_coord);
7418 number_clone (qq->y_coord, pp->y_coord);
7419 number_clone (qq->right_x, pp->left_x);
7420 number_clone (qq->right_y, pp->left_y);
7421 number_clone (qq->left_x, pp->right_x);
7422 number_clone (qq->left_y, pp->right_y);
7423 mp_originator (qq) = mp_originator (pp);
7424 if (mp_next_knot (pp) == p) {
7425 mp_next_knot (q) = qq;
7429 rr = mp_new_knot (mp);
7430 mp_next_knot (rr) = qq;
7432 pp = mp_next_knot (pp);
7438 mp_knot path_tail; /* the node that links to the beginning of a path */
7440 @ When a cyclic list of knot nodes is no longer needed, it can be recycled by
7441 calling the following subroutine.
7444 static void mp_toss_knot_list (MP mp, mp_knot p);
7445 static void mp_toss_knot (MP mp, mp_knot p);
7446 static void mp_free_knot (MP mp, mp_knot p);
7449 void mp_free_knot (MP mp, mp_knot q) {
7450 free_number (q->x_coord);
7451 free_number (q->y_coord);
7452 free_number (q->left_x);
7453 free_number (q->left_y);
7454 free_number (q->right_x);
7455 free_number (q->right_y);
7458 void mp_toss_knot (MP mp, mp_knot q) {
7459 if (mp->num_knot_nodes < max_num_knot_nodes) {
7460 q->next = mp->knot_nodes;
7462 mp->num_knot_nodes++;
7465 if (mp->math_mode > mp_math_double_mode) {
7471 void mp_toss_knot_list (MP mp, mp_knot p) {
7472 mp_knot q; /* the node being freed */
7473 mp_knot r; /* the next node */
7477 if (mp->math_mode > mp_math_double_mode) {
7479 r = mp_next_knot (q);
7480 mp_toss_knot(mp, q);
7485 r = mp_next_knot (q);
7486 if (mp->num_knot_nodes < max_num_knot_nodes) {
7487 q->next = mp->knot_nodes;
7489 mp->num_knot_nodes++;
7499 @* Choosing control points.
7500 Now we must actually delve into one of \MP's more difficult routines,
7501 the |make_choices| procedure that chooses angles and control points for
7502 the splines of a curve when the user has not specified them explicitly.
7503 The parameter to |make_choices| points to a list of knots and
7504 path information, as described above.
7506 A path decomposes into independent segments at ``breakpoint'' knots,
7507 which are knots whose left and right angles are both prespecified in
7508 some way (i.e., their |mp_left_type| and |mp_right_type| aren't both open).
7511 void mp_make_choices (MP mp, mp_knot knots) {
7512 mp_knot h; /* the first breakpoint */
7513 mp_knot p, q; /* consecutive breakpoints being processed */
7514 @<Other local variables for |make_choices|@>;
7515 FUNCTION_TRACE1 ("make_choices
()\n
");
7516 check_arith(); /* make sure that |arith_error=false| */
7517 if (number_positive(internal_value (mp_tracing_choices)))
7518 mp_print_path (mp, knots, ", before choices
", true);
7519 @<If consecutive knots are equal, join them explicitly@>;
7520 @<Find the first breakpoint, |h|, on the path;
7521 insert an artificial breakpoint if the path is an unbroken cycle@>;
7524 @<Fill in the control points between |p| and the next breakpoint,
7525 then advance |p| to that breakpoint@>;
7527 if (number_positive(internal_value (mp_tracing_choices)))
7528 mp_print_path (mp, knots, ", after choices
", true);
7529 if (mp->arith_error) {
7530 @<Report an unexpected problem during the choice-making@>;
7535 void mp_make_choices (MP mp, mp_knot knots);
7537 @ @<Report an unexpected problem during the choice...@>=
7539 const char *hlp[] = {
7540 "The path that I just computed is out of range.
",
7541 "So it will probably look funny. Proceed
, for a laugh.
",
7543 mp_back_error (mp, "Some number got too big
", hlp, true);
7544 @.Some number got too big@>;
7546 mp->arith_error = false;
7550 @ Two knots in a row with the same coordinates will always be joined
7551 by an explicit ``curve'' whose control points are identical with the
7554 @<If consecutive knots are equal, join them explicitly@>=
7557 q = mp_next_knot (p);
7558 if (number_equal (p->x_coord, q->x_coord) &&
7559 number_equal (p->y_coord, q->y_coord) &&
7560 mp_right_type (p) > mp_explicit) {
7561 mp_right_type (p) = mp_explicit;
7562 if (mp_left_type (p) == mp_open) {
7563 mp_left_type (p) = mp_curl;
7564 set_number_to_unity(p->left_curl);
7566 mp_left_type (q) = mp_explicit;
7567 if (mp_right_type (q) == mp_open) {
7568 mp_right_type (q) = mp_curl;
7569 set_number_to_unity(q->right_curl);
7571 number_clone (p->right_x, p->x_coord);
7572 number_clone (q->left_x, p->x_coord);
7573 number_clone (p->right_y, p->y_coord);
7574 number_clone (q->left_y, p->y_coord);
7577 } while (p != knots)
7579 @ If there are no breakpoints, it is necessary to compute the direction
7580 angles around an entire cycle. In this case the |mp_left_type| of the first
7581 node is temporarily changed to |end_cycle|.
7583 @<Find the first breakpoint, |h|, on the path...@>=
7586 if (mp_left_type (h) != mp_open)
7588 if (mp_right_type (h) != mp_open)
7590 h = mp_next_knot (h);
7592 mp_left_type (h) = mp_end_cycle;
7598 @ If |mp_right_type(p)<given| and |q=mp_link(p)|, we must have
7599 |mp_right_type(p)=mp_left_type(q)=mp_explicit| or |endpoint|.
7601 @<Fill in the control points between |p| and the next breakpoint...@>=
7602 q = mp_next_knot (p);
7603 if (mp_right_type (p) >= mp_given) {
7604 while ((mp_left_type (q) == mp_open) && (mp_right_type (q) == mp_open)) {
7605 q = mp_next_knot (q);
7607 @<Fill in the control information between consecutive breakpoints |p| and |q|@>;
7608 } else if (mp_right_type (p) == mp_endpoint) {
7609 @<Give reasonable values for the unused control points between |p| and~|q|@>;
7613 @ This step makes it possible to transform an explicitly computed path without
7614 checking the |mp_left_type| and |mp_right_type| fields.
7616 @<Give reasonable values for the unused control points between |p| and~|q|@>=
7618 number_clone (p->right_x, p->x_coord);
7619 number_clone (p->right_y, p->y_coord);
7620 number_clone (q->left_x, q->x_coord);
7621 number_clone (q->left_y, q->y_coord);
7625 @ Before we can go further into the way choices are made, we need to
7626 consider the underlying theory. The basic ideas implemented in |make_choices|
7627 are due to John Hobby, who introduced the notion of ``mock curvature''
7628 @^Hobby, John Douglas@>
7629 at a knot. Angles are chosen so that they preserve mock curvature when
7630 a knot is passed, and this has been found to produce excellent results.
7632 It is convenient to introduce some notations that simplify the necessary
7633 formulas. Let $d_{k,k+1}=\vert z\k-z_k\vert$ be the (nonzero) distance
7634 between knots |k| and |k+1|; and let
7635 $${z\k-z_k\over z_k-z_{k-1}}={d_{k,k+1}\over d_{k-1,k}}e^{i\psi_k}$$
7636 so that a polygonal line from $z_{k-1}$ to $z_k$ to $z\k$ turns left
7637 through an angle of~$\psi_k$. We assume that $\vert\psi_k\vert\L180^\circ$.
7638 The control points for the spline from $z_k$ to $z\k$ will be denoted by
7639 $$\eqalign{z_k^+&=z_k+
7640 \textstyle{1\over3}\rho_k e^{i\theta_k}(z\k-z_k),\cr
7642 \textstyle{1\over3}\sigma\k e^{-i\phi\k}(z\k-z_k),\cr}$$
7643 where $\rho_k$ and $\sigma\k$ are nonnegative ``velocity ratios'' at the
7644 beginning and end of the curve, while $\theta_k$ and $\phi\k$ are the
7645 corresponding ``offset angles.'' These angles satisfy the condition
7646 $$\theta_k+\phi_k+\psi_k=0,\eqno(*)$$
7647 whenever the curve leaves an intermediate knot~|k| in the direction that
7650 @ Let $\alpha_k$ and $\beta\k$ be the reciprocals of the ``tension'' of
7651 the curve at its beginning and ending points. This means that
7652 $\rho_k=\alpha_k f(\theta_k,\phi\k)$ and $\sigma\k=\beta\k f(\phi\k,\theta_k)$,
7653 where $f(\theta,\phi)$ is \MP's standard velocity function defined in
7654 the |velocity| subroutine. The cubic spline $B(z_k^{\phantom+},z_k^+,
7655 z\k^-,z\k^{\phantom+};t)$
7658 $${2\sigma\k\sin(\theta_k+\phi\k)-6\sin\theta_k\over\rho_k^2d_{k,k+1}}
7659 \qquad{\rm and}\qquad
7660 {2\rho_k\sin(\theta_k+\phi\k)-6\sin\phi\k\over\sigma\k^2d_{k,k+1}}$$
7661 at |t=0| and |t=1|, respectively. The mock curvature is the linear
7663 approximation to this true curvature that arises in the limit for
7664 small $\theta_k$ and~$\phi\k$, if second-order terms are discarded.
7665 The standard velocity function satisfies
7666 $$f(\theta,\phi)=1+O(\theta^2+\theta\phi+\phi^2);$$
7667 hence the mock curvatures are respectively
7668 $${2\beta\k(\theta_k+\phi\k)-6\theta_k\over\alpha_k^2d_{k,k+1}}
7669 \qquad{\rm and}\qquad
7670 {2\alpha_k(\theta_k+\phi\k)-6\phi\k\over\beta\k^2d_{k,k+1}}.\eqno(**)$$
7672 @ The turning angles $\psi_k$ are given, and equation $(*)$ above
7673 determines $\phi_k$ when $\theta_k$ is known, so the task of
7674 angle selection is essentially to choose appropriate values for each
7675 $\theta_k$. When equation~$(*)$ is used to eliminate $\phi$~variables
7676 from $(**)$, we obtain a system of linear equations of the form
7677 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
7679 $$A_k={\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
7680 \qquad B_k={3-\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
7681 \qquad C_k={3-\beta\k\over\alpha_k^2d_{k,k+1}},
7682 \qquad D_k={\beta\k\over\alpha_k^2d_{k,k+1}}.$$
7683 The tensions are always $3\over4$ or more, hence each $\alpha$ and~$\beta$
7684 will be at most $4\over3$. It follows that $B_k\G{5\over4}A_k$ and
7685 $C_k\G{5\over4}D_k$; hence the equations are diagonally dominant;
7686 hence they have a unique solution. Moreover, in most cases the tensions
7687 are equal to~1, so that $B_k=2A_k$ and $C_k=2D_k$. This makes the
7688 solution numerically stable, and there is an exponential damping
7689 effect: The data at knot $k\pm j$ affects the angle at knot~$k$ by
7690 a factor of~$O(2^{-j})$.
7692 @ However, we still must consider the angles at the starting and ending
7693 knots of a non-cyclic path. These angles might be given explicitly, or
7694 they might be specified implicitly in terms of an amount of ``curl.''
7696 Let's assume that angles need to be determined for a non-cyclic path
7697 starting at $z_0$ and ending at~$z_n$. Then equations of the form
7698 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta_{k+1}=R_k$$
7699 have been given for $0<k<n$, and it will be convenient to introduce
7700 equations of the same form for $k=0$ and $k=n$, where
7701 $$A_0=B_0=C_n=D_n=0.$$
7702 If $\theta_0$ is supposed to have a given value $E_0$, we simply
7703 define $C_0=1$, $D_0=0$, and $R_0=E_0$. Otherwise a curl
7704 parameter, $\gamma_0$, has been specified at~$z_0$; this means
7705 that the mock curvature at $z_0$ should be $\gamma_0$ times the
7706 mock curvature at $z_1$; i.e.,
7707 $${2\beta_1(\theta_0+\phi_1)-6\theta_0\over\alpha_0^2d_{01}}
7708 =\gamma_0{2\alpha_0(\theta_0+\phi_1)-6\phi_1\over\beta_1^2d_{01}}.$$
7709 This equation simplifies to
7710 $$(\alpha_0\chi_0+3-\beta_1)\theta_0+
7711 \bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\theta_1=
7712 -\bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\psi_1,$$
7713 where $\chi_0=\alpha_0^2\gamma_0/\beta_1^2$; so we can set $C_0=
7714 \chi_0\alpha_0+3-\beta_1$, $D_0=(3-\alpha_0)\chi_0+\beta_1$, $R_0=-D_0\psi_1$.
7715 It can be shown that $C_0>0$ and $C_0B_1-A_1D_0>0$ when $\gamma_0\G0$,
7716 hence the linear equations remain nonsingular.
7718 Similar considerations apply at the right end, when the final angle $\phi_n$
7719 may or may not need to be determined. It is convenient to let $\psi_n=0$,
7720 hence $\theta_n=-\phi_n$. We either have an explicit equation $\theta_n=E_n$,
7722 $$\bigl((3-\beta_n)\chi_n+\alpha_{n-1}\bigr)\theta_{n-1}+
7723 (\beta_n\chi_n+3-\alpha_{n-1})\theta_n=0,\qquad
7724 \chi_n={\beta_n^2\gamma_n\over\alpha_{n-1}^2}.$$
7726 When |make_choices| chooses angles, it must compute the coefficients of
7727 these linear equations, then solve the equations. To compute the coefficients,
7728 it is necessary to compute arctangents of the given turning angles~$\psi_k$.
7729 When the equations are solved, the chosen directions $\theta_k$ are put
7730 back into the form of control points by essentially computing sines and
7733 @ OK, we are ready to make the hard choices of |make_choices|.
7734 Most of the work is relegated to an auxiliary procedure
7735 called |solve_choices|, which has been introduced to keep
7736 |make_choices| from being extremely long.
7738 @<Fill in the control information between...@>=
7739 @<Calculate the turning angles $\psi_k$ and the distances $d_{k,k+1}$;
7740 set $n$ to the length of the path@>;
7741 @<Remove |open| types at the breakpoints@>;
7742 mp_solve_choices (mp, p, q, n)
7745 @ It's convenient to precompute quantities that will be needed several
7746 times later. The values of |delta_x[k]| and |delta_y[k]| will be the
7747 coordinates of $z\k-z_k$, and the magnitude of this vector will be
7748 |delta[k]=@t$d_{k,k+1}$@>|. The path angle $\psi_k$ between $z_k-z_{k-1}$
7749 and $z\k-z_k$ will be stored in |psi[k]|.
7752 int path_size; /* maximum number of knots between breakpoints of a path */
7755 mp_number *delta; /* knot differences */
7756 mp_number *psi; /* turning angles */
7758 @ @<Dealloc variables@>=
7761 for (k = 0; k<mp->path_size; k++) {
7762 free_number (mp->delta_x[k]);
7763 free_number (mp->delta_y[k]);
7764 free_number (mp->delta[k]);
7765 free_number (mp->psi[k]);
7767 xfree (mp->delta_x);
7768 xfree (mp->delta_y);
7773 @ @<Other local variables for |make_choices|@>=
7774 int k, n; /* current and final knot numbers */
7775 mp_knot s, t; /* registers for list traversal */
7777 @ @<Calculate the turning angles...@>=
7779 mp_number sine, cosine; /* trig functions of various angles */
7780 new_fraction (sine);
7781 new_fraction (cosine);
7787 t = mp_next_knot (s);
7788 set_number_from_substraction(mp->delta_x[k], t->x_coord, s->x_coord);
7789 set_number_from_substraction(mp->delta_y[k], t->y_coord, s->y_coord);
7790 pyth_add (mp->delta[k], mp->delta_x[k], mp->delta_y[k]);
7792 mp_number arg1, arg2, r1, r2;
7797 make_fraction (r1, mp->delta_y[k - 1], mp->delta[k - 1]);
7798 number_clone (sine, r1);
7799 make_fraction (r2, mp->delta_x[k - 1], mp->delta[k - 1]);
7800 number_clone (cosine, r2);
7801 take_fraction (r1, mp->delta_x[k], cosine);
7802 take_fraction (r2, mp->delta_y[k], sine);
7803 set_number_from_addition (arg1, r1, r2);
7804 take_fraction (r1, mp->delta_y[k], cosine);
7805 take_fraction (r2, mp->delta_x[k], sine);
7806 set_number_from_substraction (arg2, r1, r2);
7807 n_arg (mp->psi[k], arg1, arg2 );
7815 if (k == mp->path_size) {
7816 mp_reallocate_paths (mp, mp->path_size + (mp->path_size / 4));
7817 goto RESTART; /* retry, loop size has changed */
7821 } while (!((k >= n) && (mp_left_type (s) != mp_end_cycle)));
7823 set_number_to_zero(mp->psi[k]);
7825 number_clone(mp->psi[k], mp->psi[1]);
7827 free_number (cosine);
7831 @ When we get to this point of the code, |mp_right_type(p)| is either
7832 |given| or |curl| or |open|. If it is |open|, we must have
7833 |mp_left_type(p)=mp_end_cycle| or |mp_left_type(p)=mp_explicit|. In the latter
7834 case, the |open| type is converted to |given|; however, if the
7835 velocity coming into this knot is zero, the |open| type is
7836 converted to a |curl|, since we don't know the incoming direction.
7838 Similarly, |mp_left_type(q)| is either |given| or |curl| or |open| or
7839 |mp_end_cycle|. The |open| possibility is reduced either to |given| or to |curl|.
7841 @<Remove |open| types at the breakpoints@>=
7843 mp_number delx, dely; /* directions where |open| meets |explicit| */
7846 if (mp_left_type (q) == mp_open) {
7847 set_number_from_substraction(delx, q->right_x, q->x_coord);
7848 set_number_from_substraction(dely, q->right_y, q->y_coord);
7849 if (number_zero(delx) && number_zero(dely)) {
7850 mp_left_type (q) = mp_curl;
7851 set_number_to_unity(q->left_curl);
7853 mp_left_type (q) = mp_given;
7854 n_arg (q->left_given, delx, dely);
7857 if ((mp_right_type (p) == mp_open) && (mp_left_type (p) == mp_explicit)) {
7858 set_number_from_substraction(delx, p->x_coord, p->left_x);
7859 set_number_from_substraction(dely, p->y_coord, p->left_y);
7860 if (number_zero(delx) && number_zero(dely)) {
7861 mp_right_type (p) = mp_curl;
7862 set_number_to_unity(p->right_curl);
7864 mp_right_type (p) = mp_given;
7865 n_arg (p->right_given, delx, dely);
7872 @ Linear equations need to be solved whenever |n>1|; and also when |n=1|
7873 and exactly one of the breakpoints involves a curl. The simplest case occurs
7874 when |n=1| and there is a curl at both breakpoints; then we simply draw
7877 But before coding up the simple cases, we might as well face the general case,
7878 since we must deal with it sooner or later, and since the general case
7879 is likely to give some insight into the way simple cases can be handled best.
7881 When there is no cycle, the linear equations to be solved form a tridiagonal
7882 system, and we can apply the standard technique of Gaussian elimination
7883 to convert that system to a sequence of equations of the form
7884 $$\theta_0+u_0\theta_1=v_0,\quad
7885 \theta_1+u_1\theta_2=v_1,\quad\ldots,\quad
7886 \theta_{n-1}+u_{n-1}\theta_n=v_{n-1},\quad
7888 It is possible to do this diagonalization while generating the equations.
7889 Once $\theta_n$ is known, it is easy to determine $\theta_{n-1}$, \dots,
7890 $\theta_1$, $\theta_0$; thus, the equations will be solved.
7892 The procedure is slightly more complex when there is a cycle, but the
7893 basic idea will be nearly the same. In the cyclic case the right-hand
7894 sides will be $v_k+w_k\theta_0$ instead of simply $v_k$, and we will start
7895 the process off with $u_0=v_0=0$, $w_0=1$. The final equation will be not
7896 $\theta_n=v_n$ but $\theta_n+u_n\theta_1=v_n+w_n\theta_0$; an appropriate
7897 ending routine will take account of the fact that $\theta_n=\theta_0$ and
7898 eliminate the $w$'s from the system, after which the solution can be
7901 When $u_k$, $v_k$, and $w_k$ are being computed, the three pointer
7902 variables |r|, |s|,~|t| will point respectively to knots |k-1|, |k|,
7903 and~|k+1|. The $u$'s and $w$'s are scaled by $2^{28}$, i.e., they are
7904 of type |fraction|; the $\theta$'s and $v$'s are of type |angle|.
7907 mp_number *theta; /* values of $\theta_k$ */
7908 mp_number *uu; /* values of $u_k$ */
7909 mp_number *vv; /* values of $v_k$ */
7910 mp_number *ww; /* values of $w_k$ */
7912 @ @<Dealloc variables@>=
7915 for (k = 0; k<mp->path_size; k++) {
7916 free_number (mp->theta[k]);
7917 free_number (mp->uu[k]);
7918 free_number (mp->vv[k]);
7919 free_number (mp->ww[k]);
7928 static void mp_reallocate_paths (MP mp, int l);
7931 void mp_reallocate_paths (MP mp, int l) {
7933 XREALLOC (mp->delta_x, l, mp_number);
7934 XREALLOC (mp->delta_y, l, mp_number);
7935 XREALLOC (mp->delta, l, mp_number);
7936 XREALLOC (mp->psi, l, mp_number);
7937 XREALLOC (mp->theta, l, mp_number);
7938 XREALLOC (mp->uu, l, mp_number);
7939 XREALLOC (mp->vv, l, mp_number);
7940 XREALLOC (mp->ww, l, mp_number);
7941 for (k = mp->path_size; k<l; k++) {
7942 new_number (mp->delta_x[k]);
7943 new_number (mp->delta_y[k]);
7944 new_number (mp->delta[k]);
7945 new_angle (mp->psi[k]);
7946 new_angle (mp->theta[k]);
7947 new_fraction (mp->uu[k]);
7948 new_angle (mp->vv[k]);
7949 new_fraction (mp->ww[k]);
7955 @ Our immediate problem is to get the ball rolling by setting up the
7956 first equation or by realizing that no equations are needed, and to fit
7957 this initialization into a framework suitable for the overall computation.
7960 static void mp_solve_choices (MP mp, mp_knot p, mp_knot q, halfword n);
7963 void mp_solve_choices (MP mp, mp_knot p, mp_knot q, halfword n) {
7964 int k; /* current knot number */
7965 mp_knot r, s, t; /* registers for list traversal */
7968 FUNCTION_TRACE2 ("solve_choices
(%d
)\n
", n);
7973 t = mp_next_knot (s);
7975 @<Get the linear equations started; or |return|
7976 with the control points in place, if linear equations
7979 switch (mp_left_type (s)) {
7982 @<Set up equation to match mock curvatures
7983 at $z_k$; then |goto found| with $\theta_n$
7984 adjusted to equal $\theta_0$, if a cycle has ended@>;
7987 @<Set up equation for a curl at $\theta_n$
7991 @<Calculate the given value of $\theta_n$
7994 } /* there are no other cases */
8001 @<Finish choosing angles and assigning control points@>;
8006 @ On the first time through the loop, we have |k=0| and |r| is not yet
8007 defined. The first linear equation, if any, will have $A_0=B_0=0$.
8009 @<Get the linear equations started...@>=
8010 switch (mp_right_type (s)) {
8012 if (mp_left_type (t) == mp_given) {
8013 @<Reduce to simple case of two givens and |return|@>
8015 @<Set up the equation for a given value of $\theta_0$@>;
8019 if (mp_left_type (t) == mp_curl) {
8020 @<Reduce to simple case of straight line and |return|@>
8022 @<Set up the equation for a curl at $\theta_0$@>;
8026 set_number_to_zero(mp->uu[0]);
8027 set_number_to_zero(mp->vv[0]);
8028 number_clone(mp->ww[0], fraction_one_t);
8029 /* this begins a cycle */
8031 } /* there are no other cases */
8034 @ The general equation that specifies equality of mock curvature at $z_k$ is
8035 $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
8036 as derived above. We want to combine this with the already-derived equation
8037 $\theta_{k-1}+u_{k-1}\theta_k=v_{k-1}+w_{k-1}\theta_0$ in order to obtain
8039 $\theta_k+u_k\theta\k=v_k+w_k\theta_0$. This can be done by dividing the
8041 $$(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}
8042 -A_kw_{k-1}\theta_0$$
8043 by $B_k-u_{k-1}A_k+C_k$. The trick is to do this carefully with
8044 fixed-point arithmetic, avoiding the chance of overflow while retaining
8047 The calculations will be performed in several registers that
8048 provide temporary storage for intermediate quantities.
8050 @ @<Set up equation to match mock curvatures...@>=
8052 mp_number aa, bb, cc, acc; /* temporary registers */
8053 mp_number dd, ee; /* likewise, but |scaled| */
8060 @<Calculate the values $\\{aa}=A_k/B_k$, $\\{bb}=D_k/C_k$,
8061 $\\{dd}=(3-\alpha_{k-1})d_{k,k+1}$, $\\{ee}=(3-\beta\k)d_{k-1,k}$,
8062 and $\\{cc}=(B_k-u_{k-1}A_k)/B_k$@>;
8063 @<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>;
8064 take_fraction (mp->uu[k], ff, bb);
8065 @<Calculate the values of $v_k$ and $w_k$@>;
8066 if (mp_left_type (s) == mp_end_cycle) {
8067 @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>;
8078 @ Since tension values are never less than 3/4, the values |aa| and
8079 |bb| computed here are never more than 4/5.
8081 @<Calculate the values $\\{aa}=...@>=
8084 new_number (absval);
8085 number_clone (absval, r->right_tension);
8086 number_abs (absval);
8087 if (number_equal (absval, unity_t)) {
8088 number_clone (aa, fraction_half_t);
8089 number_clone (dd, mp->delta[k]);
8092 mp_number arg1, arg2, ret;
8095 number_clone (arg2, r->right_tension);
8097 number_multiply_int (arg2, 3);
8098 number_substract (arg2, unity_t);
8099 make_fraction (aa, unity_t, arg2);
8100 number_clone (arg2, r->right_tension);
8103 make_fraction (ret, unity_t, arg2);
8104 set_number_from_substraction (arg1, fraction_three_t, ret);
8105 take_fraction (arg2, mp->delta[k], arg1);
8106 number_clone (dd, arg2);
8111 number_clone (absval, t->left_tension);
8112 number_abs (absval);
8113 if (number_equal (absval, unity_t)) {
8114 number_clone (bb, fraction_half_t);
8115 number_clone (ee, mp->delta[k - 1]);
8118 mp_number arg1, arg2, ret;
8121 number_clone (arg2, t->left_tension);
8123 number_multiply_int (arg2, 3);
8124 number_substract (arg2, unity_t);
8125 make_fraction (bb, unity_t, arg2);
8126 number_clone (arg2, t->left_tension);
8129 make_fraction (ret, unity_t, arg2);
8130 set_number_from_substraction (arg1,fraction_three_t, ret);
8131 take_fraction (ee, mp->delta[k - 1], arg1);
8136 free_number (absval);
8141 take_fraction (r1, mp->uu[k - 1], aa);
8142 set_number_from_substraction (cc, fraction_one_t, r1);
8146 @ The ratio to be calculated in this step can be written in the form
8147 $$\beta_k^2\cdot\\{ee}\over\beta_k^2\cdot\\{ee}+\alpha_k^2\cdot
8148 \\{cc}\cdot\\{dd},$$
8149 because of the quantities just calculated. The values of |dd| and |ee|
8150 will not be needed after this step has been performed.
8152 @<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>=
8157 number_clone (arg2, dd);
8158 take_fraction (dd, arg2, cc);
8161 number_clone (lt, s->left_tension);
8163 number_clone (rt, s->right_tension);
8165 if (!number_equal(lt, rt)) { /* $\beta_k^{-1}\ne\alpha_k^{-1}$ */
8168 if (number_less(lt, rt)) {
8169 make_fraction (r1, lt, rt); /* $\alpha_k^2/\beta_k^2$ */
8170 take_fraction (ff, r1, r1);
8171 number_clone (r1, dd);
8172 take_fraction (dd, r1, ff);
8174 make_fraction (r1, rt, lt); /* $\beta_k^2/\alpha_k^2$ */
8175 take_fraction (ff, r1, r1);
8176 number_clone (r1, ee);
8177 take_fraction (ee, r1, ff);
8183 set_number_from_addition (arg2, dd, ee);
8184 make_fraction (ff, ee, arg2);
8189 @ The value of $u_{k-1}$ will be |<=1| except when $k=1$ and the previous
8190 equation was specified by a curl. In that case we must use a special
8191 method of computation to prevent overflow.
8193 Fortunately, the calculations turn out to be even simpler in this ``hard''
8194 case. The curl equation makes $w_0=0$ and $v_0=-u_0\psi_1$, hence
8195 $-B_1\psi_1-A_1v_0=-(B_1-u_0A_1)\psi_1=-\\{cc}\cdot B_1\psi_1$.
8197 @<Calculate the values of $v_k$ and $w_k$@>=
8198 take_fraction (acc, mp->psi[k + 1], mp->uu[k]);
8199 number_negate (acc);
8200 if (mp_right_type (r) == mp_curl) {
8204 set_number_from_substraction (arg2, fraction_one_t, ff);
8205 take_fraction (r1, mp->psi[1], arg2);
8206 set_number_to_zero(mp->ww[k]);
8207 set_number_from_substraction(mp->vv[k], acc, r1);
8214 set_number_from_substraction (arg1, fraction_one_t, ff);
8215 make_fraction (ff, arg1, cc); /* this is $B_k/(C_k+B_k-u_{k-1}A_k)<5$ */
8217 take_fraction (r1, mp->psi[k], ff);
8218 number_substract (acc, r1);
8219 number_clone (r1, ff);
8220 take_fraction (ff, r1, aa); /* this is $A_k/(C_k+B_k-u_{k-1}A_k)$ */
8221 take_fraction (r1, mp->vv[k - 1], ff);
8222 set_number_from_substraction(mp->vv[k], acc, r1 );
8223 if (number_zero(mp->ww[k - 1])) {
8224 set_number_to_zero(mp->ww[k]);
8226 take_fraction (mp->ww[k], mp->ww[k - 1], ff);
8227 number_negate(mp->ww[k]);
8233 @ When a complete cycle has been traversed, we have $\theta_k+u_k\theta\k=
8234 v_k+w_k\theta_0$, for |1<=k<=n|. We would like to determine the value of
8235 $\theta_n$ and reduce the system to the form $\theta_k+u_k\theta\k=v_k$
8236 for |0<=k<n|, so that the cyclic case can be finished up just as if there
8239 The idea in the following code is to observe that
8240 $$\eqalign{\theta_n&=v_n+w_n\theta_0-u_n\theta_1=\cdots\cr
8241 &=v_n+w_n\theta_0-u_n\bigl(v_1+w_1\theta_0-u_1(v_2+\cdots
8242 -u_{n-2}(v_{n-1}+w_{n-1}\theta_0-u_{n-1}\theta_0))\bigr),\cr}$$
8243 so we can solve for $\theta_n=\theta_0$.
8245 @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>=
8250 set_number_to_zero (aa);
8251 number_clone (bb, fraction_one_t); /* we have |k=n| */
8256 take_fraction (r1, aa, mp->uu[k]);
8257 set_number_from_substraction (aa, mp->vv[k], r1);
8258 take_fraction (r1, bb, mp->uu[k]);
8259 set_number_from_substraction (bb, mp->ww[k], r1);
8260 } while (k != n); /* now $\theta_n=\\{aa}+\\{bb}\cdot\theta_n$ */
8261 set_number_from_substraction (arg2, fraction_one_t, bb);
8262 make_fraction (r1, aa, arg2);
8263 number_clone (aa, r1);
8264 number_clone(mp->theta[n], aa);
8265 number_clone(mp->vv[0], aa);
8266 for (k = 1; k < n; k++) {
8267 take_fraction (r1, aa, mp->ww[k]);
8268 number_add(mp->vv[k], r1);
8283 void mp_reduce_angle (MP mp, mp_number *a) {
8285 FUNCTION_TRACE2 ("reduce_angle
(%f
)\n
", number_to_double(*a));
8287 number_clone(abs_a, *a);
8289 if ( number_greater(abs_a, one_eighty_deg_t)) {
8290 if (number_positive(*a)) {
8291 number_substract(*a, three_sixty_deg_t);
8293 number_add(*a, three_sixty_deg_t);
8300 void mp_reduce_angle (MP mp, mp_number *a);
8303 @ @<Calculate the given value of $\theta_n$...@>=
8307 n_arg (narg, mp->delta_x[n - 1], mp->delta_y[n - 1]);
8308 set_number_from_substraction(mp->theta[n], s->left_given, narg);
8310 mp_reduce_angle (mp, &mp->theta[n]);
8315 @ @<Set up the equation for a given value of $\theta_0$@>=
8319 n_arg (narg, mp->delta_x[0], mp->delta_y[0]);
8320 set_number_from_substraction(mp->vv[0], s->right_given, narg);
8322 mp_reduce_angle (mp, &mp->vv[0]);
8323 set_number_to_zero(mp->uu[0]);
8324 set_number_to_zero(mp->ww[0]);
8328 @ @<Set up the equation for a curl at $\theta_0$@>=
8330 mp_number lt, rt, cc; /* tension values */
8334 number_clone (cc, s->right_curl);
8335 number_clone (lt, t->left_tension);
8337 number_clone (rt, s->right_tension);
8339 if (number_unity(rt) && number_unity(lt)) {
8340 mp_number arg1, arg2;
8343 number_clone (arg1, cc);
8344 number_double (arg1);
8345 number_add (arg1, unity_t);
8346 number_clone (arg2, cc);
8347 number_add (arg2, two_t);
8348 make_fraction (mp->uu[0], arg1, arg2);
8352 mp_curl_ratio (mp, &mp->uu[0], cc, rt, lt);
8354 take_fraction (mp->vv[0], mp->psi[1], mp->uu[0]);
8355 number_negate(mp->vv[0]);
8356 set_number_to_zero(mp->ww[0]);
8363 @ @<Set up equation for a curl at $\theta_n$...@>=
8365 mp_number lt, rt, cc; /* tension values */
8369 number_clone (cc, s->left_curl);
8370 number_clone (lt, s->left_tension);
8372 number_clone (rt, r->right_tension);
8374 if (number_unity(rt) && number_unity(lt)) {
8375 mp_number arg1, arg2;
8378 number_clone (arg1, cc);
8379 number_double (arg1);
8380 number_add (arg1, unity_t);
8381 number_clone (arg2, cc);
8382 number_add (arg2, two_t);
8383 make_fraction (ff, arg1, arg2);
8387 mp_curl_ratio (mp, &ff, cc, lt, rt);
8390 mp_number arg1, arg2, r1;
8392 new_fraction (arg1);
8394 take_fraction (arg1, mp->vv[n - 1], ff);
8395 take_fraction (r1, ff, mp->uu[n - 1]);
8396 set_number_from_substraction (arg2, fraction_one_t, r1);
8397 make_fraction (mp->theta[n], arg1, arg2);
8398 number_negate(mp->theta[n]);
8410 @ The |curl_ratio| subroutine has three arguments, which our previous notation
8411 encourages us to call $\gamma$, $\alpha^{-1}$, and $\beta^{-1}$. It is
8412 a somewhat tedious program to calculate
8413 $${(3-\alpha)\alpha^2\gamma+\beta^3\over
8414 \alpha^3\gamma+(3-\beta)\beta^2},$$
8415 with the result reduced to 4 if it exceeds 4. (This reduction of curl
8416 is necessary only if the curl and tension are both large.)
8417 The values of $\alpha$ and $\beta$ will be at most~4/3.
8420 static void mp_curl_ratio (MP mp, mp_number *ret, mp_number gamma, mp_number a_tension,
8421 mp_number b_tension);
8424 void mp_curl_ratio (MP mp, mp_number *ret, mp_number gamma_orig, mp_number a_tension, mp_number b_tension) {
8425 mp_number alpha, beta, gamma, num, denom, ff; /* registers */
8428 new_fraction (alpha);
8429 new_fraction (beta);
8430 new_fraction (gamma);
8432 new_fraction (denom);
8434 make_fraction (alpha, unity_t, a_tension);
8435 make_fraction (beta, unity_t, b_tension);
8436 number_clone (gamma, gamma_orig);
8437 if (number_lessequal(alpha, beta)) {
8438 make_fraction (ff, alpha, beta);
8439 number_clone (arg1, ff);
8440 take_fraction (ff, arg1, arg1);
8441 number_clone (arg1, gamma);
8442 take_fraction (gamma, arg1, ff);
8443 convert_fraction_to_scaled (beta);
8444 take_fraction (denom, gamma, alpha);
8445 number_add (denom, three_t);
8447 make_fraction (ff, beta, alpha);
8448 number_clone (arg1, ff);
8449 take_fraction (ff, arg1, arg1);
8450 take_fraction (arg1, beta, ff);
8451 convert_fraction_to_scaled (arg1);
8452 number_clone (beta, arg1);
8453 take_fraction (denom, gamma, alpha);
8454 set_number_from_div (arg1, ff, twelvebits_3);
8455 number_add (denom, arg1);
8457 number_substract (denom, beta);
8458 set_number_from_substraction (arg1, fraction_three_t, alpha);
8459 take_fraction (num, gamma, arg1);
8460 number_add (num, beta);
8461 number_clone (arg1, denom);
8462 number_double (arg1);
8463 number_double (arg1); /* arg1 = 4*denom */
8464 if (number_greaterequal(num, arg1)) {
8465 number_clone(*ret, fraction_four_t);
8467 make_fraction (*ret, num, denom);
8469 free_number (alpha);
8471 free_number (gamma);
8473 free_number (denom);
8479 @ We're in the home stretch now.
8481 @<Finish choosing angles and assigning control points@>=
8485 for (k = n - 1; k >= 0; k--) {
8486 take_fraction (r1, mp->theta[k + 1], mp->uu[k]);
8487 set_number_from_substraction(mp->theta[k], mp->vv[k], r1);
8497 t = mp_next_knot (s);
8498 n_sin_cos (mp->theta[k], mp->ct, mp->st);
8499 number_clone (arg, mp->psi[k + 1]);
8500 number_negate (arg);
8501 number_substract (arg, mp->theta[k + 1]);
8502 n_sin_cos (arg, mp->cf, mp->sf);
8503 mp_set_controls (mp, s, t, k);
8511 @ The |set_controls| routine actually puts the control points into
8512 a pair of consecutive nodes |p| and~|q|. Global variables are used to
8513 record the values of $\sin\theta$, $\cos\theta$, $\sin\phi$, and
8514 $\cos\phi$ needed in this calculation.
8520 mp_number cf; /* sines and cosines */
8522 @ @<Initialize table...@>=
8523 new_fraction (mp->st);
8524 new_fraction (mp->ct);
8525 new_fraction (mp->sf);
8526 new_fraction (mp->cf);
8529 free_number (mp->st);
8530 free_number (mp->ct);
8531 free_number (mp->sf);
8532 free_number (mp->cf);
8536 static void mp_set_controls (MP mp, mp_knot p, mp_knot q, integer k);
8539 void mp_set_controls (MP mp, mp_knot p, mp_knot q, integer k) {
8540 mp_number rr, ss; /* velocities, divided by thrice the tension */
8541 mp_number lt, rt; /* tensions */
8542 mp_number sine; /* $\sin(\theta+\phi)$ */
8550 number_clone(lt, q->left_tension);
8552 number_clone(rt, p->right_tension);
8554 new_fraction (sine);
8557 velocity (rr, mp->st, mp->ct, mp->sf, mp->cf, rt);
8558 velocity (ss, mp->sf, mp->cf, mp->st, mp->ct, lt);
8559 if (number_negative(p->right_tension) || number_negative(q->left_tension)) {
8560 @<Decrease the velocities,
8561 if necessary, to stay inside the bounding triangle@>;
8563 take_fraction (r1, mp->delta_x [k], mp->ct);
8564 take_fraction (r2, mp->delta_y [k], mp->st);
8565 number_substract (r1, r2);
8566 take_fraction (tmp, r1, rr);
8567 set_number_from_addition (p->right_x, p->x_coord, tmp);
8568 take_fraction (r1, mp->delta_y[k], mp->ct);
8569 take_fraction (r2, mp->delta_x[k], mp->st);
8570 number_add (r1, r2);
8571 take_fraction (tmp, r1, rr);
8572 set_number_from_addition (p->right_y, p->y_coord, tmp);
8573 take_fraction (r1, mp->delta_x[k], mp->cf);
8574 take_fraction (r2, mp->delta_y[k], mp->sf);
8575 number_add (r1, r2);
8576 take_fraction (tmp, r1, ss);
8577 set_number_from_substraction (q->left_x, q->x_coord, tmp);
8578 take_fraction (r1, mp->delta_y[k], mp->cf);
8579 take_fraction (r2, mp->delta_x[k], mp->sf);
8580 number_substract (r1, r2);
8581 take_fraction (tmp, r1, ss);
8582 set_number_from_substraction(q->left_y, q->y_coord, tmp);
8583 mp_right_type (p) = mp_explicit;
8584 mp_left_type (q) = mp_explicit;
8596 @ The boundedness conditions $\\{rr}\L\sin\phi\,/\sin(\theta+\phi)$ and
8597 $\\{ss}\L\sin\theta\,/\sin(\theta+\phi)$ are to be enforced if $\sin\theta$,
8598 $\sin\phi$, and $\sin(\theta+\phi)$ all have the same sign. Otherwise
8599 there is no ``bounding triangle.''
8601 @<Decrease the velocities, if necessary...@>=
8602 if ((number_nonnegative(mp->st) && number_nonnegative(mp->sf)) || (number_nonpositive(mp->st) && number_nonpositive(mp->sf))) {
8603 mp_number r1, r2, arg1;
8605 new_number (ab_vs_cd);
8609 number_clone (arg1, mp->st);
8611 take_fraction (r1, arg1, mp->cf);
8612 number_clone (arg1, mp->sf);
8614 take_fraction (r2, arg1, mp->ct);
8615 set_number_from_addition (sine, r1, r2);
8616 if (number_positive(sine)) {
8617 set_number_from_addition (arg1, fraction_one_t, unity_t); /* safety factor */
8618 number_clone (r1, sine);
8619 take_fraction (sine, r1, arg1);
8620 if (number_negative(p->right_tension)) {
8621 number_clone (arg1, mp->sf);
8623 ab_vs_cd (ab_vs_cd, arg1, fraction_one_t, rr, sine);
8624 if (number_negative(ab_vs_cd)) {
8625 number_clone (arg1, mp->sf);
8627 make_fraction (rr, arg1, sine);
8630 if (number_negative(q->left_tension)) {
8631 number_clone (arg1, mp->st);
8633 ab_vs_cd (ab_vs_cd, arg1, fraction_one_t, ss, sine);
8634 if (number_negative(ab_vs_cd)) {
8635 number_clone (arg1, mp->st);
8637 make_fraction (ss, arg1, sine);
8644 free_number (ab_vs_cd);
8647 @ Only the simple cases remain to be handled.
8649 @<Reduce to simple case of two givens and |return|@>=
8654 n_arg (narg, mp->delta_x[0], mp->delta_y[0]);
8656 set_number_from_substraction (arg1, p->right_given, narg);
8657 n_sin_cos (arg1, mp->ct, mp->st);
8658 set_number_from_substraction (arg1, q->left_given, narg);
8659 n_sin_cos (arg1, mp->cf, mp->sf);
8660 number_negate (mp->sf);
8661 mp_set_controls (mp, p, q, 0);
8669 @ @<Reduce to simple case of straight line and |return|@>=
8671 mp_number lt, rt; /* tension values */
8672 mp_right_type (p) = mp_explicit;
8673 mp_left_type (q) = mp_explicit;
8676 number_clone (lt, q->left_tension);
8678 number_clone (rt, p->right_tension);
8680 if (number_unity(rt)) {
8683 if (number_nonnegative(mp->delta_x[0])) {
8684 set_number_from_addition (arg2, mp->delta_x[0], epsilon_t);
8686 set_number_from_substraction (arg2, mp->delta_x[0], epsilon_t);
8688 number_int_div (arg2, 3);
8689 set_number_from_addition (p->right_x, p->x_coord, arg2);
8690 if (number_nonnegative(mp->delta_y[0])) {
8691 set_number_from_addition (arg2, mp->delta_y[0], epsilon_t);
8693 set_number_from_substraction (arg2, mp->delta_y[0], epsilon_t);
8695 number_int_div (arg2, 3);
8696 set_number_from_addition (p->right_y, p->y_coord, arg2);
8702 number_clone (arg2, rt);
8703 number_multiply_int (arg2, 3);
8704 make_fraction (ff, unity_t, arg2); /* $\alpha/3$ */
8706 take_fraction (r1, mp->delta_x[0], ff);
8707 set_number_from_addition (p->right_x, p->x_coord, r1);
8708 take_fraction (r1, mp->delta_y[0], ff);
8709 set_number_from_addition (p->right_y, p->y_coord, r1);
8711 if (number_unity(lt)) {
8714 if (number_nonnegative(mp->delta_x[0])) {
8715 set_number_from_addition (arg2, mp->delta_x[0], epsilon_t);
8717 set_number_from_substraction (arg2, mp->delta_x[0], epsilon_t);
8719 number_int_div (arg2, 3);
8720 set_number_from_substraction (q->left_x, q->x_coord, arg2);
8721 if (number_nonnegative(mp->delta_y[0])) {
8722 set_number_from_addition (arg2, mp->delta_y[0], epsilon_t);
8724 set_number_from_substraction (arg2, mp->delta_y[0], epsilon_t);
8726 number_int_div (arg2, 3);
8727 set_number_from_substraction (q->left_y, q->y_coord, arg2);
8733 number_clone (arg2, lt);
8734 number_multiply_int (arg2, 3);
8735 make_fraction (ff, unity_t, arg2); /* $\beta/3$ */
8737 take_fraction (r1, mp->delta_x[0], ff);
8738 set_number_from_substraction(q->left_x, q->x_coord, r1);
8739 take_fraction (r1, mp->delta_y[0], ff);
8740 set_number_from_substraction(q->left_y, q->y_coord, r1);
8749 @ Various subroutines that are useful for the new (1.770) exported
8750 api for solving path choices
8753 #define TOO_LARGE(a) (fabs((a))>4096.0)
8754 #define PI 3.1415926535897932384626433832795028841971
8756 static int out_of_range(MP mp, double a)
8760 set_number_from_double(t,fabs(a));
8761 if (number_greaterequal(t,inf_t)) {
8769 static int mp_link_knotpair (MP mp, mp_knot p, mp_knot q);
8770 static int mp_link_knotpair (MP mp, mp_knot p, mp_knot q)
8772 if (p==NULL ||q==NULL) return 0;
8774 set_number_from_double(p->right_tension, 1.0);
8775 if (mp_right_type(p)==mp_endpoint) {
8776 mp_right_type(p) = mp_open;
8778 set_number_from_double(q->left_tension, 1.0);
8779 if (mp_left_type(q) == mp_endpoint) {
8780 mp_left_type(q) = mp_open;
8785 int mp_close_path_cycle (MP mp, mp_knot p, mp_knot q)
8787 return mp_link_knotpair(mp,p,q);
8790 int mp_close_path (MP mp, mp_knot q, mp_knot first)
8792 if (q==NULL || first==NULL) return 0;
8794 mp_right_type(q) = mp_endpoint;
8795 set_number_from_double(q->right_tension, 1.0);
8796 mp_left_type(first) = mp_endpoint;
8797 set_number_from_double(first->left_tension, 1.0);
8801 mp_knot mp_create_knot (MP mp)
8803 mp_knot q = mp_new_knot(mp);
8804 mp_left_type(q) = mp_endpoint;
8805 mp_right_type(q) = mp_endpoint;
8809 int mp_set_knot (MP mp, mp_knot p, double x, double y)
8811 if (out_of_range(mp, x)) return 0;
8812 if (out_of_range(mp, y)) return 0;
8813 if (p==NULL) return 0;
8814 set_number_from_double(p->x_coord, x);
8815 set_number_from_double(p->y_coord, y);
8819 mp_knot mp_append_knot (MP mp, mp_knot p, double x, double y)
8821 mp_knot q = mp_create_knot(mp);
8822 if (q==NULL) return NULL;
8823 if (!mp_set_knot(mp, q, x, y)) {
8827 if (p == NULL) return q;
8828 if (!mp_link_knotpair(mp, p,q)) {
8835 int mp_set_knot_curl (MP mp, mp_knot q, double value) {
8836 if (q==NULL) return 0;
8837 if (TOO_LARGE(value)) return 0;
8838 mp_right_type(q)=mp_curl;
8839 set_number_from_double(q->right_curl, value);
8840 if (mp_left_type(q)==mp_open) {
8841 mp_left_type(q)=mp_curl;
8842 set_number_from_double(q->left_curl, value);
8847 int mp_set_knot_left_curl (MP mp, mp_knot q, double value) {
8848 if (q==NULL) return 0;
8849 if (TOO_LARGE(value)) return 0;
8850 mp_left_type(q)=mp_curl;
8851 set_number_from_double(q->left_curl, value);
8852 if (mp_right_type(q)==mp_open) {
8853 mp_right_type(q)=mp_curl;
8854 set_number_from_double(q->right_curl, value);
8859 int mp_set_knot_right_curl (MP mp, mp_knot q, double value) {
8860 if (q==NULL) return 0;
8861 if (TOO_LARGE(value)) return 0;
8862 mp_right_type(q)=mp_curl;
8863 set_number_from_double(q->right_curl, value);
8864 if (mp_left_type(q)==mp_open) {
8865 mp_left_type(q)=mp_curl;
8866 set_number_from_double(q->left_curl, value);
8871 int mp_set_knotpair_curls (MP mp, mp_knot p, mp_knot q, double t1, double t2) {
8872 if (p==NULL || q==NULL) return 0;
8873 if (mp_set_knot_curl(mp, p, t1))
8874 return mp_set_knot_curl(mp, q, t2);
8878 int mp_set_knotpair_tensions (MP mp, mp_knot p, mp_knot q, double t1, double t2) {
8879 if (p==NULL || q==NULL) return 0;
8880 if (TOO_LARGE(t1)) return 0;
8881 if (TOO_LARGE(t2)) return 0;
8882 if ((fabs(t1)<0.75)) return 0;
8883 if ((fabs(t2)<0.75)) return 0;
8884 set_number_from_double(p->right_tension, t1);
8885 set_number_from_double(q->left_tension, t2);
8889 int mp_set_knot_left_tension (MP mp, mp_knot p, double t1) {
8890 if (p==NULL) return 0;
8891 if (TOO_LARGE(t1)) return 0;
8892 if ((fabs(t1)<0.75)) return 0;
8893 set_number_from_double(p->left_tension, t1);
8897 int mp_set_knot_right_tension (MP mp, mp_knot p, double t1) {
8898 if (p==NULL) return 0;
8899 if (TOO_LARGE(t1)) return 0;
8900 if ((fabs(t1)<0.75)) return 0;
8901 set_number_from_double(p->right_tension, t1);
8905 int mp_set_knotpair_controls (MP mp, mp_knot p, mp_knot q, double x1, double y1, double x2, double y2) {
8906 if (p==NULL || q==NULL) return 0;
8907 if (out_of_range(mp, x1)) return 0;
8908 if (out_of_range(mp, y1)) return 0;
8909 if (out_of_range(mp, x2)) return 0;
8910 if (out_of_range(mp, y2)) return 0;
8911 mp_right_type(p)=mp_explicit;
8912 set_number_from_double(p->right_x, x1);
8913 set_number_from_double(p->right_y, y1);
8914 mp_left_type(q)=mp_explicit;
8915 set_number_from_double(q->left_x, x2);
8916 set_number_from_double(q->left_y, y2);
8920 int mp_set_knot_left_control (MP mp, mp_knot p, double x1, double y1) {
8921 if (p==NULL) return 0;
8922 if (out_of_range(mp, x1)) return 0;
8923 if (out_of_range(mp, y1)) return 0;
8924 mp_left_type(p)=mp_explicit;
8925 set_number_from_double(p->left_x, x1);
8926 set_number_from_double(p->left_y, y1);
8930 int mp_set_knot_right_control (MP mp, mp_knot p, double x1, double y1) {
8931 if (p==NULL) return 0;
8932 if (out_of_range(mp, x1)) return 0;
8933 if (out_of_range(mp, y1)) return 0;
8934 mp_right_type(p)=mp_explicit;
8935 set_number_from_double(p->right_x, x1);
8936 set_number_from_double(p->right_y, y1);
8940 int mp_set_knot_direction (MP mp, mp_knot q, double x, double y) {
8942 if (q==NULL) return 0;
8943 if (TOO_LARGE(x)) return 0;
8944 if (TOO_LARGE(y)) return 0;
8945 if (!(x==0 && y == 0))
8946 value = atan2 (y, x) * (180.0 / PI) * 16.0;
8947 mp_right_type(q)=mp_given;
8948 set_number_from_double(q->right_curl, value);
8949 if (mp_left_type(q)==mp_open) {
8950 mp_left_type(q)=mp_given;
8951 set_number_from_double(q->left_curl, value);
8956 int mp_set_knotpair_directions (MP mp, mp_knot p, mp_knot q, double x1, double y1, double x2, double y2) {
8957 if (p==NULL || q==NULL) return 0;
8958 if (mp_set_knot_direction(mp,p, x1, y1))
8959 return mp_set_knot_direction(mp,q, x2, y2);
8965 static int path_needs_fixing (mp_knot source);
8966 static int path_needs_fixing (mp_knot source) {
8967 mp_knot sourcehead = source;
8969 source = source->next;
8970 } while (source && source != sourcehead);
8977 int mp_solve_path (MP mp, mp_knot first)
8979 int saved_arith_error = mp->arith_error;
8980 jmp_buf *saved_jump_buf = mp->jump_buf;
8982 if (first==NULL) return 0;
8983 if (path_needs_fixing(first)) return 0;
8984 mp->jump_buf = malloc(sizeof(jmp_buf));
8985 if (mp->jump_buf == NULL || setjmp(*(mp->jump_buf)) != 0) {
8988 mp->arith_error = 0;
8989 mp_make_choices(mp, first);
8990 if (mp->arith_error)
8992 mp->arith_error = saved_arith_error;
8994 mp->jump_buf = saved_jump_buf;
8998 void mp_free_path (MP mp, mp_knot p) {
8999 mp_toss_knot_list(mp, p);
9002 @ @<Exported function headers@>=
9003 int mp_close_path_cycle (MP mp, mp_knot p, mp_knot q);
9004 int mp_close_path (MP mp, mp_knot q, mp_knot first);
9005 mp_knot mp_create_knot (MP mp);
9006 int mp_set_knot (MP mp, mp_knot p, double x, double y);
9007 mp_knot mp_append_knot (MP mp, mp_knot p, double x, double y);
9008 int mp_set_knot_curl (MP mp, mp_knot q, double value);
9009 int mp_set_knot_left_curl (MP mp, mp_knot q, double value);
9010 int mp_set_knot_right_curl (MP mp, mp_knot q, double value);
9011 int mp_set_knotpair_curls (MP mp, mp_knot p, mp_knot q, double t1, double t2) ;
9012 int mp_set_knotpair_tensions (MP mp, mp_knot p, mp_knot q, double t1, double t2) ;
9013 int mp_set_knot_left_tension (MP mp, mp_knot p, double t1);
9014 int mp_set_knot_right_tension (MP mp, mp_knot p, double t1);
9015 int mp_set_knot_left_control (MP mp, mp_knot p, double t1, double t2);
9016 int mp_set_knot_right_control (MP mp, mp_knot p, double t1, double t2);
9017 int mp_set_knotpair_controls (MP mp, mp_knot p, mp_knot q, double x1, double y1, double x2, double y2) ;
9018 int mp_set_knot_direction (MP mp, mp_knot q, double x, double y) ;
9019 int mp_set_knotpair_directions (MP mp, mp_knot p, mp_knot q, double x1, double y1, double x2, double y2) ;
9020 int mp_solve_path (MP mp, mp_knot first);
9021 void mp_free_path (MP mp, mp_knot p);
9023 @ Simple accessors for |mp_knot|.
9026 mp_number mp_knot_x_coord(MP mp, mp_knot p) { return p->x_coord; }
9027 mp_number mp_knot_y_coord(MP mp, mp_knot p) { return p->y_coord; }
9028 mp_number mp_knot_left_x (MP mp, mp_knot p) { return p->left_x; }
9029 mp_number mp_knot_left_y (MP mp, mp_knot p) { return p->left_y; }
9030 mp_number mp_knot_right_x(MP mp, mp_knot p) { return p->right_x; }
9031 mp_number mp_knot_right_y(MP mp, mp_knot p) { return p->right_y; }
9032 int mp_knot_right_type(MP mp, mp_knot p) { return mp_right_type(p);}
9033 int mp_knot_left_type (MP mp, mp_knot p) { return mp_left_type(p);}
9034 mp_knot mp_knot_next (MP mp, mp_knot p) { return p->next; }
9035 double mp_number_as_double(MP mp, mp_number n) {
9036 return number_to_double(n);
9039 @ @<Exported function headers@>=
9040 #define mp_knot_left_curl mp_knot_left_x
9041 #define mp_knot_left_given mp_knot_left_x
9042 #define mp_knot_left_tension mp_knot_left_y
9043 #define mp_knot_right_curl mp_knot_right_x
9044 #define mp_knot_right_given mp_knot_right_x
9045 #define mp_knot_right_tension mp_knot_right_y
9046 mp_number mp_knot_x_coord(MP mp, mp_knot p);
9047 mp_number mp_knot_y_coord(MP mp, mp_knot p);
9048 mp_number mp_knot_left_x(MP mp, mp_knot p);
9049 mp_number mp_knot_left_y(MP mp, mp_knot p);
9050 mp_number mp_knot_right_x(MP mp, mp_knot p);
9051 mp_number mp_knot_right_y(MP mp, mp_knot p);
9052 int mp_knot_right_type(MP mp, mp_knot p);
9053 int mp_knot_left_type(MP mp, mp_knot p);
9054 mp_knot mp_knot_next(MP mp, mp_knot p);
9055 double mp_number_as_double(MP mp, mp_number n);
9059 \MP's \&{llcorner}, \&{lrcorner}, \&{ulcorner}, and \&{urcorner} operators
9060 allow the user to measure the bounding box of anything that can go into a
9061 picture. It's easy to get rough bounds on the $x$ and $y$ extent of a path
9062 by just finding the bounding box of the knots and the control points. We
9063 need a more accurate version of the bounding box, but we can still use the
9064 easy estimate to save time by focusing on the interesting parts of the path.
9066 @ Computing an accurate bounding box involves a theme that will come up again
9067 and again. Given a Bernshte{\u\i}n polynomial
9068 @^Bernshte{\u\i}n, Serge{\u\i} Natanovich@>
9069 $$B(z_0,z_1,\ldots,z_n;t)=\sum_k{n\choose k}t^k(1-t)^{n-k}z_k,$$
9070 we can conveniently bisect its range as follows:
9073 \textindent{1)} Let $z_k^{(0)}=z_k$, for |0<=k<=n|.
9076 \textindent{2)} Let $z_k^{(j+1)}={1\over2}(z_k^{(j)}+z\k^{(j)})$, for
9077 |0<=k<n-j|, for |0<=j<n|.
9081 $$B(z_0,z_1,\ldots,z_n;t)=B(z_0^{(0)},z_0^{(1)},\ldots,z_0^{(n)};2t)
9082 =B(z_0^{(n)},z_1^{(n-1)},\ldots,z_n^{(0)};2t-1).$$
9083 This formula gives us the coefficients of polynomials to use over the ranges
9084 $0\L t\L{1\over2}$ and ${1\over2}\L t\L1$.
9086 @ Here is a routine that computes the $x$ or $y$ coordinate of the point on
9087 a cubic corresponding to the |fraction| value~|t|.
9090 static void mp_eval_cubic (MP mp, mp_number *r, mp_knot p, mp_knot q, quarterword c,
9092 mp_number x1, x2, x3; /* intermediate values */
9096 if (c == mp_x_code) {
9097 set_number_from_of_the_way(x1, t, p->x_coord, p->right_x);
9098 set_number_from_of_the_way(x2, t, p->right_x, q->left_x);
9099 set_number_from_of_the_way(x3, t, q->left_x, q->x_coord);
9101 set_number_from_of_the_way(x1, t, p->y_coord, p->right_y);
9102 set_number_from_of_the_way(x2, t, p->right_y, q->left_y);
9103 set_number_from_of_the_way(x3, t, q->left_y, q->y_coord);
9105 set_number_from_of_the_way(x1, t, x1, x2);
9106 set_number_from_of_the_way(x2, t, x2, x3);
9107 set_number_from_of_the_way(*r, t, x1, x2);
9114 @ The actual bounding box information is stored in global variables.
9115 Since it is convenient to address the $x$ and $y$ information
9116 separately, we define arrays indexed by |x_code..y_code| and use
9117 macros to give them more convenient names.
9121 mp_x_code = 0, /* index for |minx| and |maxx| */
9122 mp_y_code /* index for |miny| and |maxy| */
9126 @d mp_minx mp->bbmin[mp_x_code]
9127 @d mp_maxx mp->bbmax[mp_x_code]
9128 @d mp_miny mp->bbmin[mp_y_code]
9129 @d mp_maxy mp->bbmax[mp_y_code]
9132 mp_number bbmin[mp_y_code + 1];
9133 mp_number bbmax[mp_y_code + 1];
9134 /* the result of procedures that compute bounding box information */
9136 @ @<Initialize table ...@>=
9139 for (i=0;i<=mp_y_code;i++) {
9140 new_number(mp->bbmin[i]);
9141 new_number(mp->bbmax[i]);
9148 for (i=0;i<=mp_y_code;i++) {
9149 free_number(mp->bbmin[i]);
9150 free_number(mp->bbmax[i]);
9155 @ Now we're ready for the key part of the bounding box computation.
9156 The |bound_cubic| procedure updates |bbmin[c]| and |bbmax[c]| based on
9157 $$B(\hbox{|knot_coord(p)|}, \hbox{|right_coord(p)|},
9158 \hbox{|left_coord(q)|}, \hbox{|knot_coord(q)|};t)
9160 for $0<t\le1$. In other words, the procedure adjusts the bounds to
9161 accommodate |knot_coord(q)| and any extremes over the range $0<t<1$.
9162 The |c| parameter is |x_code| or |y_code|.
9165 static void mp_bound_cubic (MP mp, mp_knot p, mp_knot q, quarterword c) {
9166 boolean wavy; /* whether we need to look for extremes */
9167 mp_number del1, del2, del3, del, dmax; /* proportional to the control
9168 points of a quadratic derived from a cubic */
9169 mp_number t, tt; /* where a quadratic crosses zero */
9170 mp_number x; /* a value that |bbmin[c]| and |bbmax[c]| must accommodate */
9174 if (c == mp_x_code) {
9175 number_clone(x, q->x_coord);
9177 number_clone(x, q->y_coord);
9184 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
9185 @<Check the control points against the bounding box and set |wavy:=true|
9186 if any of them lie outside@>;
9188 if (c == mp_x_code) {
9189 set_number_from_substraction(del1, p->right_x, p->x_coord);
9190 set_number_from_substraction(del2, q->left_x, p->right_x);
9191 set_number_from_substraction(del3, q->x_coord, q->left_x);
9193 set_number_from_substraction(del1, p->right_y, p->y_coord);
9194 set_number_from_substraction(del2, q->left_y, p->right_y);
9195 set_number_from_substraction(del3, q->y_coord, q->left_y);
9197 @<Scale up |del1|, |del2|, and |del3| for greater accuracy;
9198 also set |del| to the first nonzero element of |(del1,del2,del3)|@>;
9199 if (number_negative(del)) {
9200 number_negate (del1);
9201 number_negate (del2);
9202 number_negate (del3);
9204 crossing_point (t, del1, del2, del3);
9205 if (number_less(t, fraction_one_t)) {
9206 @<Test the extremes of the cubic against the bounding box@>;
9220 @ @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>=
9221 if (number_less(x, mp->bbmin[c]))
9222 number_clone(mp->bbmin[c], x);
9223 if (number_greater(x, mp->bbmax[c]))
9224 number_clone(mp->bbmax[c], x)
9226 @ @<Check the control points against the bounding box and set...@>=
9228 if (c == mp_x_code) {
9229 if (number_lessequal(mp->bbmin[c], p->right_x))
9230 if (number_lessequal (p->right_x, mp->bbmax[c]))
9231 if (number_lessequal(mp->bbmin[c], q->left_x))
9232 if (number_lessequal (q->left_x, mp->bbmax[c]))
9235 if (number_lessequal(mp->bbmin[c], p->right_y))
9236 if (number_lessequal (p->right_y, mp->bbmax[c]))
9237 if (number_lessequal(mp->bbmin[c], q->left_y))
9238 if (number_lessequal (q->left_y, mp->bbmax[c]))
9243 @ If |del1=del2=del3=0|, it's impossible to obey the title of this
9244 section. We just set |del=0| in that case.
9246 @<Scale up |del1|, |del2|, and |del3| for greater accuracy...@>=
9247 if (number_nonzero(del1)) {
9248 number_clone (del, del1);
9249 } else if (number_nonzero(del2)) {
9250 number_clone (del, del2);
9252 number_clone (del, del3);
9254 if (number_nonzero(del)) {
9256 new_number(absval1);
9257 number_clone (dmax, del1);
9259 number_clone (absval1, del2);
9260 number_abs(absval1);
9261 if (number_greater(absval1, dmax)) {
9262 number_clone(dmax, absval1);
9264 number_clone (absval1, del3);
9265 number_abs(absval1);
9266 if (number_greater(absval1, dmax)) {
9267 number_clone(dmax, absval1);
9269 while (number_less(dmax, fraction_half_t)) {
9270 number_double(dmax);
9271 number_double(del1);
9272 number_double(del2);
9273 number_double(del3);
9275 free_number (absval1);
9278 @ Since |crossing_point| has tried to choose |t| so that
9279 $B(|del1|,|del2|,|del3|;\tau)$ crosses zero at $\tau=|t|$ with negative
9280 slope, the value of |del2| computed below should not be positive.
9281 But rounding error could make it slightly positive in which case we
9282 must cut it to zero to avoid confusion.
9284 @<Test the extremes of the cubic against the bounding box@>=
9286 mp_eval_cubic (mp, &x, p, q, c, t);
9287 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
9288 set_number_from_of_the_way(del2, t, del2, del3);
9289 /* now |0,del2,del3| represent the derivative on the remaining interval */
9290 if (number_positive(del2))
9291 set_number_to_zero(del2);
9293 mp_number arg2, arg3;
9296 number_clone(arg2, del2);
9297 number_negate(arg2);
9298 number_clone(arg3, del3);
9299 number_negate(arg3);
9300 crossing_point (tt, zero_t, arg2, arg3);
9304 if (number_less(tt, fraction_one_t)) {
9305 @<Test the second extreme against the bounding box@>;
9310 @ @<Test the second extreme against the bounding box@>=
9314 set_number_from_of_the_way (arg, t, tt, fraction_one_t);
9315 mp_eval_cubic (mp, &x, p, q, c, arg);
9317 @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>;
9321 @ Finding the bounding box of a path is basically a matter of applying
9322 |bound_cubic| twice for each pair of adjacent knots.
9325 static void mp_path_bbox (MP mp, mp_knot h) {
9326 mp_knot p, q; /* a pair of adjacent knots */
9327 number_clone(mp_minx, h->x_coord);
9328 number_clone(mp_miny, h->y_coord);
9329 number_clone (mp_maxx, mp_minx);
9330 number_clone (mp_maxy, mp_miny);
9333 if (mp_right_type (p) == mp_endpoint)
9335 q = mp_next_knot (p);
9336 mp_bound_cubic (mp, p, q, mp_x_code);
9337 mp_bound_cubic (mp, p, q, mp_y_code);
9343 @ Another important way to measure a path is to find its arc length. This
9344 is best done by using the general bisection algorithm to subdivide the path
9345 until obtaining ``well behaved'' subpaths whose arc lengths can be approximated
9348 Since the arc length is the integral with respect to time of the magnitude of
9349 the velocity, it is natural to use Simpson's rule for the approximation.
9351 If $\dot B(t)$ is the spline velocity, Simpson's rule gives
9352 $$ \vb\dot B(0)\vb + 4\vb\dot B({1\over2})\vb + \vb\dot B(1)\vb \over 6 $$
9353 for the arc length of a path of length~1. For a cubic spline
9354 $B(z_0,z_1,z_2,z_3;t)$, the time derivative $\dot B(t)$ is
9355 $3B(dz_0,dz_1,dz_2;t)$, where $dz_i=z_{i+1}-z_i$. Hence the arc length
9357 $$ {\vb dz_0\vb \over 2} + 2\vb dz_{02}\vb + {\vb dz_2\vb \over 2}, $$
9359 $$ dz_{02}={1\over2}\left({dz_0+dz_1\over 2}+{dz_1+dz_2\over 2}\right)$$
9360 is the result of the bisection algorithm.
9362 @ The remaining problem is how to decide when a subpath is ``well behaved.''
9363 This could be done via the theoretical error bound for Simpson's rule,
9365 but this is impractical because it requires an estimate of the fourth
9366 derivative of the quantity being integrated. It is much easier to just perform
9367 a bisection step and see how much the arc length estimate changes. Since the
9368 error for Simpson's rule is proportional to the fourth power of the sample
9369 spacing, the remaining error is typically about $1\over16$ of the amount of
9370 the change. We say ``typically'' because the error has a pseudo-random behavior
9371 that could cause the two estimates to agree when each contain large errors.
9373 To protect against disasters such as undetected cusps, the bisection process
9374 should always continue until all the $dz_i$ vectors belong to a single
9375 $90^\circ$ sector. This ensures that no point on the spline can have velocity
9376 less than 70\% of the minimum of $\vb dz_0\vb$, $\vb dz_1\vb$ and $\vb dz_2\vb$.
9377 If such a spline happens to produce an erroneous arc length estimate that
9378 is little changed by bisection, the amount of the error is likely to be fairly
9379 small. We will try to arrange things so that freak accidents of this type do
9380 not destroy the inverse relationship between the \&{arclength} and
9381 \&{arctime} operations.
9382 @:arclength_}{\&{arclength} primitive@>
9383 @:arctime_}{\&{arctime} primitive@>
9385 @ The \&{arclength} and \&{arctime} operations are both based on a recursive
9387 function that finds the arc length of a cubic spline given $dz_0$, $dz_1$,
9388 $dz_2$. This |arc_test| routine also takes an arc length goal |a_goal| and
9389 returns the time when the arc length reaches |a_goal| if there is such a time.
9390 Thus the return value is either an arc length less than |a_goal| or, if the
9391 arc length would be at least |a_goal|, it returns a time value decreased by
9392 |two|. This allows the caller to use the sign of the result to distinguish
9393 between arc lengths and time values. On certain types of overflow, it is
9394 possible for |a_goal| and the result of |arc_test| both to be |EL_GORDO|.
9395 Otherwise, the result is always less than |a_goal|.
9397 Rather than halving the control point coordinates on each recursive call to
9398 |arc_test|, it is better to keep them proportional to velocity on the original
9399 curve and halve the results instead. This means that recursive calls can
9400 potentially use larger error tolerances in their arc length estimates. How
9401 much larger depends on to what extent the errors behave as though they are
9402 independent of each other. To save computing time, we use optimistic assumptions
9403 and increase the tolerance by a factor of about $\sqrt2$ for each recursive
9406 In addition to the tolerance parameter, |arc_test| should also have parameters
9407 for ${1\over3}\vb\dot B(0)\vb$, ${2\over3}\vb\dot B({1\over2})\vb$, and
9408 ${1\over3}\vb\dot B(1)\vb$. These quantities are relatively expensive to compute
9409 and they are needed in different instances of |arc_test|.
9412 static void mp_arc_test (MP mp, mp_number *ret, mp_number dx0, mp_number dy0, mp_number dx1,
9413 mp_number dy1, mp_number dx2, mp_number dy2, mp_number v0,
9414 mp_number v02, mp_number v2, mp_number a_goal, mp_number tol_orig) {
9415 boolean simple; /* are the control points confined to a $90^\circ$ sector? */
9416 mp_number dx01, dy01, dx12, dy12, dx02, dy02; /* bisection results */
9417 mp_number v002, v022; /* twice the velocity magnitudes at $t={1\over4}$ and $t={3\over4}$ */
9418 mp_number arc; /* best arc length estimate before recursion */
9419 mp_number arc1; /* arc length estimate for the first half */
9432 new_number (simply);
9434 number_clone(tol, tol_orig);
9435 @<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,
9437 @<Initialize |v002|, |v022|, and the arc length estimate |arc|; if it overflows
9438 set |arc_test| and |return|@>;
9439 @<Test if the control points are confined to one quadrant or rotating them
9440 $45^\circ$ would put them in one quadrant. Then set |simple| appropriately@>;
9442 set_number_from_addition(simply, v0, v2);
9443 number_halfp (simply);
9444 number_negate (simply);
9445 number_add (simply, arc);
9446 number_substract (simply, v02);
9447 number_abs (simply);
9449 if (simple && number_lessequal(simply, tol)) {
9450 if (number_less(arc, a_goal)){
9451 number_clone(*ret, arc);
9453 @<Estimate when the arc length reaches |a_goal| and set |arc_test| to
9454 that time minus |two|@>;
9457 @<Use one or two recursive calls to compute the |arc_test| function@>;
9470 free_number (simply);
9475 @ The |tol| value should by multiplied by $\sqrt 2$ before making recursive
9476 calls, but $1.5$ is an adequate approximation. It is best to avoid using
9477 |make_fraction| in this inner loop.
9480 @<Use one or two recursive calls to compute the |arc_test| function@>=
9482 mp_number a_new, a_aux; /* the sum of these gives the |a_goal| */
9483 mp_number a, b; /* results of recursive calls */
9484 mp_number half_v02; /* |halfp(v02)|, a recursion argument */
9487 new_number(half_v02);
9488 @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is as
9489 large as possible@>;
9491 mp_number halfp_tol;
9492 new_number(halfp_tol);
9493 number_clone (halfp_tol, tol);
9494 number_halfp (halfp_tol);
9495 number_add(tol, halfp_tol);
9496 free_number (halfp_tol);
9498 number_clone(half_v02, v02);
9499 number_halfp(half_v02);
9501 mp_arc_test (mp, &a, dx0, dy0, dx01, dy01, dx02, dy02,
9502 v0, v002, half_v02, a_new, tol);
9503 if (number_negative(a)) {
9504 set_number_to_unity(*ret);
9505 number_double(*ret); /* two */
9506 number_substract(*ret, a); /* two - a */
9508 number_negate(*ret); /* -halfp(two - a) */
9510 @<Update |a_new| to reduce |a_new+a_aux| by |a|@>;
9512 mp_arc_test (mp, &b, dx02, dy02, dx12, dy12, dx2, dy2,
9513 half_v02, v022, v2, a_new, tol);
9514 if (number_negative(b)) {
9517 number_clone(tmp, b);
9521 number_clone(*ret, tmp);
9522 set_number_to_unity(tmp);
9524 number_substract(*ret, tmp); /* (-(halfp(-b)) - 1/2) */
9527 set_number_from_substraction(*ret, b, a);
9529 set_number_from_addition(*ret, a, *ret); /* (a + half(b - a)) */
9533 free_number (half_v02);
9534 free_number (a_aux);
9535 free_number (a_new);
9541 @ @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is...@>=
9542 set_number_to_inf(a_aux);
9543 number_substract(a_aux, a_goal);
9544 if (number_greater(a_goal, a_aux)) {
9545 set_number_from_substraction(a_aux, a_goal, a_aux);
9546 set_number_to_inf(a_new);
9548 set_number_from_addition(a_new, a_goal, a_goal);
9549 set_number_to_zero(a_aux);
9553 @ There is no need to maintain |a_aux| at this point so we use it as a temporary
9554 to force the additions and subtractions to be done in an order that avoids
9557 @<Update |a_new| to reduce |a_new+a_aux| by |a|@>=
9558 if (number_greater(a, a_aux)) {
9559 number_substract(a_aux, a);
9560 number_add(a_new, a_aux);
9563 @ This code assumes all {\it dx} and {\it dy} variables have magnitude less than
9564 |fraction_four|. To simplify the rest of the |arc_test| routine, we strengthen
9565 this assumption by requiring the norm of each $({\it dx},{\it dy})$ pair to obey
9566 this bound. Note that recursive calls will maintain this invariant.
9568 @<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,...@>=
9569 set_number_from_addition(dx01, dx0, dx1);
9571 set_number_from_addition(dx12, dx1, dx2);
9573 set_number_from_addition(dx02, dx01, dx12);
9575 set_number_from_addition(dy01, dy0, dy1);
9577 set_number_from_addition(dy12, dy1, dy2);
9579 set_number_from_addition(dy02, dy01, dy12);
9582 @ We should be careful to keep |arc<EL_GORDO| so that calling |arc_test| with
9583 |a_goal=EL_GORDO| is guaranteed to yield the arc length.
9585 @<Initialize |v002|, |v022|, and the arc length estimate |arc|;...@>=
9587 mp_number tmp, arg1, arg2 ;
9591 set_number_from_addition(arg1, dx0, dx02);
9593 number_add(arg1, dx01);
9594 set_number_from_addition(arg2, dy0, dy02);
9596 number_add(arg2, dy01);
9597 pyth_add (v002, arg1, arg2);
9599 set_number_from_addition(arg1, dx02, dx2);
9601 number_add(arg1, dx12);
9602 set_number_from_addition(arg2, dy02, dy2);
9604 number_add(arg2, dy12);
9605 pyth_add (v022, arg1, arg2);
9609 number_clone (tmp, v02);
9610 number_add_scaled (tmp, 2);
9613 set_number_from_addition(arc1, v0, tmp);
9614 number_halfp (arc1);
9615 number_substract (arc1, v002);
9617 set_number_from_addition(arc1, v002, arc1);
9619 set_number_from_addition(arc, v2, tmp);
9621 number_substract (arc, v022);
9623 set_number_from_addition(arc, v022, arc);
9625 /* reuse |tmp| for the next |if| test: */
9626 set_number_to_inf(tmp);
9627 number_substract(tmp,arc1);
9628 if (number_less(arc, tmp)) {
9630 number_add(arc, arc1);
9633 mp->arith_error = true;
9634 if (number_infinite(a_goal)) {
9635 set_number_to_inf(*ret);
9637 set_number_to_unity(*ret);
9638 number_double(*ret);
9639 number_negate(*ret); /* -two */
9646 @ @<Test if the control points are confined to one quadrant or rotating...@>=
9647 simple = ((number_nonnegative(dx0) && number_nonnegative(dx1) && number_nonnegative(dx2)) ||
9648 (number_nonpositive(dx0) && number_nonpositive(dx1) && number_nonpositive(dx2)));
9650 simple = (number_nonnegative(dy0) && number_nonnegative(dy1) && number_nonnegative(dy2)) ||
9651 (number_nonpositive(dy0) && number_nonpositive(dy1) && number_nonpositive(dy2));
9654 simple = (number_greaterequal(dx0, dy0) && number_greaterequal(dx1, dy1) && number_greaterequal(dx2, dy2)) ||
9655 (number_lessequal(dx0, dy0) && number_lessequal(dx1, dy1) && number_lessequal(dx2, dy2));
9657 mp_number neg_dx0, neg_dx1, neg_dx2;
9658 new_number(neg_dx0);
9659 new_number(neg_dx1);
9660 new_number(neg_dx2);
9661 number_clone(neg_dx0, dx0);
9662 number_clone(neg_dx1, dx1);
9663 number_clone(neg_dx2, dx2);
9664 number_negate(neg_dx0);
9665 number_negate(neg_dx1);
9666 number_negate(neg_dx2);
9668 (number_greaterequal(neg_dx0, dy0) && number_greaterequal(neg_dx1, dy1) && number_greaterequal(neg_dx2, dy2)) ||
9669 (number_lessequal(neg_dx0, dy0) && number_lessequal(neg_dx1, dy1) && number_lessequal(neg_dx2, dy2));
9670 free_number (neg_dx0);
9671 free_number (neg_dx1);
9672 free_number (neg_dx2);
9676 @ Since Simpson's rule is based on approximating the integrand by a parabola,
9678 it is appropriate to use the same approximation to decide when the integral
9679 reaches the intermediate value |a_goal|. At this point
9681 {\vb\dot B(0)\vb\over 3} &= \hbox{|v0|}, \qquad
9682 {\vb\dot B({1\over4})\vb\over 3} = {\hbox{|v002|}\over 2}, \qquad
9683 {\vb\dot B({1\over2})\vb\over 3} = {\hbox{|v02|}\over 2}, \cr
9684 {\vb\dot B({3\over4})\vb\over 3} &= {\hbox{|v022|}\over 2}, \qquad
9685 {\vb\dot B(1)\vb\over 3} = \hbox{|v2|} \cr
9689 $$ {\vb\dot B(t)\vb\over 3} \approx
9690 \cases{B\left(\hbox{|v0|},
9691 \hbox{|v002|}-{1\over 2}\hbox{|v0|}-{1\over 4}\hbox{|v02|},
9692 {1\over 2}\hbox{|v02|}; 2t \right)&
9693 if $t\le{1\over 2}$\cr
9694 B\left({1\over 2}\hbox{|v02|},
9695 \hbox{|v022|}-{1\over 4}\hbox{|v02|}-{1\over 2}\hbox{|v2|},
9696 \hbox{|v2|}; 2t-1 \right)&
9697 if $t\ge{1\over 2}$.\cr}
9700 We can integrate $\vb\dot B(t)\vb$ by using
9701 $$\int 3B(a,b,c;\tau)\,dt =
9702 {B(0,a,a+b,a+b+c;\tau) + {\rm constant} \over {d\tau\over dt}}.
9705 This construction allows us to find the time when the arc length reaches
9706 |a_goal| by solving a cubic equation of the form
9707 $$ B(0,a,a+b,a+b+c;\tau) = x, $$
9708 where $\tau$ is $2t$ or $2t+1$, $x$ is |a_goal| or |a_goal-arc1|, and $a$, $b$,
9709 and $c$ are the Bernshte{\u\i}n coefficients from $(*)$ divided by
9710 @^Bernshte{\u\i}n, Serge{\u\i} Natanovich@>
9711 $d\tau\over dt$. We shall define a function |solve_rising_cubic| that finds
9712 $\tau$ given $a$, $b$, $c$, and $x$.
9714 @<Estimate when the arc length reaches |a_goal| and set |arc_test| to...@>=
9726 number_clone(tmp, v02);
9727 number_add_scaled(tmp, 2);
9729 number_half(tmp); /* (v02+2) / 4 */
9730 if (number_lessequal(a_goal, arc1)) {
9731 number_clone(tmp2, v0);
9733 set_number_from_substraction(tmp3, arc1, tmp2);
9734 number_substract(tmp3, tmp);
9735 mp_solve_rising_cubic (mp, &tmp5, tmp2, tmp3, tmp, a_goal);
9736 number_halfp (tmp5);
9737 set_number_to_unity(tmp3);
9738 number_substract(tmp5, tmp3);
9739 number_substract(tmp5, tmp3);
9740 number_clone(*ret, tmp5);
9742 number_clone(tmp2, v2);
9744 set_number_from_substraction(tmp3, arc, arc1);
9745 number_substract(tmp3, tmp);
9746 number_substract(tmp3, tmp2);
9747 set_number_from_substraction(tmp4, a_goal, arc1);
9748 mp_solve_rising_cubic (mp, &tmp5, tmp, tmp3, tmp2, tmp4);
9750 set_number_to_unity(tmp2);
9751 set_number_to_unity(tmp3);
9753 number_substract(tmp2, tmp3);
9754 number_substract(tmp2, tmp3);
9755 set_number_from_addition(*ret, tmp2, tmp5);
9766 @ Here is the |solve_rising_cubic| routine that finds the time~$t$ when
9767 $$ B(0, a, a+b, a+b+c; t) = x. $$
9768 This routine is based on |crossing_point| but is simplified by the
9769 assumptions that $B(a,b,c;t)\ge0$ for $0\le t\le1$ and that |0<=x<=a+b+c|.
9770 If rounding error causes this condition to be violated slightly, we just ignore
9771 it and proceed with binary search. This finds a time when the function value
9772 reaches |x| and the slope is positive.
9775 static void mp_solve_rising_cubic (MP mp, mp_number *ret, mp_number a, mp_number b, mp_number c, mp_number x);
9778 void mp_solve_rising_cubic (MP mp, mp_number *ret, mp_number a_orig, mp_number b_orig, mp_number c_orig, mp_number x_orig) {
9780 mp_number a, b, c, x; /* local versions of arguments */
9781 mp_number ab, bc, ac; /* bisection results */
9782 mp_number t; /* $2^k+q$ where unscaled answer is in $[q2^{-k},(q+1)2^{-k})$ */
9783 mp_number xx; /* temporary for updating |x| */
9784 mp_number neg_x; /* temporary for an |if| */
9785 if (number_negative(a_orig) || number_negative(c_orig))
9786 mp_confusion (mp, "rising?
");
9787 @:this can't happen rising?}{\quad rising?@>;
9794 number_clone(a, a_orig);
9795 number_clone(b, b_orig);
9796 number_clone(c, c_orig);
9797 number_clone(x, x_orig);
9803 set_number_from_addition(abc, a, b);
9805 if (number_nonpositive(x)) {
9806 set_number_to_zero(*ret);
9807 } else if (number_greaterequal(x, abc)) {
9808 set_number_to_unity(*ret);
9810 number_clone (t, epsilon_t);
9811 @<Rescale if necessary to make sure |a|, |b|, and |c| are all less than
9815 @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>;
9817 number_substract(xx, a);
9818 number_substract(xx, ab);
9819 number_substract(xx, ac);
9820 number_clone(neg_x, x);
9821 number_negate(neg_x);
9822 if (number_less(xx, neg_x)) {
9824 number_clone(b, ab);
9825 number_clone(c, ac);
9828 number_clone(a, ac);
9829 number_clone(b, bc);
9830 number_add (t, epsilon_t);
9832 } while (number_less (t, unity_t));
9833 set_number_from_substraction(*ret, t, unity_t);
9845 free_number (neg_x);
9849 @ @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>=
9850 set_number_from_addition(ab, a, b);
9852 set_number_from_addition(bc, b, c);
9854 set_number_from_addition(ac, ab, bc);
9857 @ The upper bound on |a|, |b|, and |c|:
9859 @d one_third_inf_t ((math_data *)mp->math)->one_third_inf_t
9861 @<Rescale if necessary to make sure |a|, |b|, and |c| are all less than...@>=
9862 while (number_greater(a, one_third_inf_t) ||
9863 number_greater(b, one_third_inf_t) ||
9864 number_greater(c, one_third_inf_t)) {
9872 @ It is convenient to have a simpler interface to |arc_test| that requires no
9873 unnecessary arguments and ensures that each $({\it dx},{\it dy})$ pair has
9874 length less than |fraction_four|.
9877 static void mp_do_arc_test (MP mp, mp_number *ret, mp_number dx0, mp_number dy0, mp_number dx1,
9878 mp_number dy1, mp_number dx2, mp_number dy2, mp_number a_goal) {
9879 mp_number v0, v1, v2; /* length of each $({\it dx},{\it dy})$ pair */
9880 mp_number v02; /* twice the norm of the quadratic at $t={1\over2}$ */
9884 pyth_add (v0, dx0, dy0);
9885 pyth_add (v1, dx1, dy1);
9886 pyth_add (v2, dx2, dy2);
9887 if ((number_greaterequal(v0, fraction_four_t)) ||
9888 (number_greaterequal(v1, fraction_four_t)) ||
9889 (number_greaterequal(v2, fraction_four_t))) {
9890 mp->arith_error = true;
9891 if (number_infinite(a_goal)) {
9892 set_number_to_inf(*ret);
9894 set_number_to_unity(*ret);
9895 number_double(*ret);
9896 number_negate(*ret);
9899 mp_number arg1, arg2;
9903 set_number_from_addition(arg1, dx0, dx2);
9905 number_add(arg1, dx1);
9906 set_number_from_addition(arg2, dy0, dy2);
9908 number_add(arg2, dy1);
9909 pyth_add (v02, arg1, arg2);
9912 mp_arc_test (mp, ret, dx0, dy0, dx1, dy1, dx2, dy2, v0, v02, v2, a_goal, arc_tol_k);
9921 @ Now it is easy to find the arc length of an entire path.
9924 static void mp_get_arc_length (MP mp, mp_number *ret, mp_knot h) {
9925 mp_knot p, q; /* for traversing the path */
9926 mp_number a; /* current arc length */
9927 mp_number a_tot; /* total arc length */
9928 mp_number arg1, arg2, arg3, arg4, arg5, arg6;
9939 new_number(arcgoal);
9940 set_number_to_inf(arcgoal);
9941 while (mp_right_type (p) != mp_endpoint) {
9942 q = mp_next_knot (p);
9943 set_number_from_substraction(arg1, p->right_x, p->x_coord);
9944 set_number_from_substraction(arg2, p->right_y, p->y_coord);
9945 set_number_from_substraction(arg3, q->left_x, p->right_x);
9946 set_number_from_substraction(arg4, q->left_y, p->right_y);
9947 set_number_from_substraction(arg5, q->x_coord, q->left_x);
9948 set_number_from_substraction(arg6, q->y_coord, q->left_y);
9949 mp_do_arc_test (mp, &a, arg1, arg2, arg3, arg4, arg5, arg6, arcgoal);
9950 slow_add (a_tot, a, a_tot);
9956 free_number (arcgoal);
9965 number_clone (*ret, a_tot);
9966 free_number (a_tot);
9970 @ The inverse operation of finding the time on a path~|h| when the arc length
9971 reaches some value |arc0| can also be accomplished via |do_arc_test|. Some care
9972 is required to handle very large times or negative times on cyclic paths. For
9973 non-cyclic paths, |arc0| values that are negative or too large cause
9974 |get_arc_time| to return 0 or the length of path~|h|.
9976 If |arc0| is greater than the arc length of a cyclic path~|h|, the result is a
9977 time value greater than the length of the path. Since it could be much greater,
9978 we must be prepared to compute the arc length of path~|h| and divide this into
9979 |arc0| to find how many multiples of the length of path~|h| to add.
9982 static void mp_get_arc_time (MP mp, mp_number *ret, mp_knot h, mp_number arc0_orig) {
9983 mp_knot p, q; /* for traversing the path */
9984 mp_number t_tot; /* accumulator for the result */
9985 mp_number t; /* the result of |do_arc_test| */
9986 mp_number arc, arc0; /* portion of |arc0| not used up so far */
9987 mp_number arg1, arg2, arg3, arg4, arg5, arg6; /* |do_arc_test| arguments */
9988 if (number_negative(arc0_orig)) {
9989 @<Deal with a negative |arc0_orig| value and |return|@>;
9993 number_clone(arc0, arc0_orig);
9994 if (number_infinite(arc0)) {
9995 number_add_scaled (arc0, -1);
9998 number_clone(arc, arc0);
10007 while ((mp_right_type (p) != mp_endpoint) && number_positive(arc)) {
10008 q = mp_next_knot (p);
10009 set_number_from_substraction(arg1, p->right_x, p->x_coord);
10010 set_number_from_substraction(arg2, p->right_y, p->y_coord);
10011 set_number_from_substraction(arg3, q->left_x, p->right_x);
10012 set_number_from_substraction(arg4, q->left_y, p->right_y);
10013 set_number_from_substraction(arg5, q->x_coord, q->left_x);
10014 set_number_from_substraction(arg6, q->y_coord, q->left_y);
10015 mp_do_arc_test (mp, &t, arg1, arg2, arg3, arg4, arg5, arg6, arc);
10016 @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>;
10018 @<Update |t_tot| and |arc| to avoid going around the cyclic
10019 path too many times but set |arith_error:=true| and |goto done| on
10025 number_clone (*ret, t_tot);
10027 free_number (t_tot);
10030 free_number (arc0);
10031 free_number (arg1);
10032 free_number (arg2);
10033 free_number (arg3);
10034 free_number (arg4);
10035 free_number (arg5);
10036 free_number (arg6);
10040 @ @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>=
10041 if (number_negative(t)) {
10042 number_add (t_tot, t);
10043 number_add (t_tot, two_t);
10044 set_number_to_zero(arc);
10046 number_add (t_tot, unity_t);
10047 number_substract(arc, t);
10051 @ @<Deal with a negative |arc0_orig| value and |return|@>=
10053 if (mp_left_type (h) == mp_endpoint) {
10054 set_number_to_zero (*ret);
10056 mp_number neg_arc0;
10057 p = mp_htap_ypoc (mp, h);
10058 new_number(neg_arc0);
10059 number_clone(neg_arc0, arc0_orig);
10060 number_negate(neg_arc0);
10061 mp_get_arc_time (mp, ret, p, neg_arc0);
10062 number_negate(*ret);
10063 mp_toss_knot_list (mp, p);
10064 free_number (neg_arc0);
10071 @ @<Update |t_tot| and |arc| to avoid going around the cyclic...@>=
10072 if (number_positive(arc)) {
10073 mp_number n, n1, d1, v1;
10079 set_number_from_substraction (d1, arc0, arc); /* d1 = arc0 - arc */
10080 set_number_from_div (n1, arc, d1); /* n1 = (arc / d1) */
10081 number_clone (n, n1);
10082 set_number_from_mul (n1, n1, d1); /* n1 = (n1 * d1) */
10083 number_substract (arc, n1); /* arc = arc - n1 */
10085 number_clone (d1, inf_t); /* reuse d1 */
10086 number_clone (v1, n); /* v1 = n */
10087 number_add (v1, epsilon_t); /* v1 = n1+1 */
10088 set_number_from_div (d1, d1, v1); /* |d1 = EL_GORDO / v1| */
10089 if (number_greater (t_tot, d1)) {
10090 mp->arith_error = true;
10092 set_number_to_inf(*ret);
10099 set_number_from_mul (t_tot, t_tot, v1);
10106 @* Data structures for pens.
10107 A Pen in \MP\ can be either elliptical or polygonal. Elliptical pens result
10108 in \ps\ \&{stroke} commands, while anything drawn with a polygonal pen is
10109 @:stroke}{\&{stroke} command@>
10110 converted into an area fill as described in the next part of this program.
10111 The mathematics behind this process is based on simple aspects of the theory
10112 of tracings developed by Leo Guibas, Lyle Ramshaw, and Jorge Stolfi
10113 [``A kinematic framework for computational geometry,'' Proc.\ IEEE Symp.\
10114 Foundations of Computer Science {\bf 24} (1983), 100--111].
10116 Polygonal pens are created from paths via \MP's \&{makepen} primitive.
10117 @:makepen_}{\&{makepen} primitive@>
10118 This path representation is almost sufficient for our purposes except that
10119 a pen path should always be a convex polygon with the vertices in
10120 counter-clockwise order.
10121 Since we will need to scan pen polygons both forward and backward, a pen
10122 should be represented as a doubly linked ring of knot nodes. There is
10123 room for the extra back pointer because we do not need the
10124 |mp_left_type| or |mp_right_type| fields. In fact, we don't need the |left_x|,
10125 |left_y|, |right_x|, or |right_y| fields either but we leave these alone
10126 so that certain procedures can operate on both pens and paths. In particular,
10127 pens can be copied using |copy_path| and recycled using |toss_knot_list|.
10129 @ The |make_pen| procedure turns a path into a pen by initializing
10130 the |prev_knot| pointers and making sure the knots form a convex polygon.
10131 Thus each cubic in the given path becomes a straight line and the control
10132 points are ignored. If the path is not cyclic, the ends are connected by a
10135 @d copy_pen(A) mp_make_pen(mp, mp_copy_path(mp, (A)),false)
10138 static mp_knot mp_make_pen (MP mp, mp_knot h, boolean need_hull) {
10139 mp_knot p, q; /* two consecutive knots */
10143 q = mp_next_knot (q);
10144 mp_prev_knot (q) = p;
10147 h = mp_convex_hull (mp, h);
10148 @<Make sure |h| isn't confused with an elliptical pen@>;
10154 @ The only information required about an elliptical pen is the overall
10155 transformation that has been applied to the original \&{pencircle}.
10156 @:pencircle_}{\&{pencircle} primitive@>
10157 Since it suffices to keep track of how the three points $(0,0)$, $(1,0)$,
10158 and $(0,1)$ are transformed, an elliptical pen can be stored in a single
10159 knot node and transformed as if it were a path.
10161 @d pen_is_elliptical(A) ((A)==mp_next_knot((A)))
10164 static mp_knot mp_get_pen_circle (MP mp, mp_number diam) {
10165 mp_knot h; /* the knot node to return */
10166 h = mp_new_knot (mp);
10167 mp_next_knot (h) = h;
10168 mp_prev_knot (h) = h;
10169 mp_originator (h) = mp_program_code;
10170 set_number_to_zero(h->x_coord);
10171 set_number_to_zero(h->y_coord);
10172 number_clone(h->left_x, diam);
10173 set_number_to_zero(h->left_y);
10174 set_number_to_zero(h->right_x);
10175 number_clone(h->right_y, diam);
10180 @ If the polygon being returned by |make_pen| has only one vertex, it will
10181 be interpreted as an elliptical pen. This is no problem since a degenerate
10182 polygon can equally well be thought of as a degenerate ellipse. We need only
10183 initialize the |left_x|, |left_y|, |right_x|, and |right_y| fields.
10185 @<Make sure |h| isn't confused with an elliptical pen@>=
10186 if (pen_is_elliptical (h)) {
10187 number_clone(h->left_x, h->x_coord);
10188 number_clone(h->left_y, h->y_coord);
10189 number_clone(h->right_x, h->x_coord);
10190 number_clone(h->right_y, h->y_coord);
10193 @ Printing a polygonal pen is very much like printing a path
10196 static void mp_pr_pen (MP mp, mp_knot h);
10199 void mp_pr_pen (MP mp, mp_knot h) {
10200 mp_knot p, q; /* for list traversal */
10201 if (pen_is_elliptical (h)) {
10202 @<Print the elliptical pen |h|@>;
10206 mp_print_two (mp, p->x_coord, p->y_coord);
10207 mp_print_nl (mp, " ..
");
10208 @<Advance |p| making sure the links are OK and |return| if there is
10211 mp_print (mp, "cycle
");
10216 @ @<Advance |p| making sure the links are OK and |return| if there is...@>=
10217 q = mp_next_knot (p);
10218 if ((q == NULL) || (mp_prev_knot (q) != p)) {
10219 mp_print_nl (mp, "???
");
10220 return; /* this won't happen */
10225 @ @<Print the elliptical pen |h|@>=
10229 mp_print (mp, "pencircle transformed
(");
10230 print_number (h->x_coord);
10231 mp_print_char (mp, xord (','));
10232 print_number (h->y_coord);
10233 mp_print_char (mp, xord (','));
10234 set_number_from_substraction (v1, h->left_x, h->x_coord);
10236 mp_print_char (mp, xord (','));
10237 set_number_from_substraction (v1, h->right_x, h->x_coord);
10239 mp_print_char (mp, xord (','));
10240 set_number_from_substraction (v1, h->left_y, h->y_coord);
10242 mp_print_char (mp, xord (','));
10243 set_number_from_substraction (v1, h->right_y, h->y_coord);
10245 mp_print_char (mp, xord (')'));
10250 @ Here us another version of |pr_pen| that prints the pen as a diagnostic
10254 static void mp_print_pen (MP mp, mp_knot h, const char *s, boolean nuline);
10257 void mp_print_pen (MP mp, mp_knot h, const char *s, boolean nuline) {
10258 mp_print_diagnostic (mp, "Pen
", s, nuline);
10260 @.Pen at line...@>;
10262 mp_end_diagnostic (mp, true);
10266 @ Making a polygonal pen into a path involves restoring the |mp_left_type| and
10267 |mp_right_type| fields and setting the control points so as to make a polygonal
10271 static void mp_make_path (MP mp, mp_knot h) {
10272 mp_knot p; /* for traversing the knot list */
10273 quarterword k; /* a loop counter */
10274 @<Other local variables in |make_path|@>;
10275 FUNCTION_TRACE1 ("make_path
()\n
");
10276 if (pen_is_elliptical (h)) {
10277 FUNCTION_TRACE1 ("make_path
(elliptical
)\n
");
10278 @<Make the elliptical pen |h| into a path@>;
10282 mp_left_type (p) = mp_explicit;
10283 mp_right_type (p) = mp_explicit;
10284 @<copy the coordinates of knot |p| into its control points@>;
10285 p = mp_next_knot (p);
10291 @ @<copy the coordinates of knot |p| into its control points@>=
10292 number_clone (p->left_x, p->x_coord);
10293 number_clone (p->left_y, p->y_coord);
10294 number_clone (p->right_x, p->x_coord);
10295 number_clone (p->right_y, p->y_coord)
10298 @ We need an eight knot path to get a good approximation to an ellipse.
10300 @<Make the elliptical pen |h| into a path@>=
10302 mp_number center_x, center_y; /* translation parameters for an elliptical pen */
10303 mp_number width_x, width_y; /* the effect of a unit change in $x$ */
10304 mp_number height_x, height_y; /* the effect of a unit change in $y$ */
10305 mp_number dx, dy; /* the vector from knot |p| to its right control point */
10306 new_number (center_x);
10307 new_number (center_y);
10308 new_number (width_x);
10309 new_number (width_y);
10310 new_number (height_x);
10311 new_number (height_y);
10314 @<Extract the transformation parameters from the elliptical pen~|h|@>;
10316 for (k = 0; k <= 7; k++) {
10317 @<Initialize |p| as the |k|th knot of a circle of unit diameter,
10318 transforming it appropriately@>;
10320 mp_next_knot (p) = h;
10322 mp_next_knot (p) = mp_new_knot (mp);
10323 p = mp_next_knot (p);
10327 free_number (center_x);
10328 free_number (center_y);
10329 free_number (width_x);
10330 free_number (width_y);
10331 free_number (height_x);
10332 free_number (height_y);
10336 @ @<Extract the transformation parameters from the elliptical pen~|h|@>=
10337 number_clone (center_x, h->x_coord);
10338 number_clone (center_y, h->y_coord);
10339 set_number_from_substraction (width_x, h->left_x, center_x);
10340 set_number_from_substraction (width_y, h->left_y, center_y);
10341 set_number_from_substraction (height_x, h->right_x, center_x);
10342 set_number_from_substraction (height_y, h->right_y, center_y);
10344 @ @<Other local variables in |make_path|@>=
10346 /* |k| advanced $270^\circ$ around the ring (cf. $\sin\theta=\cos(\theta+270)$) */
10348 @ The only tricky thing here are the tables |half_cos| and |d_cos| used to
10349 find the point $k/8$ of the way around the circle and the direction vector
10352 @<Initialize |p| as the |k|th knot of a circle of unit diameter,...@>=
10358 take_fraction (r1, mp->half_cos[k], width_x);
10359 take_fraction (r2, mp->half_cos[kk], height_x);
10360 number_add (r1, r2);
10361 set_number_from_addition (p->x_coord, center_x, r1);
10362 take_fraction (r1, mp->half_cos[k], width_y);
10363 take_fraction (r2, mp->half_cos[kk], height_y);
10364 number_add (r1, r2);
10365 set_number_from_addition (p->y_coord, center_y, r1);
10366 take_fraction (r1, mp->d_cos[kk], width_x);
10367 take_fraction (r2, mp->d_cos[k], height_x);
10368 number_clone (dx, r1);
10369 number_negate (dx);
10370 number_add (dx, r2);
10371 take_fraction (r1, mp->d_cos[kk], width_y);
10372 take_fraction (r2, mp->d_cos[k], height_y);
10373 number_clone (dy, r1);
10374 number_negate (dy);
10375 number_add (dy, r2);
10376 set_number_from_addition (p->right_x, p->x_coord, dx);
10377 set_number_from_addition (p->right_y, p->y_coord, dy);
10378 set_number_from_substraction (p->left_x, p->x_coord, dx);
10379 set_number_from_substraction (p->left_y, p->y_coord, dy);
10383 mp_left_type (p) = mp_explicit;
10384 mp_right_type (p) = mp_explicit;
10385 mp_originator (p) = mp_program_code
10388 mp_number half_cos[8]; /* ${1\over2}\cos(45k)$ */
10389 mp_number d_cos[8]; /* a magic constant times $\cos(45k)$ */
10391 @ The magic constant for |d_cos| is the distance between $({1\over2},0)$ and
10392 $({1\over4}\sqrt2,{1\over4}\sqrt2)$ times the result of the |velocity|
10393 function for $\theta=\phi=22.5^\circ$. This comes out to be
10394 $$ d = {\sqrt{2-\sqrt2}\over 3+3\cos22.5^\circ}
10395 \approx 0.132608244919772.
10399 for (k = 0; k <= 7; k++) {
10400 new_fraction (mp->half_cos[k]);
10401 new_fraction (mp->d_cos[k]);
10403 number_clone (mp->half_cos[0], fraction_half_t);
10404 number_clone (mp->half_cos[1], twentysixbits_sqrt2_t);
10405 number_clone (mp->half_cos[2], zero_t);
10406 number_clone (mp->d_cos[0], twentyeightbits_d_t);
10407 number_clone (mp->d_cos[1], twentysevenbits_sqrt2_d_t);
10408 number_clone (mp->d_cos[2], zero_t);
10409 for (k = 3; k <= 4; k++) {
10410 number_clone (mp->half_cos[k], mp->half_cos[4 - k]);
10411 number_negate (mp->half_cos[k]);
10412 number_clone (mp->d_cos[k], mp->d_cos[4 - k]);
10413 number_negate (mp->d_cos[k]);
10415 for (k = 5; k <= 7; k++) {
10416 number_clone (mp->half_cos[k], mp->half_cos[8 - k]);
10417 number_clone (mp->d_cos[k], mp->d_cos[8 - k]);
10421 for (k = 0; k <= 7; k++) {
10422 free_number (mp->half_cos[k]);
10423 free_number (mp->d_cos[k]);
10427 @ The |convex_hull| function forces a pen polygon to be convex when it is
10428 returned by |make_pen| and after any subsequent transformation where rounding
10429 error might allow the convexity to be lost.
10430 The convex hull algorithm used here is described by F.~P. Preparata and
10431 M.~I. Shamos [{\sl Computational Geometry}, Springer-Verlag, 1985].
10434 static mp_knot mp_convex_hull (MP mp, mp_knot h);
10437 mp_knot mp_convex_hull (MP mp, mp_knot h) { /* Make a polygonal pen convex */
10438 mp_knot l, r; /* the leftmost and rightmost knots */
10439 mp_knot p, q; /* knots being scanned */
10440 mp_knot s; /* the starting point for an upcoming scan */
10441 mp_number dx, dy; /* a temporary pointer */
10445 if (pen_is_elliptical (h)) {
10448 @<Set |l| to the leftmost knot in polygon~|h|@>;
10449 @<Set |r| to the rightmost knot in polygon~|h|@>;
10451 s = mp_next_knot (r);
10452 @<Find any knots on the path from |l| to |r| above the |l|-|r| line and
10453 move them past~|r|@>;
10454 @<Find any knots on the path from |s| to |l| below the |l|-|r| line and
10455 move them past~|l|@>;
10456 @<Sort the path from |l| to |r| by increasing $x$@>;
10457 @<Sort the path from |r| to |l| by decreasing $x$@>;
10459 if (l != mp_next_knot (l)) {
10460 @<Do a Gramm scan and remove vertices where there is no left turn@>;
10470 @ All comparisons are done primarily on $x$ and secondarily on $y$.
10472 @<Set |l| to the leftmost knot in polygon~|h|@>=
10474 p = mp_next_knot (h);
10476 if (number_lessequal (p->x_coord, l->x_coord))
10477 if ((number_less (p->x_coord, l->x_coord)) ||
10478 (number_less (p->y_coord, l->y_coord)))
10480 p = mp_next_knot (p);
10484 @ @<Set |r| to the rightmost knot in polygon~|h|@>=
10486 p = mp_next_knot (h);
10488 if (number_greaterequal(p->x_coord, r->x_coord))
10489 if (number_greater (p->x_coord, r->x_coord) ||
10490 number_greater (p->y_coord, r->y_coord))
10492 p = mp_next_knot (p);
10496 @ @<Find any knots on the path from |l| to |r| above the |l|-|r| line...@>=
10498 mp_number ab_vs_cd;
10499 mp_number arg1, arg2;
10502 new_number (ab_vs_cd);
10503 set_number_from_substraction (dx, r->x_coord, l->x_coord);
10504 set_number_from_substraction (dy, r->y_coord, l->y_coord);
10505 p = mp_next_knot (l);
10507 q = mp_next_knot (p);
10508 set_number_from_substraction (arg1, p->y_coord, l->y_coord);
10509 set_number_from_substraction (arg2, p->x_coord, l->x_coord);
10510 ab_vs_cd (ab_vs_cd, dx, arg1, dy, arg2);
10511 if (number_positive(ab_vs_cd))
10512 mp_move_knot (mp, p, r);
10515 free_number (ab_vs_cd);
10516 free_number (arg1);
10517 free_number (arg2);
10521 @ The |move_knot| procedure removes |p| from a doubly linked list and inserts
10524 @ @<Declarations@>=
10525 static void mp_move_knot (MP mp, mp_knot p, mp_knot q);
10528 void mp_move_knot (MP mp, mp_knot p, mp_knot q) {
10530 mp_next_knot (mp_prev_knot (p)) = mp_next_knot (p);
10531 mp_prev_knot (mp_next_knot (p)) = mp_prev_knot (p);
10532 mp_prev_knot (p) = q;
10533 mp_next_knot (p) = mp_next_knot (q);
10534 mp_next_knot (q) = p;
10535 mp_prev_knot (mp_next_knot (p)) = p;
10539 @ @<Find any knots on the path from |s| to |l| below the |l|-|r| line...@>=
10541 mp_number ab_vs_cd;
10542 mp_number arg1, arg2;
10543 new_number (ab_vs_cd);
10548 q = mp_next_knot (p);
10549 set_number_from_substraction (arg1, p->y_coord, l->y_coord);
10550 set_number_from_substraction (arg2, p->x_coord, l->x_coord);
10551 ab_vs_cd (ab_vs_cd, dx, arg1, dy, arg2);
10552 if (number_negative(ab_vs_cd))
10553 mp_move_knot (mp, p, l);
10556 free_number (ab_vs_cd);
10557 free_number (arg1);
10558 free_number (arg2);
10562 @ The list is likely to be in order already so we just do linear insertions.
10563 Secondary comparisons on $y$ ensure that the sort is consistent with the
10564 choice of |l| and |r|.
10566 @<Sort the path from |l| to |r| by increasing $x$@>=
10567 p = mp_next_knot (l);
10569 q = mp_prev_knot (p);
10570 while (number_greater(q->x_coord, p->x_coord))
10571 q = mp_prev_knot (q);
10572 while (number_equal(q->x_coord, p->x_coord)) {
10573 if (number_greater(q->y_coord, p->y_coord))
10574 q = mp_prev_knot (q);
10578 if (q == mp_prev_knot (p)) {
10579 p = mp_next_knot (p);
10581 p = mp_next_knot (p);
10582 mp_move_knot (mp, mp_prev_knot (p), q);
10587 @ @<Sort the path from |r| to |l| by decreasing $x$@>=
10588 p = mp_next_knot (r);
10590 q = mp_prev_knot (p);
10591 while (number_less(q->x_coord, p->x_coord))
10592 q = mp_prev_knot (q);
10593 while (number_equal(q->x_coord, p->x_coord)) {
10594 if (number_less (q->y_coord, p->y_coord))
10595 q = mp_prev_knot (q);
10599 if (q == mp_prev_knot (p)) {
10600 p = mp_next_knot (p);
10602 p = mp_next_knot (p);
10603 mp_move_knot (mp, mp_prev_knot (p), q);
10608 @ The condition involving |ab_vs_cd| tests if there is not a left turn
10609 at knot |q|. There usually will be a left turn so we streamline the case
10610 where the |then| clause is not executed.
10612 @<Do a Gramm scan and remove vertices where there...@>=
10614 mp_number ab_vs_cd;
10615 mp_number arg1, arg2;
10618 new_number (ab_vs_cd);
10620 q = mp_next_knot (l);
10622 set_number_from_substraction (dx, q->x_coord, p->x_coord);
10623 set_number_from_substraction (dy, q->y_coord, p->y_coord);
10625 q = mp_next_knot (q);
10629 set_number_from_substraction (arg1, q->y_coord, p->y_coord);
10630 set_number_from_substraction (arg2, q->x_coord, p->x_coord);
10631 ab_vs_cd (ab_vs_cd, dx, arg1, dy, arg2);
10632 if (number_nonpositive(ab_vs_cd)) {
10633 @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>;
10637 free_number (ab_vs_cd);
10638 free_number (arg1);
10639 free_number (arg2);
10643 @ @<Remove knot |p| and back up |p| and |q| but don't go past |l|@>=
10645 s = mp_prev_knot (p);
10647 mp_next_knot (s) = q;
10648 mp_prev_knot (q) = s;
10652 p = mp_prev_knot (s);
10658 @ The |find_offset| procedure sets global variables |(cur_x,cur_y)| to the
10659 offset associated with the given direction |(x,y)|. If two different offsets
10660 apply, it chooses one of them.
10663 static void mp_find_offset (MP mp, mp_number x_orig, mp_number y_orig, mp_knot h) {
10664 mp_knot p, q; /* consecutive knots */
10665 if (pen_is_elliptical (h)) {
10666 mp_fraction xx, yy; /* untransformed offset for an elliptical pen */
10667 mp_number wx, wy, hx, hy; /* the transformation matrix for an elliptical pen */
10668 mp_fraction d; /* a temporary register */
10676 @<Find the offset for |(x,y)| on the elliptical pen~|h|@>
10685 mp_number ab_vs_cd;
10686 mp_number arg1, arg2;
10689 new_number (ab_vs_cd);
10693 q = mp_next_knot (q);
10694 set_number_from_substraction (arg1, q->x_coord, p->x_coord);
10695 set_number_from_substraction (arg2, q->y_coord, p->y_coord);
10696 ab_vs_cd (ab_vs_cd, arg1, y_orig, arg2, x_orig);
10697 } while (number_negative(ab_vs_cd));
10700 q = mp_next_knot (q);
10701 set_number_from_substraction (arg1, q->x_coord, p->x_coord);
10702 set_number_from_substraction (arg2, q->y_coord, p->y_coord);
10703 ab_vs_cd (ab_vs_cd, arg1, y_orig, arg2, x_orig);
10704 } while (number_positive(ab_vs_cd));
10705 number_clone (mp->cur_x, p->x_coord);
10706 number_clone (mp->cur_y, p->y_coord);
10707 free_number (ab_vs_cd);
10708 free_number (arg1);
10709 free_number (arg2);
10716 mp_number cur_y; /* all-purpose return value registers */
10718 @ @<Initialize table entries@>=
10719 new_number (mp->cur_x);
10720 new_number (mp->cur_y);
10723 free_number (mp->cur_x);
10724 free_number (mp->cur_y);
10726 @ @<Find the offset for |(x,y)| on the elliptical pen~|h|@>=
10727 if (number_zero(x_orig) && number_zero(y_orig)) {
10728 number_clone(mp->cur_x, h->x_coord);
10729 number_clone(mp->cur_y, h->y_coord);
10731 mp_number x, y, abs_x, abs_y;
10736 number_clone(x, x_orig);
10737 number_clone(y, y_orig);
10738 @<Find the non-constant part of the transformation for |h|@>;
10739 number_clone(abs_x, x);
10740 number_clone(abs_y, y);
10743 while (number_less(abs_x, fraction_half_t) && number_less(abs_y, fraction_half_t)) {
10746 number_clone(abs_x, x);
10747 number_clone(abs_y, y);
10751 @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the
10752 untransformed version of |(x,y)|@>;
10757 take_fraction (r1, xx, wx);
10758 take_fraction (r2, yy, hx);
10759 number_add(r1, r2);
10760 set_number_from_addition(mp->cur_x, h->x_coord, r1);
10761 take_fraction (r1, xx, wy);
10762 take_fraction (r2, yy, hy);
10763 number_add(r1, r2);
10764 set_number_from_addition(mp->cur_y, h->y_coord, r1);
10768 free_number(abs_x);
10769 free_number(abs_y);
10775 @ @<Find the non-constant part of the transformation for |h|@>=
10777 set_number_from_substraction(wx, h->left_x, h->x_coord);
10778 set_number_from_substraction(wy, h->left_y, h->y_coord);
10779 set_number_from_substraction(hx, h->right_x, h->x_coord);
10780 set_number_from_substraction(hy, h->right_y, h->y_coord);
10784 @ @<Make |(xx,yy)| the offset on the untransformed \&{pencircle} for the...@>=
10786 mp_number r1, r2, arg1;
10790 take_fraction (r1, x, hy);
10791 number_clone (arg1, hx);
10792 number_negate (arg1);
10793 take_fraction (r2, y, arg1);
10794 number_add (r1, r2);
10795 number_negate (r1);
10796 number_clone(yy, r1);
10797 number_clone (arg1, wy);
10798 number_negate (arg1);
10799 take_fraction (r1, x, arg1);
10800 take_fraction (r2, y, wx);
10801 number_add (r1, r2);
10802 number_clone(xx, r1);
10803 free_number (arg1);
10807 pyth_add (d, xx, yy);
10808 if (number_positive(d)) {
10810 new_fraction (ret);
10811 make_fraction (ret, xx, d);
10813 number_clone(xx, ret);
10814 make_fraction (ret, yy, d);
10816 number_clone(yy, ret);
10820 @ Finding the bounding box of a pen is easy except if the pen is elliptical.
10821 But we can handle that case by just calling |find_offset| twice. The answer
10822 is stored in the global variables |minx|, |maxx|, |miny|, and |maxy|.
10825 static void mp_pen_bbox (MP mp, mp_knot h) {
10826 mp_knot p; /* for scanning the knot list */
10827 if (pen_is_elliptical (h)) {
10828 @<Find the bounding box of an elliptical pen@>;
10830 number_clone (mp_minx, h->x_coord);
10831 number_clone (mp_maxx, mp_minx);
10832 number_clone (mp_miny, h->y_coord);
10833 number_clone (mp_maxy, mp_miny);
10834 p = mp_next_knot (h);
10836 if (number_less (p->x_coord, mp_minx))
10837 number_clone (mp_minx, p->x_coord);
10838 if (number_less (p->y_coord, mp_miny))
10839 number_clone (mp_miny, p->y_coord);
10840 if (number_greater (p->x_coord, mp_maxx))
10841 number_clone (mp_maxx, p->x_coord);
10842 if (number_greater (p->y_coord, mp_maxy))
10843 number_clone (mp_maxy, p->y_coord);
10844 p = mp_next_knot (p);
10850 @ @<Find the bounding box of an elliptical pen@>=
10852 mp_number arg1, arg2;
10854 new_fraction (arg2);
10855 number_clone(arg2, fraction_one_t);
10856 mp_find_offset (mp, arg1, arg2, h);
10857 number_clone (mp_maxx, mp->cur_x);
10858 number_clone (mp_minx, h->x_coord);
10859 number_double (mp_minx);
10860 number_substract (mp_minx, mp->cur_x);
10861 number_negate (arg2);
10862 mp_find_offset (mp, arg2, arg1, h);
10863 number_clone (mp_maxy, mp->cur_y);
10864 number_clone (mp_miny, h->y_coord);
10865 number_double (mp_miny);
10866 number_substract (mp_miny, mp->cur_y);
10872 @* Numerical values.
10874 This first set goes into the header
10876 @<MPlib internal header stuff@>=
10877 #define mp_fraction mp_number
10878 #define mp_angle mp_number
10879 #define new_number(A) (((math_data *)(mp->math))->allocate)(mp, &(A), mp_scaled_type)
10880 #define new_fraction(A) (((math_data *)(mp->math))->allocate)(mp, &(A), mp_fraction_type)
10881 #define new_angle(A) (((math_data *)(mp->math))->allocate)(mp, &(A), mp_angle_type)
10882 #define free_number(A) (((math_data *)(mp->math))->free)(mp, &(A))
10885 @d set_precision() (((math_data *)(mp->math))->set_precision)(mp)
10886 @d free_math() (((math_data *)(mp->math))->free_math)(mp)
10887 @d scan_numeric_token(A) (((math_data *)(mp->math))->scan_numeric)(mp, A)
10888 @d scan_fractional_token(A) (((math_data *)(mp->math))->scan_fractional)(mp, A)
10889 @d set_number_from_of_the_way(A,t,B,C) (((math_data *)(mp->math))->from_oftheway)(mp, &(A),t,B,C)
10890 @d set_number_from_int(A,B) (((math_data *)(mp->math))->from_int)(&(A),B)
10891 @d set_number_from_scaled(A,B) (((math_data *)(mp->math))->from_scaled)(&(A),B)
10892 @d set_number_from_boolean(A,B) (((math_data *)(mp->math))->from_boolean)(&(A),B)
10893 @d set_number_from_double(A,B) (((math_data *)(mp->math))->from_double)(&(A),B)
10894 @d set_number_from_addition(A,B,C) (((math_data *)(mp->math))->from_addition)(&(A),B,C)
10895 @d set_number_from_substraction(A,B,C) (((math_data *)(mp->math))->from_substraction)(&(A),B,C)
10896 @d set_number_from_div(A,B,C) (((math_data *)(mp->math))->from_div)(&(A),B,C)
10897 @d set_number_from_mul(A,B,C) (((math_data *)(mp->math))->from_mul)(&(A),B,C)
10898 @d number_int_div(A,C) (((math_data *)(mp->math))->from_int_div)(&(A),A,C)
10899 @d set_number_from_int_mul(A,B,C) (((math_data *)(mp->math))->from_int_mul)(&(A),B,C)
10901 @d set_number_to_unity(A) (((math_data *)(mp->math))->clone)(&(A), unity_t)
10902 @d set_number_to_zero(A) (((math_data *)(mp->math))->clone)(&(A), zero_t)
10903 @d set_number_to_inf(A) (((math_data *)(mp->math))->clone)(&(A), inf_t)
10904 @d set_number_to_neg_inf(A) do { set_number_to_inf(A); number_negate (A); } while (0)
10906 @d init_randoms(A) (((math_data *)(mp->math))->init_randoms)(mp,A)
10907 @d print_number(A) (((math_data *)(mp->math))->print)(mp,A)
10908 @d number_tostring(A) (((math_data *)(mp->math))->tostring)(mp,A)
10909 @d make_scaled(R,A,B) (((math_data *)(mp->math))->make_scaled)(mp,&(R),A,B)
10910 @d take_scaled(R,A,B) (((math_data *)(mp->math))->take_scaled)(mp,&(R),A,B)
10911 @d make_fraction(R,A,B) (((math_data *)(mp->math))->make_fraction)(mp,&(R),A,B)
10912 @d take_fraction(R,A,B) (((math_data *)(mp->math))->take_fraction)(mp,&(R),A,B)
10913 @d pyth_add(R,A,B) (((math_data *)(mp->math))->pyth_add)(mp,&(R),A,B)
10914 @d pyth_sub(R,A,B) (((math_data *)(mp->math))->pyth_sub)(mp,&(R),A,B)
10915 @d n_arg(R,A,B) (((math_data *)(mp->math))->n_arg)(mp,&(R),A,B)
10916 @d m_log(R,A) (((math_data *)(mp->math))->m_log)(mp,&(R),A)
10917 @d m_exp(R,A) (((math_data *)(mp->math))->m_exp)(mp,&(R),A)
10918 @d velocity(R,A,B,C,D,E) (((math_data *)(mp->math))->velocity)(mp,&(R),A,B,C,D,E)
10919 @d ab_vs_cd(R,A,B,C,D) (((math_data *)(mp->math))->ab_vs_cd)(mp,&(R),A,B,C,D)
10920 @d crossing_point(R,A,B,C) (((math_data *)(mp->math))->crossing_point)(mp,&(R),A,B,C)
10921 @d n_sin_cos(A,S,C) (((math_data *)(mp->math))->sin_cos)(mp,A,&(S),&(C))
10922 @d square_rt(A,S) (((math_data *)(mp->math))->sqrt)(mp,&(A),S)
10923 @d slow_add(R,A,B) (((math_data *)(mp->math))->slow_add)(mp,&(R),A,B)
10924 @d round_unscaled(A) (((math_data *)(mp->math))->round_unscaled)(A)
10925 @d floor_scaled(A) (((math_data *)(mp->math))->floor_scaled)(&(A))
10926 @d fraction_to_round_scaled(A) (((math_data *)(mp->math))->fraction_to_round_scaled)(&(A))
10927 @d number_to_int(A) (((math_data *)(mp->math))->to_int)(A)
10928 @d number_to_boolean(A) (((math_data *)(mp->math))->to_boolean)(A)
10929 @d number_to_scaled(A) (((math_data *)(mp->math))->to_scaled)(A)
10930 @d number_to_double(A) (((math_data *)(mp->math))->to_double)(A)
10931 @d number_negate(A) (((math_data *)(mp->math))->negate)(&(A))
10932 @d number_add(A,B) (((math_data *)(mp->math))->add)(&(A),B)
10933 @d number_substract(A,B) (((math_data *)(mp->math))->substract)(&(A),B)
10934 @d number_half(A) (((math_data *)(mp->math))->half)(&(A))
10935 @d number_halfp(A) (((math_data *)(mp->math))->halfp)(&(A))
10936 @d number_double(A) (((math_data *)(mp->math))->do_double)(&(A))
10937 @d number_add_scaled(A,B) (((math_data *)(mp->math))->add_scaled)(&(A),B)
10938 @d number_multiply_int(A,B) (((math_data *)(mp->math))->multiply_int)(&(A),B)
10939 @d number_divide_int(A,B) (((math_data *)(mp->math))->divide_int)(&(A),B)
10940 @d number_abs(A) (((math_data *)(mp->math))->abs)(&(A))
10941 @d number_modulo(A,B) (((math_data *)(mp->math))->modulo)(&(A), B)
10942 @d number_nonequalabs(A,B) (((math_data *)(mp->math))->nonequalabs)(A,B)
10943 @d number_odd(A) (((math_data *)(mp->math))->odd)(A)
10944 @d number_equal(A,B) (((math_data *)(mp->math))->equal)(A,B)
10945 @d number_greater(A,B) (((math_data *)(mp->math))->greater)(A,B)
10946 @d number_less(A,B) (((math_data *)(mp->math))->less)(A,B)
10947 @d number_clone(A,B) (((math_data *)(mp->math))->clone)(&(A),B)
10948 @d number_swap(A,B) (((math_data *)(mp->math))->swap)(&(A),&(B));
10949 @d convert_scaled_to_angle(A) (((math_data *)(mp->math))->scaled_to_angle)(&(A));
10950 @d convert_angle_to_scaled(A) (((math_data *)(mp->math))->angle_to_scaled)(&(A));
10951 @d convert_fraction_to_scaled(A) (((math_data *)(mp->math))->fraction_to_scaled)(&(A));
10952 @d convert_scaled_to_fraction(A) (((math_data *)(mp->math))->scaled_to_fraction)(&(A));
10954 @d number_zero(A) number_equal(A, zero_t)
10955 @d number_infinite(A) number_equal(A, inf_t)
10956 @d number_unity(A) number_equal(A, unity_t)
10957 @d number_negative(A) number_less(A, zero_t)
10958 @d number_nonnegative(A) (!number_negative(A))
10959 @d number_positive(A) number_greater(A, zero_t)
10960 @d number_nonpositive(A) (!number_positive(A))
10961 @d number_nonzero(A) (!number_zero(A))
10962 @d number_greaterequal(A,B) (!number_less(A,B))
10963 @d number_lessequal(A,B) (!number_greater(A,B))
10965 @* Edge structures.
10966 Now we come to \MP's internal scheme for representing pictures.
10967 The representation is very different from \MF's edge structures
10968 because \MP\ pictures contain \ps\ graphics objects instead of pixel
10969 images. However, the basic idea is somewhat similar in that shapes
10970 are represented via their boundaries.
10972 The main purpose of edge structures is to keep track of graphical objects
10973 until it is time to translate them into \ps. Since \MP\ does not need to
10974 know anything about an edge structure other than how to translate it into
10975 \ps\ and how to find its bounding box, edge structures can be just linked
10976 lists of graphical objects. \MP\ has no easy way to determine whether
10977 two such objects overlap, but it suffices to draw the first one first and
10978 let the second one overwrite it if necessary.
10980 @<MPlib header stuff@>=
10981 enum mp_graphical_object_code {
10982 @<Graphical object codes@>
10986 @ Let's consider the types of graphical objects one at a time.
10987 First of all, a filled contour is represented by a eight-word node. The first
10988 word contains |type| and |link| fields, and the next six words contain a
10989 pointer to a cyclic path and the value to use for \ps' \&{currentrgbcolor}
10990 parameter. If a pen is used for filling |pen_p|, |ljoin| and |miterlim|
10991 give the relevant information.
10993 @d mp_path_p(A) (A)->path_p_ /* a pointer to the path that needs filling */
10994 @d mp_pen_p(A) (A)->pen_p_ /* a pointer to the pen to fill or stroke with */
10995 @d mp_color_model(A) ((mp_fill_node)(A))->color_model_ /* the color model */
11000 @d mp_pre_script(A) ((mp_fill_node)(A))->pre_script_
11001 @d mp_post_script(A) ((mp_fill_node)(A))->post_script_
11003 @<MPlib internal header stuff@>=
11004 typedef struct mp_fill_node_data {
11006 halfword color_model_;
11011 mp_string pre_script_;
11012 mp_string post_script_;
11015 unsigned char ljoin;
11016 mp_number miterlim;
11017 } mp_fill_node_data;
11018 typedef struct mp_fill_node_data *mp_fill_node;
11020 @ @<Graphical object codes@>=
11023 @ Make a fill node for cyclic path |p| and color black.
11025 @d fill_node_size sizeof(struct mp_fill_node_data)
11028 static mp_node mp_new_fill_node (MP mp, mp_knot p) {
11029 mp_fill_node t = malloc_node (fill_node_size);
11030 mp_type (t) = mp_fill_node_type;
11032 mp_pen_p (t) = NULL; /* |NULL| means don't use a pen */
11033 new_number(t->red);
11034 new_number(t->green);
11035 new_number(t->blue);
11036 new_number(t->black);
11037 new_number(t->miterlim);
11039 mp_color_model (t) = mp_uninitialized_model;
11040 mp_pre_script (t) = NULL;
11041 mp_post_script (t) = NULL;
11042 /* Set the |ljoin| and |miterlim| fields in object |t| */
11043 if (number_greater(internal_value (mp_linejoin), unity_t))
11045 else if (number_positive(internal_value (mp_linejoin)))
11049 if (number_less(internal_value (mp_miterlimit), unity_t)) {
11050 set_number_to_unity(t->miterlim);
11052 number_clone(t->miterlim,internal_value (mp_miterlimit));
11054 return (mp_node) t;
11058 static void mp_free_fill_node (MP mp, mp_fill_node p) {
11059 mp_toss_knot_list (mp, mp_path_p (p));
11060 if (mp_pen_p (p) != NULL)
11061 mp_toss_knot_list (mp, mp_pen_p (p));
11062 if (mp_pre_script (p) != NULL)
11063 delete_str_ref (mp_pre_script (p));
11064 if (mp_post_script (p) != NULL)
11065 delete_str_ref (mp_post_script (p));
11066 free_number(p->red);
11067 free_number(p->green);
11068 free_number(p->blue);
11069 free_number(p->black);
11070 free_number(p->miterlim);
11071 mp_free_node (mp, (mp_node)p, fill_node_size);
11076 @ A stroked path is represented by an eight-word node that is like a filled
11077 contour node except that it contains the current \&{linecap} value, a scale
11078 factor for the dash pattern, and a pointer that is non-NULL if the stroke
11079 is to be dashed. The purpose of the scale factor is to allow a picture to
11080 be transformed without touching the picture that |dash_p| points to.
11082 @d mp_dash_p(A) ((mp_stroked_node)(A))->dash_p_ /* a pointer to the edge structure that gives the dash pattern */
11084 @<MPlib internal header stuff@>=
11085 typedef struct mp_stroked_node_data {
11087 halfword color_model_;
11092 mp_string pre_script_;
11093 mp_string post_script_;
11096 unsigned char ljoin;
11097 mp_number miterlim;
11098 unsigned char lcap;
11100 mp_number dash_scale;
11101 } mp_stroked_node_data;
11102 typedef struct mp_stroked_node_data *mp_stroked_node;
11105 @ @<Graphical object codes@>=
11106 mp_stroked_code = 2,
11108 @ Make a stroked node for path |p| with |mp_pen_p(p)| temporarily |NULL|.
11110 @d stroked_node_size sizeof(struct mp_stroked_node_data)
11113 static mp_node mp_new_stroked_node (MP mp, mp_knot p) {
11114 mp_stroked_node t = malloc_node (stroked_node_size);
11115 mp_type (t) = mp_stroked_node_type;
11117 mp_pen_p (t) = NULL;
11118 mp_dash_p (t) = NULL;
11119 new_number(t->dash_scale);
11120 set_number_to_unity(t->dash_scale);
11121 new_number(t->red);
11122 new_number(t->green);
11123 new_number(t->blue);
11124 new_number(t->black);
11125 new_number(t->miterlim);
11127 mp_pre_script (t) = NULL;
11128 mp_post_script (t) = NULL;
11129 /* Set the |ljoin| and |miterlim| fields in object |t| */
11130 if (number_greater(internal_value (mp_linejoin), unity_t))
11132 else if (number_positive(internal_value (mp_linejoin)))
11136 if (number_less(internal_value (mp_miterlimit), unity_t)) {
11137 set_number_to_unity(t->miterlim);
11139 number_clone(t->miterlim,internal_value (mp_miterlimit));
11141 if (number_greater(internal_value (mp_linecap), unity_t))
11143 else if (number_positive(internal_value (mp_linecap)))
11147 return (mp_node) t;
11151 static mp_edge_header_node mp_free_stroked_node (MP mp, mp_stroked_node p) {
11152 mp_edge_header_node e = NULL;
11153 mp_toss_knot_list (mp, mp_path_p (p));
11154 if (mp_pen_p (p) != NULL)
11155 mp_toss_knot_list (mp, mp_pen_p (p));
11156 if (mp_pre_script (p) != NULL)
11157 delete_str_ref (mp_pre_script (p));
11158 if (mp_post_script (p) != NULL)
11159 delete_str_ref (mp_post_script (p));
11160 e = (mp_edge_header_node)mp_dash_p (p);
11161 free_number(p->dash_scale);
11162 free_number(p->red);
11163 free_number(p->green);
11164 free_number(p->blue);
11165 free_number(p->black);
11166 free_number(p->miterlim);
11167 mp_free_node (mp, (mp_node)p, stroked_node_size);
11171 @ When a dashed line is computed in a transformed coordinate system, the dash
11172 lengths get scaled like the pen shape and we need to compensate for this. Since
11173 there is no unique scale factor for an arbitrary transformation, we use the
11174 the square root of the determinant. The properties of the determinant make it
11175 easier to maintain the |dash_scale|. The computation is fairly straight-forward
11176 except for the initialization of the scale factor |s|. The factor of 64 is
11177 needed because |square_rt| scales its result by $2^8$ while we need $2^{14}$
11178 to counteract the effect of |take_fraction|.
11181 void mp_sqrt_det (MP mp, mp_number *ret, mp_number a_orig, mp_number b_orig, mp_number c_orig, mp_number d_orig) {
11183 mp_number maxabs; /* $max(|a|,|b|,|c|,|d|)$ */
11184 unsigned s; /* amount by which the result of |square_rt| needs to be scaled */
11189 new_number(maxabs);
11190 number_clone(a, a_orig);
11191 number_clone(b, b_orig);
11192 number_clone(c, c_orig);
11193 number_clone(d, d_orig);
11194 /* Initialize |maxabs| */
11198 number_clone(maxabs, a);
11199 number_abs(maxabs);
11200 number_clone(tmp, b);
11202 if (number_greater(tmp, maxabs))
11203 number_clone(maxabs, tmp);
11204 number_clone(tmp, c);
11206 if (number_greater(tmp, maxabs))
11207 number_clone(maxabs, tmp);
11208 number_clone(tmp, d);
11210 if (number_greater(tmp, maxabs))
11211 number_clone(maxabs, tmp);
11217 while ((number_less(maxabs, fraction_one_t)) && (s > 1)) {
11222 number_double(maxabs);
11229 take_fraction (r1, a, d);
11230 take_fraction (r2, b, c);
11231 number_substract (r1, r2);
11233 square_rt(*ret, r1);
11234 number_multiply_int(*ret, s);
11242 free_number(maxabs);
11245 static void mp_get_pen_scale (MP mp, mp_number *ret, mp_knot p) {
11247 set_number_to_zero(*ret);
11254 set_number_from_substraction(a, p->left_x, p->x_coord);
11255 set_number_from_substraction(b, p->right_x, p->x_coord);
11256 set_number_from_substraction(c, p->left_y, p->y_coord);
11257 set_number_from_substraction(d, p->right_y, p->y_coord);
11258 mp_sqrt_det (mp, ret, a, b, c, d);
11267 @ @<Declarations@>=
11268 static void mp_sqrt_det (MP mp, mp_number *ret, mp_number a, mp_number b, mp_number c, mp_number d);
11270 @ When a picture contains text, this is represented by a fourteen-word node
11271 where the color information and |type| and |link| fields are augmented by
11272 additional fields that describe the text and how it is transformed.
11273 The |path_p| and |mp_pen_p| pointers are replaced by a number that identifies
11274 the font and a string number that gives the text to be displayed.
11275 The |width|, |height|, and |depth| fields
11276 give the dimensions of the text at its design size, and the remaining six
11277 words give a transformation to be applied to the text. The |new_text_node|
11278 function initializes everything to default values so that the text comes out
11279 black with its reference point at the origin.
11281 @d mp_text_p(A) ((mp_text_node)(A))->text_p_ /* a string pointer for the text to display */
11282 @d mp_font_n(A) ((mp_text_node)(A))->font_n_ /* the font number */
11284 @<MPlib internal header stuff@>=
11285 typedef struct mp_text_node_data {
11287 halfword color_model_;
11292 mp_string pre_script_;
11293 mp_string post_script_;
11305 } mp_text_node_data;
11306 typedef struct mp_text_node_data *mp_text_node;
11308 @ @<Graphical object codes@>=
11311 @ Make a text node for font |f| and text string |s|.
11313 @d text_node_size sizeof(struct mp_text_node_data)
11316 static mp_node mp_new_text_node (MP mp, char *f, mp_string s) {
11317 mp_text_node t = malloc_node (text_node_size);
11318 mp_type (t) = mp_text_node_type;
11321 mp_font_n (t) = (halfword) mp_find_font (mp, f); /* this identifies the font */
11322 new_number(t->red);
11323 new_number(t->green);
11324 new_number(t->blue);
11325 new_number(t->black);
11326 new_number(t->width);
11327 new_number(t->height);
11328 new_number(t->depth);
11330 mp_pre_script (t) = NULL;
11331 mp_post_script (t) = NULL;
11334 new_number(t->txx);
11335 new_number(t->txy);
11336 new_number(t->tyx);
11337 new_number(t->tyy);
11338 /* |tx_val (t) = 0; ty_val (t) = 0;| */
11339 /* |txy_val (t) = 0; tyx_val (t) = 0;| */
11340 set_number_to_unity(t->txx);
11341 set_number_to_unity(t->tyy);
11342 mp_set_text_box (mp, t); /* this finds the bounding box */
11343 return (mp_node) t;
11347 static void mp_free_text_node (MP mp, mp_text_node p) {
11348 /* |delete_str_ref (mp_text_p (p));| */ /* gives errors */
11349 if (mp_pre_script (p) != NULL)
11350 delete_str_ref (mp_pre_script (p));
11351 if (mp_post_script (p) != NULL)
11352 delete_str_ref (mp_post_script (p));
11353 free_number(p->red);
11354 free_number(p->green);
11355 free_number(p->blue);
11356 free_number(p->black);
11357 free_number(p->width);
11358 free_number(p->height);
11359 free_number(p->depth);
11360 free_number(p->tx);
11361 free_number(p->ty);
11362 free_number(p->txx);
11363 free_number(p->txy);
11364 free_number(p->tyx);
11365 free_number(p->tyy);
11366 mp_free_node (mp, (mp_node)p, text_node_size);
11369 @ The last two types of graphical objects that can occur in an edge structure
11370 are clipping paths and \&{setbounds} paths. These are slightly more difficult
11371 @:set_bounds_}{\&{setbounds} primitive@>
11372 to implement because we must keep track of exactly what is being clipped or
11373 bounded when pictures get merged together. For this reason, each clipping or
11374 \&{setbounds} operation is represented by a pair of nodes: first comes a
11375 node whose |path_p| gives the relevant path, then there is the list
11376 of objects to clip or bound followed by a closing node.
11378 @d has_color(A) (mp_type((A))<mp_start_clip_node_type)
11379 /* does a graphical object have color fields? */
11380 @d has_pen(A) (mp_type((A))<mp_text_node_type)
11381 /* does a graphical object have a |mp_pen_p| field? */
11382 @d is_start_or_stop(A) (mp_type((A))>=mp_start_clip_node_type)
11383 @d is_stop(A) (mp_type((A))>=mp_stop_clip_node_type)
11385 @<MPlib internal header stuff@>=
11386 typedef struct mp_start_clip_node_data {
11389 } mp_start_clip_node_data;
11390 typedef struct mp_start_clip_node_data *mp_start_clip_node;
11391 typedef struct mp_start_bounds_node_data {
11394 } mp_start_bounds_node_data;
11395 typedef struct mp_start_bounds_node_data *mp_start_bounds_node;
11396 typedef struct mp_stop_clip_node_data {
11398 } mp_stop_clip_node_data;
11399 typedef struct mp_stop_clip_node_data *mp_stop_clip_node;
11400 typedef struct mp_stop_bounds_node_data {
11402 } mp_stop_bounds_node_data;
11403 typedef struct mp_stop_bounds_node_data *mp_stop_bounds_node;
11406 @ @<Graphical object codes@>=
11407 mp_start_clip_code = 4, /* |type| of a node that starts clipping */
11408 mp_start_bounds_code = 5, /* |type| of a node that gives a \&{setbounds} path */
11409 mp_stop_clip_code = 6, /* |type| of a node that stops clipping */
11410 mp_stop_bounds_code = 7, /* |type| of a node that stops \&{setbounds} */
11415 @d start_clip_size sizeof(struct mp_start_clip_node_data)
11416 @d stop_clip_size sizeof(struct mp_stop_clip_node_data)
11417 @d start_bounds_size sizeof(struct mp_start_bounds_node_data)
11418 @d stop_bounds_size sizeof(struct mp_stop_bounds_node_data)
11421 static mp_node mp_new_bounds_node (MP mp, mp_knot p, quarterword c) {
11422 /* make a node of type |c| where |p| is the clipping or \&{setbounds} path */
11423 if (c == mp_start_clip_node_type) {
11424 mp_start_clip_node t; /* the new node */
11425 t = (mp_start_clip_node) malloc_node (start_clip_size);
11429 return (mp_node) t;
11430 } else if (c == mp_start_bounds_node_type) {
11431 mp_start_bounds_node t; /* the new node */
11432 t = (mp_start_bounds_node) malloc_node (start_bounds_size);
11436 return (mp_node) t;
11437 } else if (c == mp_stop_clip_node_type) {
11438 mp_stop_clip_node t; /* the new node */
11439 t = (mp_stop_clip_node) malloc_node (stop_clip_size);
11442 return (mp_node) t;
11443 } else if (c == mp_stop_bounds_node_type) {
11444 mp_stop_bounds_node t; /* the new node */
11445 t = (mp_stop_bounds_node) malloc_node (stop_bounds_size);
11448 return (mp_node) t;
11457 static void mp_free_start_clip_node (MP mp, mp_start_clip_node p) {
11458 mp_toss_knot_list (mp, mp_path_p (p));
11459 mp_free_node (mp, (mp_node)p, start_clip_size);
11461 static void mp_free_start_bounds_node (MP mp, mp_start_bounds_node p) {
11462 mp_toss_knot_list (mp, mp_path_p (p));
11463 mp_free_node (mp, (mp_node)p, start_bounds_size);
11465 static void mp_free_stop_clip_node (MP mp, mp_stop_clip_node p) {
11466 mp_free_node (mp, (mp_node)p, stop_clip_size);
11468 static void mp_free_stop_bounds_node (MP mp, mp_stop_bounds_node p) {
11469 mp_free_node (mp, (mp_node)p, stop_bounds_size);
11473 @ All the essential information in an edge structure is encoded as a linked list
11474 of graphical objects as we have just seen, but it is helpful to add some
11475 redundant information. A single edge structure might be used as a dash pattern
11476 many times, and it would be nice to avoid scanning the same structure
11477 repeatedly. Thus, an edge structure known to be a suitable dash pattern
11478 has a header that gives a list of dashes in a sorted order designed for rapid
11479 translation into \ps.
11481 Each dash is represented by a three-word node containing the initial and final
11482 $x$~coordinates as well as the usual |link| field. The |link| fields points to
11483 the dash node with the next higher $x$-coordinates and the final link points
11484 to a special location called |null_dash|. (There should be no overlap between
11485 dashes). Since the $y$~coordinate of the dash pattern is needed to determine
11486 the period of repetition, this needs to be stored in the edge header along
11487 with a pointer to the list of dash nodes.
11489 The |dash_info| is explained below.
11491 @d dash_list(A) (mp_dash_node)(((mp_dash_node)(A))->link) /* in an edge header this points to the first dash node */
11492 @d set_dash_list(A,B) ((mp_dash_node)(A))->link=(mp_node)((B)) /* in an edge header this points to the first dash node */
11494 @<MPlib internal header stuff@>=
11495 typedef struct mp_dash_node_data {
11497 mp_number start_x; /* the starting $x$~coordinate in a dash node */
11498 mp_number stop_x; /* the ending $x$~coordinate in a dash node */
11499 mp_number dash_y; /* $y$ value for the dash list in an edge header */
11500 mp_node dash_info_;
11501 } mp_dash_node_data;
11504 typedef struct mp_dash_node_data *mp_dash_node;
11506 @ @<Initialize table entries@>=
11507 mp->null_dash = mp_get_dash_node (mp);
11509 @ @<Free table entries@>=
11510 mp_free_node (mp, (mp_node)mp->null_dash, dash_node_size);
11513 @d dash_node_size sizeof(struct mp_dash_node_data)
11516 static mp_dash_node mp_get_dash_node (MP mp) {
11517 mp_dash_node p = (mp_dash_node) malloc_node (dash_node_size);
11519 new_number(p->start_x);
11520 new_number(p->stop_x);
11521 new_number(p->dash_y);
11522 mp_type (p) = mp_dash_node_type;
11527 @ It is also convenient for an edge header to contain the bounding
11528 box information needed by the \&{llcorner} and \&{urcorner} operators
11529 so that this does not have to be recomputed unnecessarily. This is done by
11530 adding fields for the $x$~and $y$ extremes as well as a pointer that indicates
11531 how far the bounding box computation has gotten. Thus if the user asks for
11532 the bounding box and then adds some more text to the picture before asking
11533 for more bounding box information, the second computation need only look at
11534 the additional text.
11536 When the bounding box has not been computed, the |bblast| pointer points
11537 to a dummy link at the head of the graphical object list while the |minx_val|
11538 and |miny_val| fields contain |EL_GORDO| and the |maxx_val| and |maxy_val|
11539 fields contain |-EL_GORDO|.
11541 Since the bounding box of pictures containing objects of type
11542 |mp_start_bounds_node| depends on the value of \&{truecorners}, the bounding box
11543 @:mp_true_corners_}{\&{truecorners} primitive@>
11544 data might not be valid for all values of this parameter. Hence, the |bbtype|
11545 field is needed to keep track of this.
11547 @d bblast(A) ((mp_edge_header_node)(A))->bblast_ /* last item considered in bounding box computation */
11548 @d edge_list(A) ((mp_edge_header_node)(A))->list_ /* where the object list begins in an edge header */
11550 @<MPlib internal header stuff@>=
11551 typedef struct mp_edge_header_node_data {
11556 mp_node dash_info_;
11562 int bbtype; /* tells how bounding box data depends on \&{truecorners} */
11564 mp_node obj_tail_; /* explained below */
11565 halfword ref_count_; /* explained below */
11566 } mp_edge_header_node_data;
11567 typedef struct mp_edge_header_node_data *mp_edge_header_node;
11570 @d no_bounds 0 /* |bbtype| value when bounding box data is valid for all \&{truecorners} values */
11571 @d bounds_set 1 /* |bbtype| value when bounding box data is for \&{truecorners}${}\le 0$ */
11572 @d bounds_unset 2 /* |bbtype| value when bounding box data is for \&{truecorners}${}>0$ */
11574 static void mp_init_bbox (MP mp, mp_edge_header_node h) {
11575 /* Initialize the bounding box information in edge structure |h| */
11577 bblast (h) = edge_list (h);
11578 h->bbtype = no_bounds;
11579 set_number_to_inf(h->minx);
11580 set_number_to_inf(h->miny);
11581 set_number_to_neg_inf(h->maxx);
11582 set_number_to_neg_inf(h->maxy);
11586 @ The only other entries in an edge header are a reference count in the first
11587 word and a pointer to the tail of the object list in the last word.
11589 @d obj_tail(A) ((mp_edge_header_node)(A))->obj_tail_ /* points to the last entry in the object list */
11590 @d edge_ref_count(A) ((mp_edge_header_node)(A))->ref_count_
11592 @d edge_header_size sizeof(struct mp_edge_header_node_data)
11595 static mp_edge_header_node mp_get_edge_header_node (MP mp) {
11596 mp_edge_header_node p = (mp_edge_header_node) malloc_node (edge_header_size);
11597 mp_type (p) = mp_edge_header_node_type;
11598 new_number(p->start_x);
11599 new_number(p->stop_x);
11600 new_number(p->dash_y);
11601 new_number(p->minx);
11602 new_number(p->miny);
11603 new_number(p->maxx);
11604 new_number(p->maxy);
11605 p->list_ = mp_get_token_node (mp); /* or whatever, just a need a link handle */
11608 static void mp_init_edges (MP mp, mp_edge_header_node h) {
11609 /* initialize an edge header to NULL values */
11610 set_dash_list (h, mp->null_dash);
11611 obj_tail (h) = edge_list (h);
11612 mp_link (edge_list (h)) = NULL;
11613 edge_ref_count (h) = 0;
11614 mp_init_bbox (mp, h);
11618 @ Here is how edge structures are deleted. The process can be recursive because
11619 of the need to dereference edge structures that are used as dash patterns.
11622 @d add_edge_ref(A) incr(edge_ref_count((A)))
11623 @d delete_edge_ref(A) {
11624 if ( edge_ref_count((A))==0 )
11625 mp_toss_edges(mp, (mp_edge_header_node)(A));
11627 decr(edge_ref_count((A)));
11631 static void mp_flush_dash_list (MP mp, mp_edge_header_node h);
11632 static mp_edge_header_node mp_toss_gr_object (MP mp, mp_node p);
11633 static void mp_toss_edges (MP mp, mp_edge_header_node h);
11636 void mp_toss_edges (MP mp, mp_edge_header_node h) {
11637 mp_node p, q; /* pointers that scan the list being recycled */
11638 mp_edge_header_node r; /* an edge structure that object |p| refers to */
11639 mp_flush_dash_list (mp, h);
11640 q = mp_link (edge_list (h));
11641 while ((q != NULL)) {
11644 r = mp_toss_gr_object (mp, p);
11646 delete_edge_ref (r);
11648 free_number(h->start_x);
11649 free_number(h->stop_x);
11650 free_number(h->dash_y);
11651 free_number(h->minx);
11652 free_number(h->miny);
11653 free_number(h->maxx);
11654 free_number(h->maxy);
11655 mp_free_token_node (mp, h->list_);
11656 mp_free_node (mp, (mp_node)h, edge_header_size);
11658 void mp_flush_dash_list (MP mp, mp_edge_header_node h) {
11659 mp_dash_node p, q; /* pointers that scan the list being recycled */
11661 while (q != mp->null_dash) { /* todo: NULL check should not be needed */
11663 q = (mp_dash_node)mp_link (q);
11664 mp_free_node (mp, (mp_node)p, dash_node_size);
11666 set_dash_list (h,mp->null_dash);
11668 mp_edge_header_node mp_toss_gr_object (MP mp, mp_node p) {
11669 /* returns an edge structure that needs to be dereferenced */
11670 mp_edge_header_node e = NULL; /* the edge structure to return */
11671 switch (mp_type (p)) {
11672 case mp_fill_node_type:
11673 mp_free_fill_node (mp, (mp_fill_node)p);
11675 case mp_stroked_node_type:
11676 e = mp_free_stroked_node (mp, (mp_stroked_node)p);
11678 case mp_text_node_type:
11679 mp_free_text_node(mp, (mp_text_node)p);
11681 case mp_start_clip_node_type:
11682 mp_free_start_clip_node(mp, (mp_start_clip_node)p);
11684 case mp_start_bounds_node_type:
11685 mp_free_start_bounds_node(mp, (mp_start_bounds_node)p);
11687 case mp_stop_clip_node_type:
11688 mp_free_stop_clip_node(mp, (mp_stop_clip_node)p);
11690 case mp_stop_bounds_node_type:
11691 mp_free_stop_bounds_node(mp, (mp_stop_bounds_node)p);
11693 default: /* there are no other valid cases, but please the compiler */
11700 @ If we use |add_edge_ref| to ``copy'' edge structures, the real copying needs
11701 to be done before making a significant change to an edge structure. Much of
11702 the work is done in a separate routine |copy_objects| that copies a list of
11703 graphical objects into a new edge header.
11706 static mp_edge_header_node mp_private_edges (MP mp, mp_edge_header_node h) {
11707 /* make a private copy of the edge structure headed by |h| */
11708 mp_edge_header_node hh; /* the edge header for the new copy */
11709 mp_dash_node p, pp; /* pointers for copying the dash list */
11710 assert (mp_type (h) == mp_edge_header_node_type);
11711 if (edge_ref_count (h) == 0) {
11714 decr (edge_ref_count (h));
11715 hh = (mp_edge_header_node)mp_copy_objects (mp, mp_link (edge_list (h)), NULL);
11716 @<Copy the dash list from |h| to |hh|@>;
11717 @<Copy the bounding box information from |h| to |hh| and make |bblast(hh)|
11718 point into the new object list@>;
11724 @ Here we use the fact that |dash_list(hh)=mp_link(hh)|.
11725 @^data structure assumptions@>
11727 @<Copy the dash list from |h| to |hh|@>=
11728 pp = (mp_dash_node)hh;
11730 while ((p != mp->null_dash)) {
11731 mp_link (pp) = (mp_node)mp_get_dash_node (mp);
11732 pp = (mp_dash_node)mp_link (pp);
11733 number_clone(pp->start_x, p->start_x);
11734 number_clone(pp->stop_x, p->stop_x);
11735 p = (mp_dash_node)mp_link (p);
11737 mp_link (pp) = (mp_node)mp->null_dash;
11738 number_clone(hh->dash_y, h->dash_y )
11741 @ |h| is an edge structure
11744 static mp_dash_object *mp_export_dashes (MP mp, mp_stroked_node q, mp_number w) {
11747 mp_number scf; /* scale factor */
11749 double *dashes = NULL;
11750 int num_dashes = 1;
11751 h = (mp_dash_node)mp_dash_p (q);
11752 if (h == NULL || dash_list (h) == mp->null_dash)
11756 mp_get_pen_scale (mp, &scf, mp_pen_p (q));
11757 if (number_zero(scf)) {
11758 if (number_zero(w)) {
11759 number_clone(scf, q->dash_scale);
11767 make_scaled (ret, w, scf);
11768 take_scaled (scf, ret, q->dash_scale);
11771 number_clone(w, scf);
11772 d = xmalloc (1, sizeof (mp_dash_object));
11773 add_var_used (sizeof (mp_dash_object));
11774 set_number_from_addition(mp->null_dash->start_x, p->start_x, h->dash_y);
11776 mp_number ret, arg1;
11779 new_number (dashoff);
11780 while (p != mp->null_dash) {
11781 dashes = xrealloc (dashes, (num_dashes + 2), sizeof (double));
11782 set_number_from_substraction (arg1, p->stop_x, p->start_x);
11783 take_scaled (ret, arg1, scf);
11784 dashes[(num_dashes - 1)] = number_to_double (ret);
11785 set_number_from_substraction (arg1, ((mp_dash_node)mp_link (p))->start_x, p->stop_x);
11786 take_scaled (ret, arg1, scf);
11787 dashes[(num_dashes)] = number_to_double (ret);
11788 dashes[(num_dashes + 1)] = -1.0; /* terminus */
11790 p = (mp_dash_node)mp_link (p);
11793 mp_dash_offset (mp, &dashoff, h);
11794 take_scaled (ret, dashoff, scf);
11795 d->offset = number_to_double(ret);
11797 free_number (arg1);
11799 free_number (dashoff);
11805 @ @<Copy the bounding box information from |h| to |hh|...@>=
11806 number_clone(hh->minx, h->minx);
11807 number_clone(hh->miny, h->miny);
11808 number_clone(hh->maxx, h->maxx);
11809 number_clone(hh->maxy, h->maxy);
11810 hh->bbtype = h->bbtype;
11811 p = (mp_dash_node)edge_list (h);
11812 pp = (mp_dash_node)edge_list (hh);
11813 while ((p != (mp_dash_node)bblast (h))) {
11815 mp_confusion (mp, "bblast
");
11816 @:this can't happen bblast}{\quad bblast@>;
11817 p = (mp_dash_node)mp_link (p);
11818 pp = (mp_dash_node)mp_link (pp);
11820 bblast (hh) = (mp_node)pp
11822 @ Here is the promised routine for copying graphical objects into a new edge
11823 structure. It starts copying at object~|p| and stops just before object~|q|.
11824 If |q| is NULL, it copies the entire sublist headed at |p|. The resulting edge
11825 structure requires further initialization by |init_bbox|.
11828 static mp_edge_header_node mp_copy_objects (MP mp, mp_node p, mp_node q);
11831 mp_edge_header_node mp_copy_objects (MP mp, mp_node p, mp_node q) {
11832 mp_edge_header_node hh; /* the new edge header */
11833 mp_node pp; /* the last newly copied object */
11834 quarterword k = 0; /* temporary register */
11835 hh = mp_get_edge_header_node (mp);
11836 set_dash_list (hh, mp->null_dash);
11837 edge_ref_count (hh) = 0;
11838 pp = edge_list (hh);
11840 @<Make |mp_link(pp)| point to a copy of object |p|, and update |p| and |pp|@>;
11842 obj_tail (hh) = pp;
11843 mp_link (pp) = NULL;
11848 @ @<Make |mp_link(pp)| point to a copy of object |p|, and update |p| and |pp|@>=
11850 switch (mp_type (p)) {
11851 case mp_start_clip_node_type:
11852 k = start_clip_size;
11854 case mp_start_bounds_node_type:
11855 k = start_bounds_size;
11857 case mp_fill_node_type:
11858 k = fill_node_size;
11860 case mp_stroked_node_type:
11861 k = stroked_node_size;
11863 case mp_text_node_type:
11864 k = text_node_size;
11866 case mp_stop_clip_node_type:
11867 k = stop_clip_size;
11869 case mp_stop_bounds_node_type:
11870 k = stop_bounds_size;
11872 default: /* there are no other valid cases, but please the compiler */
11875 mp_link (pp) = malloc_node ((size_t) k); /* |gr_object| */
11877 memcpy (pp, p, (size_t) k);
11879 @<Fix anything in graphical object |pp| that should differ from the
11880 corresponding field in |p|@>;
11885 @ @<Fix anything in graphical object |pp| that should differ from the...@>=
11886 switch (mp_type (p)) {
11887 case mp_start_clip_node_type:
11889 mp_start_clip_node tt = (mp_start_clip_node)pp;
11890 mp_start_clip_node t = (mp_start_clip_node)p;
11891 mp_path_p (tt) = mp_copy_path (mp, mp_path_p (t));
11894 case mp_start_bounds_node_type:
11896 mp_start_bounds_node tt = (mp_start_bounds_node)pp;
11897 mp_start_bounds_node t = (mp_start_bounds_node)p;
11898 mp_path_p (tt) = mp_copy_path (mp, mp_path_p (t));
11901 case mp_fill_node_type:
11903 mp_fill_node tt = (mp_fill_node)pp;
11904 mp_fill_node t = (mp_fill_node)p;
11905 new_number(tt->red); number_clone(tt->red, t->red);
11906 new_number(tt->green); number_clone(tt->green, t->green);
11907 new_number(tt->blue); number_clone(tt->blue, t->blue);
11908 new_number(tt->black); number_clone(tt->black, t->black);
11909 new_number(tt->miterlim); number_clone(tt->miterlim,t->miterlim);
11910 mp_path_p (tt) = mp_copy_path (mp, mp_path_p (t));
11911 if (mp_pre_script (p) != NULL)
11912 add_str_ref (mp_pre_script (p));
11913 if (mp_post_script (p) != NULL)
11914 add_str_ref (mp_post_script (p));
11915 if (mp_pen_p (t) != NULL)
11916 mp_pen_p (tt) = copy_pen (mp_pen_p (t));
11919 case mp_stroked_node_type:
11921 mp_stroked_node tt = (mp_stroked_node)pp;
11922 mp_stroked_node t = (mp_stroked_node)p;
11923 new_number(tt->red); number_clone(tt->red, t->red);
11924 new_number(tt->green); number_clone(tt->green, t->green);
11925 new_number(tt->blue); number_clone(tt->blue, t->blue);
11926 new_number(tt->black); number_clone(tt->black, t->black);
11927 new_number(tt->miterlim); number_clone(tt->miterlim,t->miterlim);
11928 new_number(tt->dash_scale); number_clone(tt->dash_scale,t->dash_scale);
11929 if (mp_pre_script (p) != NULL)
11930 add_str_ref (mp_pre_script (p));
11931 if (mp_post_script (p) != NULL)
11932 add_str_ref (mp_post_script (p));
11933 mp_path_p (tt) = mp_copy_path (mp, mp_path_p (t));
11934 mp_pen_p (tt) = copy_pen (mp_pen_p (t));
11935 if (mp_dash_p (p) != NULL)
11936 add_edge_ref (mp_dash_p (pp));
11939 case mp_text_node_type:
11941 mp_text_node tt = (mp_text_node)pp;
11942 mp_text_node t = (mp_text_node)p;
11943 new_number(tt->red); number_clone(tt->red, t->red);
11944 new_number(tt->green); number_clone(tt->green, t->green);
11945 new_number(tt->blue); number_clone(tt->blue, t->blue);
11946 new_number(tt->black); number_clone(tt->black, t->black);
11947 new_number(tt->width); number_clone(tt->width, t->width);
11948 new_number(tt->height); number_clone(tt->height, t->height);
11949 new_number(tt->depth); number_clone(tt->depth, t->depth);
11950 new_number(tt->tx); number_clone(tt->tx, t->tx);
11951 new_number(tt->ty); number_clone(tt->ty, t->ty);
11952 new_number(tt->txx); number_clone(tt->txx, t->txx);
11953 new_number(tt->tyx); number_clone(tt->tyx, t->tyx);
11954 new_number(tt->txy); number_clone(tt->txy, t->txy);
11955 new_number(tt->tyy); number_clone(tt->tyy, t->tyy);
11956 if (mp_pre_script (p) != NULL)
11957 add_str_ref (mp_pre_script (p));
11958 if (mp_post_script (p) != NULL)
11959 add_str_ref (mp_post_script (p));
11960 add_str_ref (mp_text_p (pp));
11963 case mp_stop_clip_node_type:
11964 case mp_stop_bounds_node_type:
11966 default: /* there are no other valid cases, but please the compiler */
11971 @ Here is one way to find an acceptable value for the second argument to
11972 |copy_objects|. Given a non-NULL graphical object list, |skip_1component|
11973 skips past one picture component, where a ``picture component'' is a single
11974 graphical object, or a start bounds or start clip object and everything up
11975 through the matching stop bounds or stop clip object.
11978 static mp_node mp_skip_1component (MP mp, mp_node p) {
11979 integer lev; /* current nesting level */
11983 if (is_start_or_stop (p)) {
11990 } while (lev != 0);
11995 @ Here is a diagnostic routine for printing an edge structure in symbolic form.
11998 static void mp_print_edges (MP mp, mp_node h, const char *s, boolean nuline);
12001 void mp_print_edges (MP mp, mp_node h, const char *s, boolean nuline) {
12002 mp_node p; /* a graphical object to be printed */
12003 mp_number scf; /* a scale factor for the dash pattern */
12004 boolean ok_to_dash; /* |false| for polygonal pen strokes */
12006 mp_print_diagnostic (mp, "Edge structure
", s, nuline);
12008 while (mp_link (p) != NULL) {
12011 switch (mp_type (p)) {
12012 @<Cases for printing graphical object node |p|@>;
12014 mp_print (mp, "[unknown object type
!]");
12018 mp_print_nl (mp, "End edges
");
12019 if (p != obj_tail (h))
12020 mp_print (mp, "?
");
12022 mp_end_diagnostic (mp, true);
12027 @ @<Cases for printing graphical object node |p|@>=
12028 case mp_fill_node_type:
12029 mp_print (mp, "Filled contour
");
12030 mp_print_obj_color (mp, p);
12031 mp_print_char (mp, xord (':'));
12033 mp_pr_path (mp, mp_path_p ((mp_fill_node) p));
12035 if ((mp_pen_p ((mp_fill_node) p) != NULL)) {
12036 @<Print join type for graphical object |p|@>;
12037 mp_print (mp, " with pen
");
12039 mp_pr_pen (mp, mp_pen_p ((mp_fill_node) p));
12043 @ @<Print join type for graphical object |p|@>=
12044 switch (((mp_stroked_node)p)->ljoin) {
12046 mp_print (mp, "mitered joins limited
");
12047 print_number (((mp_stroked_node)p)->miterlim);
12050 mp_print (mp, "round joins
");
12053 mp_print (mp, "beveled joins
");
12056 mp_print (mp, "?? joins
");
12062 @ For stroked nodes, we need to print |lcap_val(p)| as well.
12064 @<Print join and cap types for stroked node |p|@>=
12065 switch (((mp_stroked_node)p)->lcap ) {
12067 mp_print (mp, "butt
");
12070 mp_print (mp, "round
");
12073 mp_print (mp, "square
");
12076 mp_print (mp, "??
");
12080 mp_print (mp, " ends
, ");
12081 @<Print join type for graphical object |p|@>
12084 @ Here is a routine that prints the color of a graphical object if it isn't
12085 black (the default color).
12088 static void mp_print_obj_color (MP mp, mp_node p);
12091 void mp_print_obj_color (MP mp, mp_node p) {
12092 mp_stroked_node p0 = (mp_stroked_node) p;
12093 if (mp_color_model (p) == mp_grey_model) {
12094 if (number_positive(p0->grey)) {
12095 mp_print (mp, "greyed
");
12096 mp_print_char (mp, xord ('('));
12097 print_number (p0->grey);
12098 mp_print_char (mp, xord (')'));
12100 } else if (mp_color_model (p) == mp_cmyk_model) {
12101 if (number_positive(p0->cyan) || number_positive(p0->magenta) ||
12102 number_positive(p0->yellow) || number_positive(p0->black)) {
12103 mp_print (mp, "processcolored
");
12104 mp_print_char (mp, xord ('('));
12105 print_number (p0->cyan);
12106 mp_print_char (mp, xord (','));
12107 print_number (p0->magenta);
12108 mp_print_char (mp, xord (','));
12109 print_number (p0->yellow);
12110 mp_print_char (mp, xord (','));
12111 print_number (p0->black);
12112 mp_print_char (mp, xord (')'));
12114 } else if (mp_color_model (p) == mp_rgb_model) {
12115 if (number_positive(p0->red) || number_positive(p0->green) ||
12116 number_positive(p0->blue)) {
12117 mp_print (mp, "colored
");
12118 mp_print_char (mp, xord ('('));
12119 print_number (p0->red);
12120 mp_print_char (mp, xord (','));
12121 print_number (p0->green);
12122 mp_print_char (mp, xord (','));
12123 print_number (p0->blue);
12124 mp_print_char (mp, xord (')'));
12130 @ @<Cases for printing graphical object node |p|@>=
12131 case mp_stroked_node_type:
12132 mp_print (mp, "Filled pen stroke
");
12133 mp_print_obj_color (mp, p);
12134 mp_print_char (mp, xord (':'));
12136 mp_pr_path (mp, mp_path_p ((mp_stroked_node) p));
12137 if (mp_dash_p (p) != NULL) {
12138 mp_print_nl (mp, "dashed
(");
12139 @<Finish printing the dash pattern that |p| refers to@>;
12142 @<Print join and cap types for stroked node |p|@>;
12143 mp_print (mp, " with pen
");
12145 if (mp_pen_p ((mp_stroked_node) p) == NULL) {
12146 mp_print (mp, "???
"); /* shouldn't happen */
12149 mp_pr_pen (mp, mp_pen_p ((mp_stroked_node) p));
12153 @ Normally, the |dash_list| field in an edge header is set to |null_dash|
12154 when it is not known to define a suitable dash pattern. This is disallowed
12155 here because the |mp_dash_p| field should never point to such an edge header.
12156 Note that memory is allocated for |start_x(null_dash)| and we are free to
12157 give it any convenient value.
12159 @<Finish printing the dash pattern that |p| refers to@>=
12161 mp_dash_node ppd, hhd;
12162 ok_to_dash = pen_is_elliptical (mp_pen_p ((mp_stroked_node) p));
12164 set_number_to_unity (scf);
12166 number_clone(scf, ((mp_stroked_node) p)->dash_scale);
12167 hhd = (mp_dash_node)mp_dash_p (p);
12168 ppd = dash_list (hhd);
12169 if ((ppd == mp->null_dash) || number_negative(hhd->dash_y)) {
12170 mp_print (mp, " ??
");
12173 mp_number ret, arg1;
12176 new_number (dashoff);
12177 set_number_from_addition(mp->null_dash->start_x, ppd->start_x, hhd->dash_y );
12178 while (ppd != mp->null_dash) {
12179 mp_print (mp, "on
");
12180 set_number_from_substraction (arg1, ppd->stop_x, ppd->start_x);
12181 take_scaled (ret, arg1, scf);
12182 print_number ( ret);
12183 mp_print (mp, " off
");
12184 set_number_from_substraction (arg1, ((mp_dash_node)mp_link (ppd))->start_x, ppd->stop_x);
12185 take_scaled (ret, arg1, scf);
12186 print_number (ret);
12187 ppd = (mp_dash_node)mp_link (ppd);
12188 if (ppd != mp->null_dash)
12189 mp_print_char (mp, xord (' '));
12191 mp_print (mp, ") shifted
");
12192 mp_dash_offset (mp, &dashoff, hhd);
12193 take_scaled (ret, dashoff, scf);
12194 number_negate (ret);
12195 print_number (ret);
12196 free_number (dashoff);
12198 free_number (arg1);
12199 if (!ok_to_dash || number_zero(hhd->dash_y) )
12200 mp_print (mp, " (this will be ignored
)");
12204 @ @<Declarations@>=
12205 static void mp_dash_offset (MP mp, mp_number *x, mp_dash_node h);
12208 void mp_dash_offset (MP mp, mp_number *x, mp_dash_node h) {
12209 if (dash_list (h) == mp->null_dash || number_negative(h->dash_y ))
12210 mp_confusion (mp, "dash0
");
12211 @:this can't happen dash0}{\quad dash0@>;
12212 if (number_zero(h->dash_y)) {
12213 set_number_to_zero(*x);
12215 number_clone (*x, (dash_list (h))->start_x );
12216 number_modulo (*x, h->dash_y);
12217 number_negate (*x);
12218 if (number_negative(*x))
12219 number_add(*x, h->dash_y);
12224 @ @<Cases for printing graphical object node |p|@>=
12225 case mp_text_node_type:
12227 mp_text_node p0 = (mp_text_node)p;
12228 mp_print_char (mp, xord ('"'
));
12229 mp_print_str
(mp
, mp_text_p
(p
));
12230 mp_print
(mp
, "\" infont \
"");
12231 mp_print
(mp
, mp-
>font_name
[mp_font_n
(p
)]);
12232 mp_print_char
(mp
, xord
('
"'));
12234 mp_print_obj_color (mp, p);
12235 mp_print (mp, "transformed
");
12236 mp_print_char (mp, xord ('('));
12237 print_number (p0->tx);
12238 mp_print_char (mp, xord (','));
12239 print_number (p0->ty);
12240 mp_print_char (mp, xord (','));
12241 print_number (p0->txx);
12242 mp_print_char (mp, xord (','));
12243 print_number (p0->txy);
12244 mp_print_char (mp, xord (','));
12245 print_number (p0->tyx);
12246 mp_print_char (mp, xord (','));
12247 print_number (p0->tyy);
12248 mp_print_char (mp, xord (')'));
12252 @ @<Cases for printing graphical object node |p|@>=
12253 case mp_start_clip_node_type:
12254 mp_print (mp, "clipping path
:");
12256 mp_pr_path (mp, mp_path_p ((mp_start_clip_node) p));
12258 case mp_stop_clip_node_type:
12259 mp_print (mp, "stop clipping
");
12262 @ @<Cases for printing graphical object node |p|@>=
12263 case mp_start_bounds_node_type:
12264 mp_print (mp, "setbounds path
:");
12266 mp_pr_path (mp, mp_path_p ((mp_start_bounds_node) p));
12268 case mp_stop_bounds_node_type:
12269 mp_print (mp, "end of setbounds
");
12272 @ To initialize the |dash_list| field in an edge header~|h|, we need a
12273 subroutine that scans an edge structure and tries to interpret it as a dash
12274 pattern. This can only be done when there are no filled regions or clipping
12275 paths and all the pen strokes have the same color. The first step is to let
12276 $y_0$ be the initial $y$~coordinate of the first pen stroke. Then we implicitly
12277 project all the pen stroke paths onto the line $y=y_0$ and require that there
12278 be no retracing. If the resulting paths cover a range of $x$~coordinates of
12279 length $\Delta x$, we set |dash_y(h)| to the length of the dash pattern by
12280 finding the maximum of $\Delta x$ and the absolute value of~$y_0$.
12283 static mp_edge_header_node mp_make_dashes (MP mp, mp_edge_header_node h) { /* returns |h| or |NULL| */
12284 mp_node p; /* this scans the stroked nodes in the object list */
12285 mp_node p0; /* if not |NULL| this points to the first stroked node */
12286 mp_knot pp, qq, rr; /* pointers into |mp_path_p(p)| */
12287 mp_dash_node d, dd; /* pointers used to create the dash list */
12289 @<Other local variables in |make_dashes|@>;
12290 if (dash_list (h) != mp->null_dash)
12292 new_number (y0); /* the initial $y$ coordinate */
12294 p = mp_link (edge_list (h));
12295 while (p != NULL) {
12296 if (mp_type (p) != mp_stroked_node_type) {
12297 @<Compain that the edge structure contains a node of the wrong type
12298 and |goto not_found|@>;
12300 pp = mp_path_p ((mp_stroked_node) p);
12303 number_clone(y0, pp->y_coord);
12305 @<Make |d| point to a new dash node created from stroke |p| and path |pp|
12306 or |goto not_found| if there is an error@>;
12307 @<Insert |d| into the dash list and |goto not_found| if there is an error@>;
12310 if (dash_list (h) == mp->null_dash)
12311 goto NOT_FOUND; /* No error message */
12312 @<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>;
12313 @<Set |dash_y(h)| and merge the first and last dashes if necessary@>;
12318 @<Flush the dash list, recycle |h| and return |NULL|@>;
12322 @ @<Compain that the edge structure contains a node of the wrong type...@>=
12324 const char *hlp[] = {
12325 "When you say `dashed p'
, picture p should not contain any
",
12326 "text
, filled regions
, or clipping paths. This time it did
",
12327 "so I'll just make it a solid line instead.
",
12329 mp_back_error (mp, "Picture is too complicated to use as a dash pattern
", hlp, true);
12330 mp_get_x_next (mp);
12335 @ A similar error occurs when monotonicity fails.
12338 static void mp_x_retrace_error (MP mp);
12341 void mp_x_retrace_error (MP mp) {
12342 const char *hlp[] = {
12343 "When you say `dashed p'
, every path in p should be monotone
",
12344 "in x and there must be no overlapping. This failed
",
12345 "so I'll just make it a solid line instead.
",
12347 mp_back_error (mp, "Picture is too complicated to use as a dash pattern
", hlp, true);
12348 mp_get_x_next (mp);
12352 @ We stash |p| in |dash_info(d)| if |mp_dash_p(p)<>0| so that subsequent processing can
12353 handle the case where the pen stroke |p| is itself dashed.
12355 @d dash_info(A) ((mp_dash_node)(A))->dash_info_ /* in an edge header this points to the first dash node */
12357 @<Make |d| point to a new dash node created from stroke |p| and path...@>=
12358 @<Make sure |p| and |p0| are the same color and |goto not_found| if there is
12361 if (mp_next_knot (pp) != pp) {
12364 rr = mp_next_knot (rr);
12365 @<Check for retracing between knots |qq| and |rr| and |goto not_found|
12366 if there is a problem@>;
12367 } while (mp_right_type (rr) != mp_endpoint);
12369 d = (mp_dash_node)mp_get_dash_node (mp);
12370 if (mp_dash_p (p) == NULL)
12371 dash_info (d) = NULL;
12374 if (number_less (pp->x_coord, rr->x_coord)) {
12375 number_clone(d->start_x, pp->x_coord);
12376 number_clone(d->stop_x, rr->x_coord);
12378 number_clone(d->start_x, rr->x_coord);
12379 number_clone(d->stop_x, pp->x_coord);
12383 @ We also need to check for the case where the segment from |qq| to |rr| is
12384 monotone in $x$ but is reversed relative to the path from |pp| to |qq|.
12386 @<Check for retracing between knots |qq| and |rr| and |goto not_found|...@>=
12388 mp_number x0, x1, x2, x3; /* $x$ coordinates of the segment from |qq| to |rr| */
12393 number_clone(x0, qq->x_coord);
12394 number_clone(x1, qq->right_x);
12395 number_clone(x2, rr->left_x);
12396 number_clone(x3, rr->x_coord);
12397 if (number_greater(x0, x1) || number_greater(x1, x2) || number_greater(x2, x3)) {
12398 if (number_less(x0, x1) || number_less(x1, x2) || number_less(x2, x3)) {
12399 mp_number a1, a2, a3, a4;
12406 set_number_from_substraction(a1, x2, x1);
12407 set_number_from_substraction(a2, x2, x1);
12408 set_number_from_substraction(a3, x1, x0);
12409 set_number_from_substraction(a4, x3, x2);
12410 ab_vs_cd (test, a1, a2, a3, a4);
12415 if (number_positive(test)) {
12416 mp_x_retrace_error (mp);
12427 if (number_greater(pp->x_coord, x0) || number_greater(x0, x3)) {
12428 if (number_less (pp->x_coord, x0) || number_less(x0, x3)) {
12429 mp_x_retrace_error (mp);
12443 @ @<Make sure |p| and |p0| are the same color and |goto not_found|...@>=
12444 if (!number_equal(((mp_stroked_node)p)->red, ((mp_stroked_node)p0)->red) ||
12445 !number_equal(((mp_stroked_node)p)->black, ((mp_stroked_node)p0)->black) ||
12446 !number_equal(((mp_stroked_node)p)->green, ((mp_stroked_node)p0)->green) ||
12447 !number_equal(((mp_stroked_node)p)->blue, ((mp_stroked_node)p0)->blue)
12449 const char *hlp[] = {
12450 "When you say `dashed p'
, everything in picture p should
",
12451 "be the same color. I can\'t handle your color changes
",
12452 "so I'll just make it a solid line instead.
",
12454 mp_back_error (mp, "Picture is too complicated to use as a dash pattern
", hlp, true);
12455 mp_get_x_next (mp);
12459 @ @<Insert |d| into the dash list and |goto not_found| if there is an error@>=
12460 number_clone(mp->null_dash->start_x, d->stop_x);
12461 dd = (mp_dash_node)h; /* this makes |mp_link(dd)=dash_list(h)| */
12462 while (number_less(((mp_dash_node)mp_link (dd))->start_x, d->stop_x ))
12463 dd = (mp_dash_node)mp_link (dd);
12464 if (dd != (mp_dash_node)h) {
12465 if (number_greater(dd->stop_x, d->start_x)) {
12466 mp_x_retrace_error (mp);
12470 mp_link (d) = mp_link (dd);
12471 mp_link (dd) = (mp_node)d
12473 @ @<Set |dash_y(h)| and merge the first and last dashes if necessary@>=
12475 while ((mp_link (d) != (mp_node)mp->null_dash))
12476 d = (mp_dash_node)mp_link (d);
12477 dd = dash_list (h);
12478 set_number_from_substraction(h->dash_y, d->stop_x, dd->start_x);
12481 new_number (absval);
12482 number_clone (absval, y0);
12483 number_abs (absval);
12484 if (number_greater (absval, h->dash_y) ) {
12485 number_clone(h->dash_y, absval);
12486 } else if (d != dd) {
12487 set_dash_list (h, mp_link (dd));
12488 set_number_from_addition(d->stop_x, dd->stop_x, h->dash_y);
12489 mp_free_node (mp, (mp_node)dd, dash_node_size);
12491 free_number (absval);
12493 @ We get here when the argument is a NULL picture or when there is an error.
12494 Recovering from an error involves making |dash_list(h)| empty to indicate
12495 that |h| is not known to be a valid dash pattern. We also dereference |h|
12496 since it is not being used for the return value.
12498 @<Flush the dash list, recycle |h| and return |NULL|@>=
12499 mp_flush_dash_list (mp, h);
12500 delete_edge_ref (h);
12503 @ Having carefully saved the dashed stroked nodes in the
12504 corresponding dash nodes, we must be prepared to break up these dashes into
12507 @<Scan |dash_list(h)| and deal with any dashes that are themselves dashed@>=
12509 mp_number hsf; /* the dash pattern from |hh| gets scaled by this */
12511 d = (mp_dash_node)h; /* now |mp_link(d)=dash_list(h)| */
12512 while (mp_link (d) != (mp_node)mp->null_dash) {
12513 ds = dash_info (mp_link (d));
12515 d = (mp_dash_node)mp_link (d);
12517 hh = (mp_edge_header_node)mp_dash_p (ds);
12518 number_clone(hsf, ((mp_stroked_node)ds)->dash_scale);
12520 mp_confusion (mp, "dash1
");
12521 @:this can't happen dash0}{\quad dash1@>;
12522 /* clang: dereference null pointer 'hh' */ assert(hh);
12523 if (number_zero(((mp_dash_node)hh)->dash_y )) {
12524 d = (mp_dash_node)mp_link (d);
12526 if (dash_list (hh) == NULL)
12527 mp_confusion (mp, "dash1
");
12528 @:this can't happen dash0}{\quad dash1@>;
12529 @<Replace |mp_link(d)| by a dashed version as determined by edge header
12530 |hh| and scale factor |ds|@>;
12537 @ @<Other local variables in |make_dashes|@>=
12538 mp_dash_node dln; /* |mp_link(d)| */
12539 mp_edge_header_node hh; /* an edge header that tells how to break up |dln| */
12540 mp_node ds; /* the stroked node from which |hh| and |hsf| are derived */
12542 @ @<Replace |mp_link(d)| by a dashed version as determined by edge header...@>=
12544 mp_number xoff; /* added to $x$ values in |dash_list(hh)| to match |dln| */
12549 dln = (mp_dash_node)mp_link (d);
12550 dd = dash_list (hh);
12551 /* clang: dereference null pointer 'dd' */ assert(dd);
12553 new_number (dashoff);
12554 mp_dash_offset (mp, &dashoff, (mp_dash_node)hh);
12555 take_scaled (r1, hsf, dd->start_x);
12556 take_scaled (r2, hsf, dashoff);
12557 number_add (r1, r2);
12558 set_number_from_substraction(xoff, dln->start_x, r1);
12559 free_number (dashoff);
12560 take_scaled (r1, hsf, dd->start_x);
12561 take_scaled (r2, hsf, hh->dash_y);
12562 set_number_from_addition(mp->null_dash->start_x, r1, r2);
12563 number_clone(mp->null_dash->stop_x, mp->null_dash->start_x);
12564 @<Advance |dd| until finding the first dash that overlaps |dln| when
12565 offset by |xoff|@>;
12566 while (number_lessequal(dln->start_x, dln->stop_x)) {
12567 @<If |dd| has `fallen off the end', back up to the beginning and fix |xoff|@>;
12568 @<Insert a dash between |d| and |dln| for the overlap with the offset version
12570 dd = (mp_dash_node)mp_link (dd);
12571 take_scaled (r1, hsf, dd->start_x);
12572 set_number_from_addition(dln->start_x , xoff, r1);
12577 mp_link (d) = mp_link (dln);
12578 mp_free_node (mp, (mp_node)dln, dash_node_size);
12582 @ The name of this module is a bit of a lie because we just find the
12583 first |dd| where |take_scaled (hsf, stop_x(dd))| is large enough to make an
12584 overlap possible. It could be that the unoffset version of dash |dln| falls
12585 in the gap between |dd| and its predecessor.
12587 @<Advance |dd| until finding the first dash that overlaps |dln| when...@>=
12591 take_scaled (r1, hsf, dd->stop_x);
12592 number_add (r1, xoff);
12593 while (number_less(r1, dln->start_x)) {
12594 dd = (mp_dash_node)mp_link (dd);
12595 take_scaled (r1, hsf, dd->stop_x);
12596 number_add (r1, xoff);
12601 @ @<If |dd| has `fallen off the end', back up to the beginning and fix...@>=
12602 if (dd == mp->null_dash) {
12605 dd = dash_list (hh);
12606 take_scaled (ret, hsf, hh->dash_y);
12607 number_add(xoff, ret);
12611 @ At this point we already know that |start_x(dln)<=xoff+take_scaled(hsf,stop_x(dd))|.
12613 @<Insert a dash between |d| and |dln| for the overlap with the offset...@>=
12617 take_scaled (r1, hsf, dd->start_x);
12618 number_add (r1, xoff);
12619 if (number_lessequal(r1, dln->stop_x)) {
12620 mp_link (d) = (mp_node)mp_get_dash_node (mp);
12621 d = (mp_dash_node)mp_link (d);
12622 mp_link (d) = (mp_node)dln;
12623 take_scaled (r1, hsf, dd->start_x );
12624 number_add (r1, xoff);
12625 if (number_greater(dln->start_x, r1))
12626 number_clone(d->start_x, dln->start_x);
12628 number_clone(d->start_x, r1);
12630 take_scaled (r1, hsf, dd->stop_x);
12631 number_add (r1, xoff);
12632 if (number_less(dln->stop_x, r1))
12633 number_clone(d->stop_x, dln->stop_x );
12635 number_clone(d->stop_x, r1);
12641 @ The next major task is to update the bounding box information in an edge
12642 header~|h|. This is done via a procedure |adjust_bbox| that enlarges an edge
12643 header's bounding box to accommodate the box computed by |path_bbox| or
12644 |pen_bbox|. (This is stored in global variables |minx|, |miny|, |maxx|, and
12648 static void mp_adjust_bbox (MP mp, mp_edge_header_node h) {
12649 if (number_less (mp_minx, h->minx))
12650 number_clone(h->minx, mp_minx);
12651 if (number_less (mp_miny, h->miny))
12652 number_clone(h->miny, mp_miny);
12653 if (number_greater (mp_maxx, h->maxx))
12654 number_clone(h->maxx, mp_maxx);
12655 if (number_greater (mp_maxy, h->maxy))
12656 number_clone(h->maxy, mp_maxy);
12660 @ Here is a special routine for updating the bounding box information in
12661 edge header~|h| to account for the squared-off ends of a non-cyclic path~|p|
12662 that is to be stroked with the pen~|pp|.
12665 static void mp_box_ends (MP mp, mp_knot p, mp_knot pp, mp_edge_header_node h) {
12666 mp_knot q; /* a knot node adjacent to knot |p| */
12667 mp_fraction dx, dy; /* a unit vector in the direction out of the path at~|p| */
12668 mp_number d; /* a factor for adjusting the length of |(dx,dy)| */
12669 mp_number z; /* a coordinate being tested against the bounding box */
12670 mp_number xx, yy; /* the extreme pen vertex in the |(dx,dy)| direction */
12671 integer i; /* a loop counter */
12678 if (mp_right_type (p) != mp_endpoint) {
12679 q = mp_next_knot (p);
12681 @<Make |(dx,dy)| the final direction for the path segment from
12682 |q| to~|p|; set~|d|@>;
12683 pyth_add (d, dx, dy);
12684 if (number_positive(d)) {
12685 @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>;
12686 for (i = 1; i <= 2; i++) {
12687 @<Use |(dx,dy)| to generate a vertex of the square end cap and
12688 update the bounding box to accommodate it@>;
12693 if (mp_right_type (p) == mp_endpoint) {
12696 @<Advance |p| to the end of the path and make |q| the previous knot@>;
12710 @ @<Make |(dx,dy)| the final direction for the path segment from...@>=
12711 if (q == mp_next_knot (p)) {
12712 set_number_from_substraction(dx, p->x_coord, p->right_x);
12713 set_number_from_substraction(dy, p->y_coord, p->right_y);
12714 if (number_zero(dx) && number_zero(dy)) {
12715 set_number_from_substraction(dx, p->x_coord, q->left_x);
12716 set_number_from_substraction(dy, p->y_coord, q->left_y);
12719 set_number_from_substraction(dx, p->x_coord, p->left_x);
12720 set_number_from_substraction(dy, p->y_coord, p->left_y);
12721 if (number_zero(dx) && number_zero(dy)) {
12722 set_number_from_substraction(dx, p->x_coord, q->right_x);
12723 set_number_from_substraction(dy, p->y_coord, q->right_y);
12726 set_number_from_substraction(dx, p->x_coord, q->x_coord);
12727 set_number_from_substraction(dy, p->y_coord, q->y_coord);
12730 @ @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>=
12735 make_fraction (r, dx, d);
12736 number_clone(dx, r);
12737 make_fraction (r, dy, d);
12738 number_clone(dy, r);
12740 number_clone(arg1, dy);
12741 number_negate(arg1);
12742 mp_find_offset (mp, arg1, dx, pp);
12744 number_clone(xx, mp->cur_x);
12745 number_clone(yy, mp->cur_y);
12748 @ @<Use |(dx,dy)| to generate a vertex of the square end cap and...@>=
12750 mp_number r1, r2, arg1;
12754 mp_find_offset (mp, dx, dy, pp);
12755 set_number_from_substraction (arg1, xx, mp->cur_x);
12756 take_fraction (r1, arg1, dx);
12757 set_number_from_substraction (arg1, yy, mp->cur_y);
12758 take_fraction (r2, arg1, dy);
12759 set_number_from_addition(d, r1, r2);
12760 if ((number_negative(d) && (i == 1)) || (number_positive(d) && (i == 2)))
12761 mp_confusion (mp, "box_ends
");
12762 @:this can't happen box ends}{\quad\\{box\_ends}@>;
12763 take_fraction (r1, d, dx);
12764 set_number_from_addition(z, p->x_coord, mp->cur_x);
12765 number_add (z, r1);
12766 if (number_less(z, h->minx))
12767 number_clone(h->minx, z);
12768 if (number_greater(z, h->maxx))
12769 number_clone(h->maxx, z);
12770 take_fraction (r1, d, dy);
12771 set_number_from_addition(z, p->y_coord, mp->cur_y);
12772 number_add (z, r1);
12773 if (number_less(z, h->miny))
12774 number_clone(h->miny, z);
12775 if (number_greater(z, h->maxy))
12776 number_clone(h->maxy, z);
12779 free_number (arg1);
12782 @ @<Advance |p| to the end of the path and make |q| the previous knot@>=
12785 p = mp_next_knot (p);
12786 } while (mp_right_type (p) != mp_endpoint)
12788 @ The major difficulty in finding the bounding box of an edge structure is the
12789 effect of clipping paths. We treat them conservatively by only clipping to the
12790 clipping path's bounding box, but this still
12791 requires recursive calls to |set_bbox| in order to find the bounding box of
12793 the objects to be clipped. Such calls are distinguished by the fact that the
12794 boolean parameter |top_level| is false.
12797 void mp_set_bbox (MP mp, mp_edge_header_node h, boolean top_level) {
12798 mp_node p; /* a graphical object being considered */
12799 integer lev; /* nesting level for |mp_start_bounds_node| nodes */
12800 /* Wipe out any existing bounding box information if |bbtype(h)| is
12801 incompatible with |internal[mp_true_corners]| */
12802 switch (h->bbtype ) {
12806 if (number_positive(internal_value (mp_true_corners)))
12807 mp_init_bbox (mp, h);
12810 if (number_nonpositive(internal_value (mp_true_corners)))
12811 mp_init_bbox (mp, h);
12813 } /* there are no other cases */
12815 while (mp_link (bblast (h)) != NULL) {
12816 p = mp_link (bblast (h));
12818 switch (mp_type (p)) {
12819 case mp_stop_clip_node_type:
12821 mp_confusion (mp, "bbox
");
12824 @:this can't happen bbox}{\quad bbox@>;
12826 @<Other cases for updating the bounding box based on the type of object |p|@>;
12827 default: /* there are no other valid cases, but please the compiler */
12832 mp_confusion (mp, "bbox
");
12836 @ @<Declarations@>=
12837 static void mp_set_bbox (MP mp, mp_edge_header_node h, boolean top_level);
12840 @ @<Other cases for updating the bounding box...@>=
12841 case mp_fill_node_type:
12842 mp_path_bbox (mp, mp_path_p ((mp_fill_node) p));
12843 if (mp_pen_p ((mp_fill_node) p) != NULL) {
12844 mp_number x0a, y0a, x1a, y1a;
12849 number_clone (x0a, mp_minx);
12850 number_clone (y0a, mp_miny);
12851 number_clone (x1a, mp_maxx);
12852 number_clone (y1a, mp_maxy);
12853 mp_pen_bbox (mp, mp_pen_p ((mp_fill_node) p));
12854 number_add (mp_minx, x0a);
12855 number_add (mp_miny, y0a);
12856 number_add (mp_maxx, x1a);
12857 number_add (mp_maxy, y1a);
12863 mp_adjust_bbox (mp, h);
12866 @ @<Other cases for updating the bounding box...@>=
12867 case mp_start_bounds_node_type:
12868 if (number_positive (internal_value (mp_true_corners))) {
12869 h->bbtype = bounds_unset;
12871 h->bbtype = bounds_set;
12872 mp_path_bbox (mp, mp_path_p ((mp_start_bounds_node) p));
12873 mp_adjust_bbox (mp, h);
12874 @<Scan to the matching |mp_stop_bounds_node| node and update |p| and
12878 case mp_stop_bounds_node_type:
12879 if (number_nonpositive (internal_value (mp_true_corners)))
12880 mp_confusion (mp, "bbox2
");
12881 @:this can't happen bbox2}{\quad bbox2@>;
12884 @ @<Scan to the matching |mp_stop_bounds_node| node and update |p| and...@>=
12887 if (mp_link (p) == NULL)
12888 mp_confusion (mp, "bbox2
");
12889 @:this can't happen bbox2}{\quad bbox2@>;
12890 /* clang: dereference null pointer */ assert(mp_link(p));
12892 if (mp_type (p) == mp_start_bounds_node_type)
12894 else if (mp_type (p) == mp_stop_bounds_node_type)
12899 @ It saves a lot of grief here to be slightly conservative and not account for
12900 omitted parts of dashed lines. We also don't worry about the material omitted
12901 when using butt end caps. The basic computation is for round end caps and
12902 |box_ends| augments it for square end caps.
12904 @<Other cases for updating the bounding box...@>=
12905 case mp_stroked_node_type:
12906 mp_path_bbox (mp, mp_path_p ((mp_stroked_node) p));
12908 mp_number x0a, y0a, x1a, y1a;
12913 number_clone (x0a, mp_minx);
12914 number_clone (y0a, mp_miny);
12915 number_clone (x1a, mp_maxx);
12916 number_clone (y1a, mp_maxy);
12917 mp_pen_bbox (mp, mp_pen_p ((mp_stroked_node) p));
12918 number_add (mp_minx, x0a);
12919 number_add (mp_miny, y0a);
12920 number_add (mp_maxx, x1a);
12921 number_add (mp_maxy, y1a);
12927 mp_adjust_bbox (mp, h);
12928 if ((mp_left_type (mp_path_p ((mp_stroked_node) p)) == mp_endpoint)
12929 && (((mp_stroked_node) p)->lcap == 2))
12930 mp_box_ends (mp, mp_path_p ((mp_stroked_node) p),
12931 mp_pen_p ((mp_stroked_node) p), h);
12934 @ The height width and depth information stored in a text node determines a
12935 rectangle that needs to be transformed according to the transformation
12936 parameters stored in the text node.
12938 @<Other cases for updating the bounding box...@>=
12939 case mp_text_node_type:
12941 mp_number x0a, y0a, x1a, y1a, arg1;
12942 mp_text_node p0 = (mp_text_node)p;
12948 number_clone (arg1, p0->depth);
12949 number_negate (arg1);
12950 take_scaled (x1a, p0->txx, p0->width);
12951 take_scaled (y0a, p0->txy, arg1);
12952 take_scaled (y1a, p0->txy, p0->height);
12953 number_clone (mp_minx, p0->tx);
12954 number_clone (mp_maxx, mp_minx);
12955 if (number_less(y0a, y1a)) {
12956 number_add (mp_minx, y0a);
12957 number_add (mp_maxx, y1a);
12959 number_add (mp_minx, y1a);
12960 number_add (mp_maxx, y0a);
12962 if (number_negative(x1a))
12963 number_add (mp_minx, x1a);
12965 number_add (mp_maxx, x1a);
12966 take_scaled (x1a, p0->tyx, p0->width);
12967 number_clone (arg1, p0->depth);
12968 number_negate (arg1);
12969 take_scaled (y0a, p0->tyy, arg1);
12970 take_scaled (y1a, p0->tyy, p0->height);
12971 number_clone (mp_miny, p0->ty);
12972 number_clone (mp_maxy, mp_miny);
12973 if (number_less (y0a, y1a)) {
12974 number_add (mp_miny, y0a);
12975 number_add (mp_maxy, y1a);
12977 number_add (mp_miny, y1a);
12978 number_add (mp_maxy, y0a);
12980 if (number_negative(x1a))
12981 number_add (mp_miny, x1a);
12983 number_add (mp_maxy, x1a);
12984 mp_adjust_bbox (mp, h);
12989 free_number (arg1);
12993 @ This case involves a recursive call that advances |bblast(h)| to the node of
12994 type |mp_stop_clip_node| that matches |p|.
12996 @<Other cases for updating the bounding box...@>=
12997 case mp_start_clip_node_type:
12999 mp_number sminx, sminy, smaxx, smaxy;
13000 /* for saving the bounding box during recursive calls */
13001 mp_number x0a, y0a, x1a, y1a;
13006 new_number (sminx);
13007 new_number (sminy);
13008 new_number (smaxx);
13009 new_number (smaxy);
13010 mp_path_bbox (mp, mp_path_p ((mp_start_clip_node) p));
13011 number_clone (x0a, mp_minx);
13012 number_clone (y0a, mp_miny);
13013 number_clone (x1a, mp_maxx);
13014 number_clone (y1a, mp_maxy);
13015 number_clone (sminx, h->minx);
13016 number_clone (sminy, h->miny);
13017 number_clone (smaxx, h->maxx);
13018 number_clone (smaxy, h->maxy);
13019 @<Reinitialize the bounding box in header |h| and call |set_bbox| recursively
13020 starting at |mp_link(p)|@>;
13021 @<Clip the bounding box in |h| to the rectangle given by |x0a|, |x1a|,
13023 number_clone (mp_minx, sminx);
13024 number_clone (mp_miny, sminy);
13025 number_clone (mp_maxx, smaxx);
13026 number_clone (mp_maxy, smaxy);
13027 mp_adjust_bbox (mp, h);
13028 free_number (sminx);
13029 free_number (sminy);
13030 free_number (smaxx);
13031 free_number (smaxy);
13039 @ @<Reinitialize the bounding box in header |h| and call |set_bbox|...@>=
13040 set_number_to_inf(h->minx);
13041 set_number_to_inf(h->miny);
13042 set_number_to_neg_inf(h->maxx);
13043 set_number_to_neg_inf(h->maxy);
13044 mp_set_bbox (mp, h, false)
13047 @ @<Clip the bounding box in |h| to the rectangle given by |x0a|, |x1a|,...@>=
13048 if (number_less(h->minx, x0a))
13049 number_clone(h->minx, x0a);
13050 if (number_less(h->miny, y0a))
13051 number_clone(h->miny, y0a);
13052 if (number_greater(h->maxx, x1a))
13053 number_clone(h->maxx, x1a);
13054 if (number_greater(h->maxy, y1a))
13055 number_clone(h->maxy, y1a);
13057 @* Finding an envelope.
13058 When \MP\ has a path and a polygonal pen, it needs to express the desired
13059 shape in terms of things \ps\ can understand. The present task is to compute
13060 a new path that describes the region to be filled. It is convenient to
13061 define this as a two step process where the first step is determining what
13062 offset to use for each segment of the path.
13064 @ Given a pointer |c| to a cyclic path,
13065 and a pointer~|h| to the first knot of a pen polygon,
13066 the |offset_prep| routine changes the path into cubics that are
13067 associated with particular pen offsets. Thus if the cubic between |p|
13068 and~|q| is associated with the |k|th offset and the cubic between |q| and~|r|
13069 has offset |l| then |mp_info(q)=zero_off+l-k|. (The constant |zero_off| is added
13070 to because |l-k| could be negative.)
13072 After overwriting the type information with offset differences, we no longer
13073 have a true path so we refer to the knot list returned by |offset_prep| as an
13076 Since an envelope spec only determines relative changes in pen offsets,
13077 |offset_prep| sets a global variable |spec_offset| to the relative change from
13078 |h| to the first offset.
13080 @d zero_off 16384 /* added to offset changes to make them positive */
13083 integer spec_offset; /* number of pen edges between |h| and the initial offset */
13086 static mp_knot mp_offset_prep (MP mp, mp_knot c, mp_knot h) {
13087 int n; /* the number of vertices in the pen polygon */
13088 mp_knot c0, p, q, q0, r, w, ww; /* for list manipulation */
13089 int k_needed; /* amount to be added to |mp_info(p)| when it is computed */
13090 mp_knot w0; /* a pointer to pen offset to use just before |p| */
13091 mp_number dxin, dyin; /* the direction into knot |p| */
13092 int turn_amt; /* change in pen offsets for the current cubic */
13093 mp_number max_coef; /* used while scaling */
13095 @<Other local variables for |offset_prep|@>;
13096 new_number(max_coef);
13127 @<Initialize the pen size~|n|@>;
13128 @<Initialize the incoming direction and pen offset at |c|@>;
13133 q = mp_next_knot (p);
13134 @<Split the cubic between |p| and |q|, if necessary, into cubics
13135 associated with single offsets, after which |q| should
13136 point to the end of the final such cubic@>;
13138 @<Advance |p| to node |q|, removing any ``dead'' cubics that
13139 might have been introduced by the splitting process@>;
13141 @<Fix the offset change in |mp_knot_info(c)| and set |c| to the return value of
13145 free_number (dxin);
13146 free_number (dyin);
13155 free_number (max_coef);
13178 @ We shall want to keep track of where certain knots on the cyclic path
13179 wind up in the envelope spec. It doesn't suffice just to keep pointers to
13180 knot nodes because some nodes are deleted while removing dead cubics. Thus
13181 |offset_prep| updates the following pointers
13185 mp_knot spec_p2; /* pointers to distinguished knots */
13188 mp->spec_p1 = NULL;
13189 mp->spec_p2 = NULL;
13191 @ @<Initialize the pen size~|n|@>=
13196 p = mp_next_knot (p);
13199 @ Since the true incoming direction isn't known yet, we just pick a direction
13200 consistent with the pen offset~|h|. If this is wrong, it can be corrected
13203 @<Initialize the incoming direction and pen offset at |c|@>=
13205 mp_knot hn = mp_next_knot (h);
13206 mp_knot hp = mp_prev_knot (h);
13207 set_number_from_substraction(dxin, hn->x_coord, hp->x_coord);
13208 set_number_from_substraction(dyin, hn->y_coord, hp->y_coord);
13209 if (number_zero(dxin) && number_zero(dyin)) {
13210 set_number_from_substraction(dxin, hp->y_coord, h->y_coord);
13211 set_number_from_substraction(dyin, h->x_coord, hp->x_coord);
13216 @ We must be careful not to remove the only cubic in a cycle.
13218 But we must also be careful for another reason. If the user-supplied
13219 path starts with a set of degenerate cubics, the target node |q| can
13220 be collapsed to the initial node |p| which might be the same as the
13221 initial node |c| of the curve. This would cause the |offset_prep| routine
13222 to bail out too early, causing distress later on. (See for example
13223 the testcase reported by Bogus\l{}aw Jackowski in tracker id 267, case 52c
13226 @<Advance |p| to node |q|, removing any ``dead'' cubics...@>=
13229 r = mp_next_knot (p);
13230 if (number_equal (p->x_coord, p->right_x) &&
13231 number_equal (p->y_coord, p->right_y) &&
13232 number_equal (p->x_coord, r->left_x) &&
13233 number_equal (p->y_coord, r->left_y) &&
13234 number_equal (p->x_coord, r->x_coord) &&
13235 number_equal (p->y_coord, r->y_coord) &&
13236 r != p && r != q) {
13237 @<Remove the cubic following |p| and update the data structures
13238 to merge |r| into |p|@>;
13242 /* Check if we removed too much */
13243 if ((q != q0) && (q != c || c == c0))
13244 q = mp_next_knot (q)
13247 @ @<Remove the cubic following |p| and update the data structures...@>=
13249 k_needed = mp_knot_info (p) - zero_off;
13253 mp_knot_info (p) = k_needed + mp_knot_info (r);
13257 mp_knot_info (p) = mp_knot_info (c);
13260 if (r == mp->spec_p1)
13262 if (r == mp->spec_p2)
13265 mp_remove_cubic (mp, p);
13269 @ Not setting the |info| field of the newly created knot allows the splitting
13270 routine to work for paths.
13273 static void mp_split_cubic (MP mp, mp_knot p, mp_number t);
13276 void mp_split_cubic (MP mp, mp_knot p, mp_number t) { /* splits the cubic after |p| */
13277 mp_number v; /* an intermediate value */
13278 mp_knot q, r; /* for list manipulation */
13279 q = mp_next_knot (p);
13280 r = mp_new_knot (mp);
13281 mp_next_knot (p) = r;
13282 mp_next_knot (r) = q;
13283 mp_originator (r) = mp_program_code;
13284 mp_left_type (r) = mp_explicit;
13285 mp_right_type (r) = mp_explicit;
13287 set_number_from_of_the_way (v, t, p->right_x, q->left_x);
13288 set_number_from_of_the_way (p->right_x, t, p->x_coord, p->right_x);
13289 set_number_from_of_the_way (q->left_x, t, q->left_x, q->x_coord);
13290 set_number_from_of_the_way (r->left_x, t, p->right_x, v);
13291 set_number_from_of_the_way (r->right_x, t, v, q->left_x);
13292 set_number_from_of_the_way (r->x_coord, t, r->left_x, r->right_x);
13293 set_number_from_of_the_way (v, t, p->right_y, q->left_y);
13294 set_number_from_of_the_way (p->right_y, t, p->y_coord, p->right_y);
13295 set_number_from_of_the_way (q->left_y, t, q->left_y, q->y_coord);
13296 set_number_from_of_the_way (r->left_y, t, p->right_y, v);
13297 set_number_from_of_the_way (r->right_y, t, v, q->left_y);
13298 set_number_from_of_the_way (r->y_coord, t, r->left_y, r->right_y);
13303 @ This does not set |mp_knot_info(p)| or |mp_right_type(p)|.
13306 static void mp_remove_cubic (MP mp, mp_knot p);
13309 void mp_remove_cubic (MP mp, mp_knot p) { /* removes the dead cubic following~|p| */
13310 mp_knot q; /* the node that disappears */
13312 q = mp_next_knot (p);
13313 mp_next_knot (p) = mp_next_knot (q);
13314 number_clone (p->right_x, q->right_x);
13315 number_clone (p->right_y, q->right_y);
13320 @ Let $d\prec d'$ mean that the counter-clockwise angle from $d$ to~$d'$ is
13321 strictly between zero and $180^\circ$. Then we can define $d\preceq d'$ to
13322 mean that the angle could be zero or $180^\circ$. If $w_k=(u_k,v_k)$ is the
13323 $k$th pen offset, the $k$th pen edge direction is defined by the formula
13324 $$d_k=(u\k-u_k,\,v\k-v_k).$$
13325 When listed by increasing $k$, these directions occur in counter-clockwise
13326 order so that $d_k\preceq d\k$ for all~$k$.
13327 The goal of |offset_prep| is to find an offset index~|k| to associate with
13328 each cubic, such that the direction $d(t)$ of the cubic satisfies
13329 $$d_{k-1}\preceq d(t)\preceq d_k\qquad\hbox{for $0\le t\le 1$.}\eqno(*)$$
13330 We may have to split a cubic into many pieces before each
13331 piece corresponds to a unique offset.
13333 @<Split the cubic between |p| and |q|, if necessary, into cubics...@>=
13334 mp_knot_info (p) = zero_off + k_needed;
13336 @<Prepare for derivative computations;
13337 |goto not_found| if the current cubic is dead@>;
13338 @<Find the initial direction |(dx,dy)|@>;
13339 @<Update |mp_knot_info(p)| and find the offset $w_k$ such that
13340 $d_{k-1}\preceq(\\{dx},\\{dy})\prec d_k$; also advance |w0| for
13341 the direction change at |p|@>;
13342 @<Find the final direction |(dxin,dyin)|@>;
13343 @<Decide on the net change in pen offsets and set |turn_amt|@>;
13344 @<Complete the offset splitting process@>;
13345 w0 = mp_pen_walk (mp, w0, turn_amt)
13348 @ @<Declarations@>=
13349 static mp_knot mp_pen_walk (MP mp, mp_knot w, integer k);
13352 mp_knot mp_pen_walk (MP mp, mp_knot w, integer k) {
13353 /* walk |k| steps around a pen from |w| */
13356 w = mp_next_knot (w);
13360 w = mp_prev_knot (w);
13367 @ The direction of a cubic $B(z_0,z_1,z_2,z_3;t)=\bigl(x(t),y(t)\bigr)$ can be
13368 calculated from the quadratic polynomials
13369 ${1\over3}x'(t)=B(x_1-x_0,x_2-x_1,x_3-x_2;t)$ and
13370 ${1\over3}y'(t)=B(y_1-y_0,y_2-y_1,y_3-y_2;t)$.
13371 Since we may be calculating directions from several cubics
13372 split from the current one, it is desirable to do these calculations
13373 without losing too much precision. ``Scaled up'' values of the
13374 derivatives, which will be less tainted by accumulated errors than
13375 derivatives found from the cubics themselves, are maintained in
13376 local variables |x0|, |x1|, and |x2|, representing $X_0=2^l(x_1-x_0)$,
13377 $X_1=2^l(x_2-x_1)$, and $X_2=2^l(x_3-x_2)$; similarly |y0|, |y1|, and~|y2|
13378 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)$.
13380 @<Other local variables for |offset_prep|@>=
13381 mp_number x0, x1, x2, y0, y1, y2; /* representatives of derivatives */
13382 mp_number t0, t1, t2; /* coefficients of polynomial for slope testing */
13383 mp_number du, dv, dx, dy; /* for directions of the pen and the curve */
13384 mp_number dx0, dy0; /* initial direction for the first cubic in the curve */
13385 mp_number x0a, x1a, x2a, y0a, y1a, y2a; /* intermediate values */
13386 mp_number t; /* where the derivative passes through zero */
13387 mp_number s; /* a temporary value */
13389 @ @<Prepare for derivative computations...@>=
13390 set_number_from_substraction(x0, p->right_x, p->x_coord);
13391 set_number_from_substraction(x2, q->x_coord, q->left_x);
13392 set_number_from_substraction(x1, q->left_x, p->right_x);
13393 set_number_from_substraction(y0, p->right_y, p->y_coord);
13394 set_number_from_substraction(y2, q->y_coord, q->left_y);
13395 set_number_from_substraction(y1, q->left_y, p->right_y);
13398 new_number (absval);
13399 number_clone(absval, x1);
13400 number_abs(absval);
13401 number_clone(max_coef, x0);
13402 number_abs (max_coef);
13403 if (number_greater(absval, max_coef)) {
13404 number_clone(max_coef, absval);
13406 number_clone(absval, x2);
13407 number_abs(absval);
13408 if (number_greater(absval, max_coef)) {
13409 number_clone(max_coef, absval);
13411 number_clone(absval, y0);
13412 number_abs(absval);
13413 if (number_greater(absval, max_coef)) {
13414 number_clone(max_coef, absval);
13416 number_clone(absval, y1);
13417 number_abs(absval);
13418 if (number_greater(absval, max_coef)) {
13419 number_clone(max_coef, absval);
13421 number_clone(absval, y2);
13422 number_abs(absval);
13423 if (number_greater(absval, max_coef)) {
13424 number_clone(max_coef, absval);
13426 if (number_zero(max_coef)) {
13429 free_number (absval);
13431 while (number_less(max_coef, fraction_half_t)) {
13432 number_double (max_coef);
13433 number_double (x0);
13434 number_double (x1);
13435 number_double (x2);
13436 number_double (y0);
13437 number_double (y1);
13438 number_double (y2);
13442 @ Let us first solve a special case of the problem: Suppose we
13443 know an index~$k$ such that either (i)~$d(t)\succeq d_{k-1}$ for all~$t$
13444 and $d(0)\prec d_k$, or (ii)~$d(t)\preceq d_k$ for all~$t$ and
13445 $d(0)\succ d_{k-1}$.
13446 Then, in a sense, we're halfway done, since one of the two relations
13447 in $(*)$ is satisfied, and the other couldn't be satisfied for
13448 any other value of~|k|.
13450 Actually, the conditions can be relaxed somewhat since a relation such as
13451 $d(t)\succeq d_{k-1}$ restricts $d(t)$ to a half plane when all that really
13452 matters is whether $d(t)$ crosses the ray in the $d_{k-1}$ direction from
13453 the origin. The condition for case~(i) becomes $d_{k-1}\preceq d(0)\prec d_k$
13454 and $d(t)$ never crosses the $d_{k-1}$ ray in the clockwise direction.
13455 Case~(ii) is similar except $d(t)$ cannot cross the $d_k$ ray in the
13456 counterclockwise direction.
13458 The |fin_offset_prep| subroutine solves the stated subproblem.
13459 It has a parameter called |rise| that is |1| in
13460 case~(i), |-1| in case~(ii). Parameters |x0| through |y2| represent
13461 the derivative of the cubic following |p|.
13462 The |w| parameter should point to offset~$w_k$ and |mp_info(p)| should already
13463 be set properly. The |turn_amt| parameter gives the absolute value of the
13464 overall net change in pen offsets.
13467 static void mp_fin_offset_prep (MP mp, mp_knot p, mp_knot w, mp_number
13468 x0, mp_number x1, mp_number x2, mp_number y0,
13469 mp_number y1, mp_number y2, integer rise,
13473 void mp_fin_offset_prep (MP mp, mp_knot p, mp_knot w, mp_number
13474 x0, mp_number x1, mp_number x2, mp_number y0, mp_number y1,
13475 mp_number y2, integer rise, integer turn_amt) {
13476 mp_knot ww; /* for list manipulation */
13477 mp_number du, dv; /* for slope calculation */
13478 mp_number t0, t1, t2; /* test coefficients */
13479 mp_number t; /* place where the derivative passes a critical slope */
13480 mp_number s; /* slope or reciprocal slope */
13481 mp_number v; /* intermediate value for updating |x0..y2| */
13482 mp_knot q; /* original |mp_next_knot(p)| */
13483 q = mp_next_knot (p);
13494 ww = mp_next_knot (w); /* a pointer to $w\k$ */
13496 ww = mp_prev_knot (w); /* a pointer to $w_{k-1}$ */
13497 @<Compute test coefficients |(t0,t1,t2)|
13498 for $d(t)$ versus $d_k$ or $d_{k-1}$@>;
13499 crossing_point (t, t0, t1, t2);
13500 if (number_greaterequal(t, fraction_one_t)) {
13502 number_clone(t, fraction_one_t);
13506 @<Split the cubic at $t$,
13507 and split off another cubic if the derivative crosses back@>;
13522 @ We want $B(\\{t0},\\{t1},\\{t2};t)$ to be the dot product of $d(t)$ with a
13523 $-90^\circ$ rotation of the vector from |w| to |ww|. This makes the resulting
13524 function cross from positive to negative when $d_{k-1}\preceq d(t)\preceq d_k$
13527 @<Compute test coefficients |(t0,t1,t2)| for $d(t)$ versus...@>=
13529 mp_number abs_du, abs_dv;
13530 new_number (abs_du);
13531 new_number (abs_dv);
13532 set_number_from_substraction(du, ww->x_coord, w->x_coord);
13533 set_number_from_substraction(dv, ww->y_coord, w->y_coord);
13534 number_clone(abs_du, du);
13535 number_abs(abs_du);
13536 number_clone(abs_dv, dv);
13537 number_abs(abs_dv);
13538 if (number_greaterequal(abs_du, abs_dv)) {
13541 make_fraction (s, dv, du);
13542 take_fraction (r1, x0, s);
13543 set_number_from_substraction(t0, r1, y0);
13544 take_fraction (r1, x1, s);
13545 set_number_from_substraction(t1, r1, y1);
13546 take_fraction (r1, x2, s);
13547 set_number_from_substraction(t2, r1, y2);
13548 if (number_negative(du)) {
13549 number_negate (t0);
13550 number_negate (t1);
13551 number_negate (t2);
13557 make_fraction (s, du, dv);
13558 take_fraction (r1, y0, s);
13559 set_number_from_substraction(t0, x0, r1);
13560 take_fraction (r1, y1, s);
13561 set_number_from_substraction(t1, x1, r1);
13562 take_fraction (r1, y2, s);
13563 set_number_from_substraction(t2, x2, r1);
13564 if (number_negative(dv)) {
13565 number_negate (t0);
13566 number_negate (t1);
13567 number_negate (t2);
13571 free_number (abs_du);
13572 free_number (abs_dv);
13573 if (number_negative(t0))
13574 set_number_to_zero(t0); /* should be positive without rounding error */
13578 @ The curve has crossed $d_k$ or $d_{k-1}$; its initial segment satisfies
13579 $(*)$, and it might cross again and return towards $s_{k-1}$ or $s_k$,
13580 respectively, yielding another solution of $(*)$.
13582 @<Split the cubic at $t$, and split off another...@>=
13584 mp_split_cubic (mp, p, t);
13585 p = mp_next_knot (p);
13586 mp_knot_info (p) = zero_off + rise;
13588 set_number_from_of_the_way(v, t, x0, x1);
13589 set_number_from_of_the_way(x1, t, x1, x2);
13590 set_number_from_of_the_way(x0, t, v, x1);
13591 set_number_from_of_the_way(v, t, y0, y1);
13592 set_number_from_of_the_way(y1, t, y1, y2);
13593 set_number_from_of_the_way(y0, t, v, y1);
13594 if (turn_amt < 0) {
13595 mp_number arg1, arg2, arg3;
13599 set_number_from_of_the_way(t1, t, t1, t2);
13600 if (number_positive(t1))
13601 set_number_to_zero(t1); /* without rounding error, |t1| would be |<=0| */
13602 number_clone(arg2, t1);
13603 number_negate(arg2);
13604 number_clone(arg3, t2);
13605 number_negate(arg3);
13606 crossing_point (t, arg1, arg2, arg3);
13607 free_number (arg1);
13608 free_number (arg2);
13609 free_number (arg3);
13610 if (number_greater(t, fraction_one_t))
13611 number_clone(t, fraction_one_t);
13613 if (number_equal(t,fraction_one_t) && (mp_next_knot (p) != q)) {
13614 mp_knot_info (mp_next_knot (p)) = mp_knot_info (mp_next_knot (p)) - rise;
13616 mp_split_cubic (mp, p, t);
13617 mp_knot_info (mp_next_knot (p)) = zero_off - rise;
13618 set_number_from_of_the_way(v, t, x1, x2);
13619 set_number_from_of_the_way(x1, t, x0, x1);
13620 set_number_from_of_the_way(x2, t, x1, v);
13621 set_number_from_of_the_way(v, t, y1, y2);
13622 set_number_from_of_the_way(y1, t, y0, y1);
13623 set_number_from_of_the_way(y2, t, y1, v);
13629 @ Now we must consider the general problem of |offset_prep|, when
13630 nothing is known about a given cubic. We start by finding its
13631 direction in the vicinity of |t=0|.
13633 If $z'(t)=0$, the given cubic is numerically unstable but |offset_prep|
13634 has not yet introduced any more numerical errors. Thus we can compute
13635 the true initial direction for the given cubic, even if it is almost
13638 @<Find the initial direction |(dx,dy)|@>=
13639 number_clone(dx, x0);
13640 number_clone(dy, y0);
13641 if (number_zero(dx) && number_zero(dy)) {
13642 number_clone(dx, x1);
13643 number_clone(dy, y1);
13644 if (number_zero(dx) && number_zero(dy)) {
13645 number_clone(dx, x2);
13646 number_clone(dy, y2);
13650 number_clone(dx0, dx);
13651 number_clone(dy0, dy);
13654 @ @<Find the final direction |(dxin,dyin)|@>=
13655 number_clone(dxin, x2);
13656 number_clone(dyin, y2);
13657 if (number_zero(dxin) && number_zero(dyin)) {
13658 number_clone(dxin, x1);
13659 number_clone(dyin, y1);
13660 if (number_zero(dxin) && number_zero(dyin)) {
13661 number_clone(dxin, x0);
13662 number_clone(dyin, y0);
13666 @ The next step is to bracket the initial direction between consecutive
13667 edges of the pen polygon. We must be careful to turn clockwise only if
13668 this makes the turn less than $180^\circ$. (A $180^\circ$ turn must be
13669 counter-clockwise in order to make \&{doublepath} envelopes come out
13670 @:double_path_}{\&{doublepath} primitive@>
13671 right.) This code depends on |w0| being the offset for |(dxin,dyin)|.
13673 @<Update |mp_knot_info(p)| and find the offset $w_k$ such that...@>=
13675 mp_number ab_vs_cd;
13676 new_number (ab_vs_cd);
13677 ab_vs_cd (ab_vs_cd, dy, dxin, dx, dyin);
13678 turn_amt = mp_get_turn_amt (mp, w0, dx, dy, number_nonnegative(ab_vs_cd));
13679 free_number (ab_vs_cd);
13680 w = mp_pen_walk (mp, w0, turn_amt);
13682 mp_knot_info (p) = mp_knot_info (p) + turn_amt;
13685 @ Decide how many pen offsets to go away from |w| in order to find the offset
13686 for |(dx,dy)|, going counterclockwise if |ccw| is |true|. This assumes that
13687 |w| is the offset for some direction $(x',y')$ from which the angle to |(dx,dy)|
13688 in the sense determined by |ccw| is less than or equal to $180^\circ$.
13690 If the pen polygon has only two edges, they could both be parallel
13691 to |(dx,dy)|. In this case, we must be careful to stop after crossing the first
13692 such edge in order to avoid an infinite loop.
13695 static integer mp_get_turn_amt (MP mp, mp_knot w, mp_number dx,
13696 mp_number dy, boolean ccw);
13699 integer mp_get_turn_amt (MP mp, mp_knot w, mp_number dx, mp_number dy, boolean ccw) {
13700 mp_knot ww; /* a neighbor of knot~|w| */
13701 integer s; /* turn amount so far */
13702 mp_number t; /* |ab_vs_cd| result */
13703 mp_number arg1, arg2;
13709 ww = mp_next_knot (w);
13711 set_number_from_substraction (arg1, ww->x_coord, w->x_coord);
13712 set_number_from_substraction (arg2, ww->y_coord, w->y_coord);
13713 ab_vs_cd (t, dy, arg1, dx, arg2);
13714 if (number_negative(t))
13718 ww = mp_next_knot (ww);
13719 } while (number_positive(t));
13721 ww = mp_prev_knot (w);
13722 set_number_from_substraction (arg1, w->x_coord, ww->x_coord);
13723 set_number_from_substraction (arg2, w->y_coord, ww->y_coord);
13724 ab_vs_cd (t, dy, arg1, dx, arg2);
13725 while (number_negative(t)) {
13728 ww = mp_prev_knot (ww);
13729 set_number_from_substraction (arg1, w->x_coord, ww->x_coord);
13730 set_number_from_substraction (arg2, w->y_coord, ww->y_coord);
13731 ab_vs_cd (t, dy, arg1, dx, arg2);
13735 free_number (arg1);
13736 free_number (arg2);
13741 @ When we're all done, the final offset is |w0| and the final curve direction
13742 is |(dxin,dyin)|. With this knowledge of the incoming direction at |c|, we
13743 can correct |mp_info(c)| which was erroneously based on an incoming offset
13746 @d fix_by(A) mp_knot_info(c)=mp_knot_info(c)+(A)
13748 @<Fix the offset change in |mp_knot_info(c)| and set |c| to the return value of...@>=
13749 mp->spec_offset = mp_knot_info (c) - zero_off;
13750 if (mp_next_knot (c) == c) {
13751 mp_knot_info (c) = zero_off + n;
13753 mp_number ab_vs_cd;
13754 new_number (ab_vs_cd);
13758 w0 = mp_next_knot (w0);
13760 while (mp_knot_info (c) <= zero_off - n)
13762 while (mp_knot_info (c) > zero_off)
13764 ab_vs_cd (ab_vs_cd, dy0, dxin, dx0, dyin);
13765 if ((mp_knot_info (c) != zero_off) && number_nonnegative(ab_vs_cd))
13767 free_number (ab_vs_cd);
13771 @ Finally we want to reduce the general problem to situations that
13772 |fin_offset_prep| can handle. We split the cubic into at most three parts
13773 with respect to $d_{k-1}$, and apply |fin_offset_prep| to each part.
13775 @<Complete the offset splitting process@>=
13776 ww = mp_prev_knot (w);
13777 @<Compute test coeff...@>;
13778 @<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set
13779 |t:=fraction_one+1|@>;
13780 if (number_greater(t, fraction_one_t)) {
13781 mp_fin_offset_prep (mp, p, w, x0, x1, x2, y0, y1, y2, 1, turn_amt);
13783 mp_split_cubic (mp, p, t);
13784 r = mp_next_knot (p);
13785 set_number_from_of_the_way(x1a, t, x0, x1);
13786 set_number_from_of_the_way(x1, t, x1, x2);
13787 set_number_from_of_the_way(x2a, t, x1a, x1);
13788 set_number_from_of_the_way(y1a, t, y0, y1);
13789 set_number_from_of_the_way(y1, t, y1, y2);
13790 set_number_from_of_the_way(y2a, t, y1a, y1);
13791 mp_fin_offset_prep (mp, p, w, x0, x1a, x2a, y0, y1a, y2a, 1, 0);
13792 number_clone(x0, x2a);
13793 number_clone(y0, y2a);
13794 mp_knot_info (r) = zero_off - 1;
13795 if (turn_amt >= 0) {
13796 mp_number arg1, arg2, arg3;
13800 set_number_from_of_the_way(t1, t, t1, t2);
13801 if (number_positive(t1))
13802 set_number_to_zero(t1);
13803 number_clone(arg2, t1);
13804 number_negate(arg2);
13805 number_clone(arg3, t2);
13806 number_negate(arg3);
13807 crossing_point (t, arg1, arg2, arg3);
13808 free_number (arg1);
13809 free_number (arg2);
13810 free_number (arg3);
13811 if (number_greater(t, fraction_one_t))
13812 number_clone (t, fraction_one_t);
13813 @<Split off another rising cubic for |fin_offset_prep|@>;
13814 mp_fin_offset_prep (mp, r, ww, x0, x1, x2, y0, y1, y2, -1, 0);
13816 mp_fin_offset_prep (mp, r, ww, x0, x1, x2, y0, y1, y2, -1, (-1 - turn_amt));
13821 @ @<Split off another rising cubic for |fin_offset_prep|@>=
13822 mp_split_cubic (mp, r, t);
13823 mp_knot_info (mp_next_knot (r)) = zero_off + 1;
13824 set_number_from_of_the_way(x1a, t, x1, x2);
13825 set_number_from_of_the_way(x1, t, x0, x1);
13826 set_number_from_of_the_way(x0a, t, x1, x1a);
13827 set_number_from_of_the_way(y1a, t, y1, y2);
13828 set_number_from_of_the_way(y1, t, y0, y1);
13829 set_number_from_of_the_way(y0a, t, y1, y1a);
13830 mp_fin_offset_prep (mp, mp_next_knot (r), w, x0a, x1a, x2, y0a, y1a, y2, 1, turn_amt);
13831 number_clone(x2, x0a);
13832 number_clone(y2, y0a)
13834 @ At this point, the direction of the incoming pen edge is |(-du,-dv)|.
13835 When the component of $d(t)$ perpendicular to |(-du,-dv)| crosses zero, we
13836 need to decide whether the directions are parallel or antiparallel. We
13837 can test this by finding the dot product of $d(t)$ and |(-du,-dv)|, but this
13838 should be avoided when the value of |turn_amt| already determines the
13839 answer. If |t2<0|, there is one crossing and it is antiparallel only if
13840 |turn_amt>=0|. If |turn_amt<0|, there should always be at least one
13841 crossing and the first crossing cannot be antiparallel.
13843 @<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set...@>=
13844 crossing_point (t, t0, t1, t2);
13845 if (turn_amt >= 0) {
13846 if (number_negative(t2)) {
13847 number_clone(t, fraction_one_t);
13848 number_add_scaled (t, 1);
13850 mp_number tmp, arg1, r1;
13854 set_number_from_of_the_way(u0, t, x0, x1);
13855 set_number_from_of_the_way(u1, t, x1, x2);
13856 set_number_from_of_the_way(tmp, t, u0, u1);
13857 number_clone (arg1, du);
13859 take_fraction (ss, arg1, tmp);
13860 set_number_from_of_the_way(v0, t, y0, y1);
13861 set_number_from_of_the_way(v1, t, y1, y2);
13862 set_number_from_of_the_way(tmp, t, v0, v1);
13863 number_clone (arg1, dv);
13865 take_fraction (r1, arg1, tmp);
13866 number_add (ss, r1);
13868 if (number_negative(ss)) {
13869 number_clone(t, fraction_one_t);
13870 number_add_scaled (t, 1);
13875 } else if (number_greater(t, fraction_one_t)) {
13876 number_clone (t, fraction_one_t);
13879 @ @<Other local variables for |offset_prep|@>=
13880 mp_number u0, u1, v0, v1; /* intermediate values for $d(t)$ calculation */
13881 int d_sign; /* sign of overall change in direction for this cubic */
13883 @ If the cubic almost has a cusp, it is a numerically ill-conditioned
13884 problem to decide which way it loops around but that's OK as long we're
13885 consistent. To make \&{doublepath} envelopes work properly, reversing
13886 the path should always change the sign of |turn_amt|.
13888 @<Decide on the net change in pen offsets and set |turn_amt|@>=
13890 mp_number ab_vs_cd;
13891 new_number (ab_vs_cd);
13892 ab_vs_cd (ab_vs_cd, dx, dyin, dxin, dy);
13893 if (number_negative (ab_vs_cd))
13895 else if (number_zero (ab_vs_cd))
13899 free_number (ab_vs_cd);
13902 @<Check rotation direction based on node position@>
13905 if (number_zero(dx)) {
13906 if (number_positive(dy))
13911 if (number_positive(dx))
13917 @<Make |ss| negative if and only if the total change in direction is
13918 more than $180^\circ$@>;
13919 turn_amt = mp_get_turn_amt (mp, w, dxin, dyin, (d_sign > 0));
13920 if (number_negative(ss))
13921 turn_amt = turn_amt - d_sign * n
13923 @ We check rotation direction by looking at the vector connecting the current
13924 node with the next. If its angle with incoming and outgoing tangents has the
13925 same sign, we pick this as |d_sign|, since it means we have a flex, not a cusp.
13926 Otherwise we proceed to the cusp code.
13928 @<Check rotation direction based on node position@>=
13930 mp_number ab_vs_cd1, ab_vs_cd2, t;
13931 new_number (ab_vs_cd1);
13932 new_number (ab_vs_cd2);
13934 set_number_from_substraction(u0, q->x_coord, p->x_coord);
13935 set_number_from_substraction(u1, q->y_coord, p->y_coord);
13936 ab_vs_cd (ab_vs_cd1, dx, u1, u0, dy);
13937 ab_vs_cd (ab_vs_cd2, u0, dyin, dxin, u1);
13938 set_number_from_addition (t, ab_vs_cd1, ab_vs_cd2);
13940 if (number_negative (t))
13942 else if (number_zero (t))
13947 free_number (ab_vs_cd1);
13948 free_number (ab_vs_cd2);
13951 @ In order to be invariant under path reversal, the result of this computation
13952 should not change when |x0|, |y0|, $\ldots$ are all negated and |(x0,y0)| is
13953 then swapped with |(x2,y2)|. We make use of the identities
13954 |take_fraction(-a,-b)=take_fraction(a,b)| and
13955 |t_of_the_way(-a,-b)=-(t_of_the_way(a,b))|.
13957 @<Make |ss| negative if and only if the total change in direction is...@>=
13959 mp_number r1, r2, arg1;
13963 take_fraction (r1, x0, y2);
13964 take_fraction (r2, x2, y0);
13967 set_number_from_substraction(t0, r1, r2);
13968 set_number_from_addition (arg1, y0, y2);
13969 take_fraction (r1, x1, arg1);
13970 set_number_from_addition (arg1, x0, x2);
13971 take_fraction (r1, y1, arg1);
13974 set_number_from_substraction(t1, r1, r2);
13975 free_number (arg1);
13979 if (number_zero(t0))
13980 set_number_from_scaled(t0, d_sign); /* path reversal always negates |d_sign| */
13981 if (number_positive(t0)) {
13984 number_clone(arg3, t0);
13985 number_negate(arg3);
13986 crossing_point (t, t0, t1, arg3);
13987 free_number (arg3);
13988 set_number_from_of_the_way(u0, t, x0, x1);
13989 set_number_from_of_the_way(u1, t, x1, x2);
13990 set_number_from_of_the_way(v0, t, y0, y1);
13991 set_number_from_of_the_way(v1, t, y1, y2);
13995 number_clone(arg1, t0);
13996 number_negate(arg1);
13997 crossing_point (t, arg1, t1, t0);
13998 free_number (arg1);
13999 set_number_from_of_the_way(u0, t, x2, x1);
14000 set_number_from_of_the_way(u1, t, x1, x0);
14001 set_number_from_of_the_way(v0, t, y2, y1);
14002 set_number_from_of_the_way(v1, t, y1, y0);
14005 mp_number tmp1, tmp2, r1, r2, arg1;
14011 set_number_from_of_the_way(tmp1, t, u0, u1);
14012 set_number_from_of_the_way(tmp2, t, v0, v1);
14013 set_number_from_addition(arg1, x0, x2);
14014 take_fraction (r1, arg1, tmp1);
14015 set_number_from_addition(arg1, y0, y2);
14016 take_fraction (r2, arg1, tmp2);
14017 set_number_from_addition (ss, r1, r2);
14018 free_number (arg1);
14021 free_number (tmp1);
14022 free_number (tmp2);
14026 @ Here's a routine that prints an envelope spec in symbolic form. It assumes
14027 that the |cur_pen| has not been walked around to the first offset.
14030 static void mp_print_spec (MP mp, mp_knot cur_spec, mp_knot cur_pen,
14032 mp_knot p, q; /* list traversal */
14033 mp_knot w; /* the current pen offset */
14034 mp_print_diagnostic (mp, "Envelope spec
", s, true);
14036 w = mp_pen_walk (mp, cur_pen, mp->spec_offset);
14038 mp_print_two (mp, cur_spec->x_coord, cur_spec->y_coord);
14039 mp_print (mp, " % beginning with offset
");
14040 mp_print_two (mp, w->x_coord, w->y_coord);
14043 q = mp_next_knot (p);
14044 @<Print the cubic between |p| and |q|@>;
14046 if ((p == cur_spec) || (mp_knot_info (p) != zero_off))
14049 if (mp_knot_info (p) != zero_off) {
14050 @<Update |w| as indicated by |mp_knot_info(p)| and print an explanation@>;
14052 } while (p != cur_spec);
14053 mp_print_nl (mp, " & cycle");
14054 mp_end_diagnostic (mp, true);
14058 @ @<Update |w| as indicated by |mp_knot_info(p)| and print an explanation@>=
14060 w = mp_pen_walk (mp, w, (mp_knot_info (p) - zero_off));
14061 mp_print (mp, " % ");
14062 if (mp_knot_info (p) > zero_off)
14063 mp_print (mp, "counter");
14064 mp_print (mp, "clockwise to offset ");
14065 mp_print_two (mp, w->x_coord, w->y_coord);
14069 @ @<Print the cubic between |p| and |q|@>=
14071 mp_print_nl (mp, " ..controls ");
14072 mp_print_two (mp, p->right_x, p->right_y);
14073 mp_print (mp, " and ");
14074 mp_print_two (mp, q->left_x, q->left_y);
14075 mp_print_nl (mp, " ..");
14076 mp_print_two (mp, q->x_coord, q->y_coord);
14080 @ Once we have an envelope spec, the remaining task to construct the actual
14081 envelope by offsetting each cubic as determined by the |info| fields in
14082 the knots. First we use |offset_prep| to convert the |c| into an envelope
14083 spec. Then we add the offsets so that |c| becomes a cyclic path that represents
14086 The |ljoin| and |miterlim| parameters control the treatment of points where the
14087 pen offset changes, and |lcap| controls the endpoints of a \&{doublepath}.
14088 The endpoints are easily located because |c| is given in undoubled form
14089 and then doubled in this procedure. We use |spec_p1| and |spec_p2| to keep
14090 track of the endpoints and treat them like very sharp corners.
14091 Butt end caps are treated like beveled joins; round end caps are treated like
14092 round joins; and square end caps are achieved by setting |join_type:=3|.
14094 None of these parameters apply to inside joins where the convolution tracing
14095 has retrograde lines. In such cases we use a simple connect-the-endpoints
14096 approach that is achieved by setting |join_type:=2|.
14099 static mp_knot mp_make_envelope (MP mp, mp_knot c, mp_knot h, quarterword ljoin,
14100 quarterword lcap, mp_number miterlim) {
14101 mp_knot p, q, r, q0; /* for manipulating the path */
14102 mp_knot w, w0; /* the pen knot for the current offset */
14103 halfword k, k0; /* controls pen edge insertion */
14104 mp_number qx, qy; /* unshifted coordinates of |q| */
14105 mp_fraction dxin, dyin, dxout, dyout; /* directions at |q| when square or mitered */
14106 int join_type = 0; /* codes |0..3| for mitered, round, beveled, or square */
14107 @<Other local variables for |make_envelope|@>;
14108 new_number (max_ht);
14110 new_fraction(dxin);
14111 new_fraction(dyin);
14112 new_fraction(dxout);
14113 new_fraction(dyout);
14114 mp->spec_p1 = NULL;
14115 mp->spec_p2 = NULL;
14118 @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>;
14119 @<Use |offset_prep| to compute the envelope spec then walk |h| around to
14120 the initial offset@>;
14124 q = mp_next_knot (p);
14126 number_clone (qx, q->x_coord);
14127 number_clone (qy, q->y_coord);
14128 k = mp_knot_info (q);
14131 if (k != zero_off) {
14132 @<Set |join_type| to indicate how to handle offset changes at~|q|@>;
14134 @<Add offset |w| to the cubic from |p| to |q|@>;
14135 while (k != zero_off) {
14136 @<Step |w| and move |k| one step closer to |zero_off|@>;
14137 if ((join_type == 1) || (k == zero_off)) {
14138 mp_number xtot, ytot;
14141 set_number_from_addition (xtot, qx, w->x_coord);
14142 set_number_from_addition (ytot, qy, w->y_coord);
14143 q = mp_insert_knot (mp, q, xtot, ytot);
14146 if (q != mp_next_knot (p)) {
14147 @<Set |p=mp_link(p)| and add knots between |p| and |q| as
14148 required by |join_type|@>;
14152 free_number (max_ht);
14156 free_number (dxin);
14157 free_number (dyin);
14158 free_number (dxout);
14159 free_number (dyout);
14164 @ @<Use |offset_prep| to compute the envelope spec then walk |h| around to...@>=
14165 c = mp_offset_prep (mp, c, h);
14166 if (number_positive(internal_value (mp_tracing_specs)))
14167 mp_print_spec (mp, c, h, "");
14168 h = mp_pen_walk (mp, h, mp->spec_offset)
14171 @ Mitered and squared-off joins depend on path directions that are difficult to
14172 compute for degenerate cubics. The envelope spec computed by |offset_prep| can
14173 have degenerate cubics only if the entire cycle collapses to a single
14174 degenerate cubic. Setting |join_type:=2| in this case makes the computed
14175 envelope degenerate as well.
14177 @<Set |join_type| to indicate how to handle offset changes at~|q|@>=
14178 if (k < zero_off) {
14181 if ((q != mp->spec_p1) && (q != mp->spec_p2))
14183 else if (lcap == 2)
14186 join_type = 2 - lcap;
14187 if ((join_type == 0) || (join_type == 3)) {
14188 @<Set the incoming and outgoing directions at |q|; in case of
14189 degeneracy set |join_type:=2|@>;
14190 if (join_type == 0) {
14191 @<If |miterlim| is less than the secant of half the angle at |q|
14192 then set |join_type:=2|@>;
14198 @ @<If |miterlim| is less than the secant of half the angle at |q|...@>=
14203 take_fraction (r1, dxin, dxout);
14204 take_fraction (r2, dyin, dyout);
14205 number_add (r1, r2);
14207 number_add (r1, fraction_half_t);
14208 take_fraction (tmp, miterlim, r1);
14209 if (number_less(tmp, unity_t)) {
14212 take_scaled (ret, miterlim, tmp);
14213 if (number_less(ret, unity_t))
14222 @ @<Other local variables for |make_envelope|@>=
14223 mp_number tmp; /* a temporary value */
14225 @ The coordinates of |p| have already been shifted unless |p| is the first
14226 knot in which case they get shifted at the very end.
14228 @<Add offset |w| to the cubic from |p| to |q|@>=
14229 number_add (p->right_x, w->x_coord);
14230 number_add (p->right_y, w->y_coord);
14231 number_add (q->left_x, w->x_coord);
14232 number_add (q->left_y, w->y_coord);
14233 number_add (q->x_coord, w->x_coord);
14234 number_add (q->y_coord, w->y_coord);
14235 mp_left_type (q) = mp_explicit;
14236 mp_right_type (q) = mp_explicit
14238 @ @<Step |w| and move |k| one step closer to |zero_off|@>=
14239 if (k > zero_off) {
14240 w = mp_next_knot (w);
14243 w = mp_prev_knot (w);
14248 @ The cubic from |q| to the new knot at |(x,y)| becomes a line segment and
14249 the |mp_right_x| and |mp_right_y| fields of |r| are set from |q|. This is done in
14250 case the cubic containing these control points is ``yet to be examined.''
14253 static mp_knot mp_insert_knot (MP mp, mp_knot q, mp_number x, mp_number y);
14256 mp_knot mp_insert_knot (MP mp, mp_knot q, mp_number x, mp_number y) {
14257 /* returns the inserted knot */
14258 mp_knot r; /* the new knot */
14259 r = mp_new_knot (mp);
14260 mp_next_knot (r) = mp_next_knot (q);
14261 mp_next_knot (q) = r;
14262 number_clone (r->right_x, q->right_x);
14263 number_clone (r->right_y, q->right_y);
14264 number_clone (r->x_coord, x);
14265 number_clone (r->y_coord, y);
14266 number_clone (q->right_x, q->x_coord);
14267 number_clone (q->right_y, q->y_coord);
14268 number_clone (r->left_x, r->x_coord);
14269 number_clone (r->left_y, r->y_coord);
14270 mp_left_type (r) = mp_explicit;
14271 mp_right_type (r) = mp_explicit;
14272 mp_originator (r) = mp_program_code;
14277 @ After setting |p:=mp_link(p)|, either |join_type=1| or |q=mp_link(p)|.
14279 @<Set |p=mp_link(p)| and add knots between |p| and |q| as...@>=
14281 p = mp_next_knot (p);
14282 if ((join_type == 0) || (join_type == 3)) {
14283 if (join_type == 0) {
14284 @<Insert a new knot |r| between |p| and |q| as required for a mitered join@>
14286 @<Make |r| the last of two knots inserted between |p| and |q| to form a
14290 number_clone (r->right_x, r->x_coord);
14291 number_clone (r->right_y, r->y_coord);
14297 @ For very small angles, adding a knot is unnecessary and would cause numerical
14298 problems, so we just set |r:=NULL| in that case.
14300 @d near_zero_angle_k ((math_data *)mp->math)->near_zero_angle_t
14302 @<Insert a new knot |r| between |p| and |q| as required for a mitered join@>=
14304 mp_number det; /* a determinant used for mitered join calculations */
14309 new_fraction (det);
14310 new_fraction (absdet);
14311 take_fraction (r1, dyout, dxin);
14312 take_fraction (r2, dxout, dyin);
14313 set_number_from_substraction(det, r1, r2);
14314 number_clone (absdet, det);
14315 number_abs (absdet);
14316 if (number_less (absdet, near_zero_angle_k)) {
14317 r = NULL; /* sine $<10^{-4}$ */
14319 mp_number xtot, ytot, xsub, ysub;
14320 new_fraction(xsub);
14321 new_fraction(ysub);
14324 set_number_from_substraction (tmp, q->x_coord, p->x_coord);
14325 take_fraction (r1, tmp, dyout);
14326 set_number_from_substraction (tmp, q->y_coord, p->y_coord);
14327 take_fraction (r2, tmp, dxout);
14328 set_number_from_substraction (tmp, r1, r2);
14329 make_fraction (r1, tmp, det);
14330 number_clone (tmp, r1);
14331 take_fraction (xsub, tmp, dxin);
14332 take_fraction (ysub, tmp, dyin);
14333 set_number_from_addition(xtot, p->x_coord, xsub);
14334 set_number_from_addition(ytot, p->y_coord, ysub);
14335 r = mp_insert_knot (mp, p, xtot, ytot);
14336 free_number (xtot);
14337 free_number (ytot);
14338 free_number (xsub);
14339 free_number (ysub);
14344 free_number (absdet);
14348 @ @<Make |r| the last of two knots inserted between |p| and |q| to form a...@>=
14350 mp_number ht_x, ht_y; /* perpendicular to the segment from |p| to |q| */
14351 mp_number ht_x_abs, ht_y_abs; /* absolutes */
14352 mp_number xtot, ytot, xsub, ysub;
14353 new_fraction(xsub);
14354 new_fraction(ysub);
14357 new_fraction (ht_x);
14358 new_fraction (ht_y);
14359 new_fraction (ht_x_abs);
14360 new_fraction (ht_y_abs);
14361 set_number_from_substraction(ht_x, w->y_coord, w0->y_coord);
14362 set_number_from_substraction(ht_y, w0->x_coord, w->x_coord);
14363 number_clone (ht_x_abs, ht_x);
14364 number_clone (ht_y_abs, ht_y);
14365 number_abs (ht_x_abs);
14366 number_abs (ht_y_abs);
14367 while (number_less(ht_x_abs, fraction_half_t) && number_less(ht_y_abs, fraction_half_t)) {
14368 number_double(ht_x);
14369 number_double(ht_y);
14370 number_clone (ht_x_abs, ht_x);
14371 number_clone (ht_y_abs, ht_y);
14372 number_abs (ht_x_abs);
14373 number_abs (ht_y_abs);
14375 @<Scan the pen polygon between |w0| and |w| and make |max_ht| the range dot
14376 product with |(ht_x,ht_y)|@>;
14381 take_fraction (r1, dxin, ht_x);
14382 take_fraction (r2, dyin, ht_y);
14383 number_add (r1, r2);
14384 make_fraction (tmp, max_ht, r1);
14388 take_fraction (xsub, tmp, dxin);
14389 take_fraction (ysub, tmp, dyin);
14390 set_number_from_addition(xtot, p->x_coord, xsub);
14391 set_number_from_addition(ytot, p->y_coord, ysub);
14392 r = mp_insert_knot (mp, p, xtot, ytot);
14393 /* clang: value never read */ assert(r);
14398 take_fraction (r1, dxout, ht_x);
14399 take_fraction (r2, dyout, ht_y);
14400 number_add (r1, r2);
14401 make_fraction (tmp, max_ht, r1);
14405 take_fraction (xsub, tmp, dxout);
14406 take_fraction (ysub, tmp, dyout);
14407 set_number_from_addition(xtot, q->x_coord, xsub);
14408 set_number_from_addition(ytot, q->y_coord, ysub);
14409 r = mp_insert_knot (mp, p, xtot, ytot);
14410 free_number (xsub);
14411 free_number (ysub);
14412 free_number (xtot);
14413 free_number (ytot);
14414 free_number (ht_x);
14415 free_number (ht_y);
14416 free_number (ht_x_abs);
14417 free_number (ht_y_abs);
14421 @ @<Other local variables for |make_envelope|@>=
14422 mp_number max_ht; /* maximum height of the pen polygon above the |w0|-|w| line */
14423 halfword kk; /* keeps track of the pen vertices being scanned */
14424 mp_knot ww; /* the pen vertex being tested */
14426 @ The dot product of the vector from |w0| to |ww| with |(ht_x,ht_y)| ranges
14427 from zero to |max_ht|.
14429 @<Scan the pen polygon between |w0| and |w| and make |max_ht| the range...@>=
14430 set_number_to_zero (max_ht);
14434 @<Step |ww| and move |kk| one step closer to |k0|@>;
14441 set_number_from_substraction (tmp, ww->x_coord, w0->x_coord);
14442 take_fraction (r1, tmp, ht_x);
14443 set_number_from_substraction (tmp, ww->y_coord, w0->y_coord);
14444 take_fraction (r2, tmp, ht_y);
14445 set_number_from_addition (tmp, r1, r2);
14449 if (number_greater(tmp, max_ht))
14450 number_clone(max_ht, tmp);
14454 @ @<Step |ww| and move |kk| one step closer to |k0|@>=
14456 ww = mp_next_knot (ww);
14459 ww = mp_prev_knot (ww);
14464 @ @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>=
14465 if (mp_left_type (c) == mp_endpoint) {
14466 mp->spec_p1 = mp_htap_ypoc (mp, c);
14467 mp->spec_p2 = mp->path_tail;
14468 mp_originator (mp->spec_p1) = mp_program_code;
14469 mp_next_knot (mp->spec_p2) = mp_next_knot (mp->spec_p1);
14470 mp_next_knot (mp->spec_p1) = c;
14471 mp_remove_cubic (mp, mp->spec_p1);
14473 if (c != mp_next_knot (c)) {
14474 mp_originator (mp->spec_p2) = mp_program_code;
14475 mp_remove_cubic (mp, mp->spec_p2);
14477 @<Make |c| look like a cycle of length one@>;
14481 @ @<Make |c| look like a cycle of length one@>=
14483 mp_left_type (c) = mp_explicit;
14484 mp_right_type (c) = mp_explicit;
14485 number_clone(c->left_x, c->x_coord);
14486 number_clone(c->left_y, c->y_coord);
14487 number_clone(c->right_x, c->x_coord);
14488 number_clone(c->right_y, c->y_coord);
14492 @ In degenerate situations we might have to look at the knot preceding~|q|.
14493 That knot is |p| but if |p<>c|, its coordinates have already been offset by |w|.
14495 @<Set the incoming and outgoing directions at |q|; in case of...@>=
14497 set_number_from_substraction(dxin, q->x_coord, q->left_x);
14498 set_number_from_substraction(dyin, q->y_coord, q->left_y);
14499 if (number_zero(dxin) && number_zero(dyin)) {
14500 set_number_from_substraction(dxin, q->x_coord, p->right_x);
14501 set_number_from_substraction(dyin, q->y_coord, p->right_y);
14502 if (number_zero(dxin) && number_zero(dyin)) {
14503 set_number_from_substraction(dxin, q->x_coord, p->x_coord);
14504 set_number_from_substraction(dyin, q->y_coord, p->y_coord);
14505 if (p != c) { /* the coordinates of |p| have been offset by |w| */
14506 number_add(dxin, w->x_coord);
14507 number_add(dyin, w->y_coord);
14511 pyth_add (tmp, dxin, dyin);
14512 if (number_zero(tmp)) {
14517 make_fraction (r1, dxin, tmp);
14518 number_clone(dxin, r1);
14519 make_fraction (r1, dyin, tmp);
14520 number_clone(dyin, r1);
14522 @<Set the outgoing direction at |q|@>;
14527 @ If |q=c| then the coordinates of |r| and the control points between |q|
14528 and~|r| have already been offset by |h|.
14530 @<Set the outgoing direction at |q|@>=
14532 set_number_from_substraction(dxout, q->right_x, q->x_coord);
14533 set_number_from_substraction(dyout, q->right_y, q->y_coord);
14534 if (number_zero(dxout) && number_zero(dyout)) {
14535 r = mp_next_knot (q);
14536 set_number_from_substraction(dxout, r->left_x, q->x_coord);
14537 set_number_from_substraction(dyout, r->left_y, q->y_coord);
14538 if (number_zero(dxout) && number_zero(dyout)) {
14539 set_number_from_substraction(dxout, r->x_coord, q->x_coord);
14540 set_number_from_substraction(dyout, r->y_coord, q->y_coord);
14544 number_substract(dxout, h->x_coord);
14545 number_substract(dyout, h->y_coord);
14547 pyth_add (tmp, dxout, dyout);
14548 if (number_zero(tmp)) {
14549 /* |mp_confusion (mp, "degenerate spec");| */
14550 @:this can't happen degerate spec}{\quad degenerate spec@>;
14551 /* But apparently, it actually can happen. The test case is this:
14554 linejoin := mitered;
14555 p:= (10,0)..(0,10)..(-10,0)..(0,-10)..cycle;
14556 addto currentpicture contour p withpen pensquare;
14558 The reason for failure here is the addition of |r != q| in revision 1757
14559 in ``Advance |p| to node |q|, removing any ``dead'' cubics'', which itself
14560 was needed to fix a bug with disappearing knots in a path that was rotated
14561 exactly 45 degrees (luatex.org bug 530).
14566 make_fraction (r1, dxout, tmp);
14567 number_clone(dxout, r1);
14568 make_fraction (r1, dyout, tmp);
14569 number_clone(dyout, r1);
14575 @* Direction and intersection times.
14576 A path of length $n$ is defined parametrically by functions $x(t)$ and
14577 $y(t)$, for |0<=t<=n|; we can regard $t$ as the ``time'' at which the path
14578 reaches the point $\bigl(x(t),y(t)\bigr)$. In this section of the program
14579 we shall consider operations that determine special times associated with
14580 given paths: the first time that a path travels in a given direction, and
14581 a pair of times at which two paths cross each other.
14583 @ Let's start with the easier task. The function |find_direction_time| is
14584 given a direction |(x,y)| and a path starting at~|h|. If the path never
14585 travels in direction |(x,y)|, the direction time will be~|-1|; otherwise
14586 it will be nonnegative.
14588 Certain anomalous cases can arise: If |(x,y)=(0,0)|, so that the given
14589 direction is undefined, the direction time will be~0. If $\bigl(x'(t),
14590 y'(t)\bigr)=(0,0)$, so that the path direction is undefined, it will be
14591 assumed to match any given direction at time~|t|.
14593 The routine solves this problem in nondegenerate cases by rotating the path
14594 and the given direction so that |(x,y)=(1,0)|; i.e., the main task will be
14595 to find when a given path first travels ``due east.''
14598 static void mp_find_direction_time (MP mp, mp_number *ret, mp_number x_orig, mp_number y_orig, mp_knot h) {
14599 mp_number max; /* $\max\bigl(\vert x\vert,\vert y\vert\bigr)$ */
14600 mp_knot p, q; /* for list traversal */
14601 mp_number n; /* the direction time at knot |p| */
14602 mp_number tt; /* the direction time within a cubic */
14604 mp_number abs_x, abs_y;
14605 /* Other local variables for |find_direction_time| */
14606 mp_number x1, x2, x3, y1, y2, y3; /* multiples of rotated derivatives */
14607 mp_number phi; /* angles of exit and entry at a knot */
14608 mp_number t; /* temp storage */
14609 mp_number ab_vs_cd;
14619 new_number (ab_vs_cd);
14620 set_number_to_zero (*ret); /* just in case */
14623 new_number (abs_x);
14624 new_number (abs_y);
14627 number_clone (x, x_orig);
14628 number_clone (y, y_orig);
14629 number_clone (abs_x, x_orig);
14630 number_clone (abs_y, y_orig);
14631 number_abs (abs_x);
14632 number_abs (abs_y);
14633 /* Normalize the given direction for better accuracy;
14634 but |return| with zero result if it's zero */
14635 if (number_less(abs_x, abs_y)) {
14638 make_fraction (r1, x, abs_y);
14639 number_clone(x, r1);
14641 if (number_positive(y)) {
14642 number_clone(y, fraction_one_t);
14644 number_clone(y, fraction_one_t);
14647 } else if (number_zero(x)) {
14652 make_fraction (r1, y, abs_x);
14653 number_clone(y, r1);
14655 if (number_positive(x)) {
14656 number_clone(x, fraction_one_t);
14658 number_clone(x, fraction_one_t);
14665 if (mp_right_type (p) == mp_endpoint)
14667 q = mp_next_knot (p);
14668 @<Rotate the cubic between |p| and |q|; then
14669 |goto found| if the rotated cubic travels due east at some time |tt|;
14670 but |break| if an entire cyclic path has been traversed@>;
14672 number_add(n, unity_t);
14674 set_number_to_unity (*ret);
14675 number_negate(*ret);
14678 set_number_from_addition (*ret, n, tt);
14683 free_number (abs_x);
14684 free_number (abs_y);
14685 /* Free local variables for |find_direction_time| */
14694 free_number (ab_vs_cd);
14703 @ Since we're interested in the tangent directions, we work with the
14704 derivative $${1\over3}B'(x_0,x_1,x_2,x_3;t)=
14705 B(x_1-x_0,x_2-x_1,x_3-x_2;t)$$ instead of
14706 $B(x_0,x_1,x_2,x_3;t)$ itself. The derived coefficients are also scale-d up
14707 in order to achieve better accuracy.
14709 The given path may turn abruptly at a knot, and it might pass the critical
14710 tangent direction at such a time. Therefore we remember the direction |phi|
14711 in which the previous rotated cubic was traveling. (The value of |phi| will be
14712 undefined on the first cubic, i.e., when |n=0|.)
14715 number_clone (tt, t);
14716 fraction_to_round_scaled (tt);
14720 @<Rotate the cubic between |p| and |q|; then...@>=
14721 set_number_to_zero(tt);
14722 /* Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples of the control
14723 points of the rotated derivatives */
14726 new_number (absval);
14727 set_number_from_substraction(x1, p->right_x, p->x_coord);
14728 set_number_from_substraction(x2, q->left_x, p->right_x);
14729 set_number_from_substraction(x3, q->x_coord, q->left_x);
14730 set_number_from_substraction(y1, p->right_y, p->y_coord);
14731 set_number_from_substraction(y2, q->left_y, p->right_y);
14732 set_number_from_substraction(y3, q->y_coord, q->left_y);
14733 number_clone(absval, x2);
14734 number_abs(absval);
14735 number_clone(max, x1);
14737 if (number_greater(absval, max)) {
14738 number_clone(max, absval);
14740 number_clone(absval, x3);
14741 number_abs(absval);
14742 if (number_greater(absval, max)) {
14743 number_clone(max, absval);
14745 number_clone(absval, y1);
14746 number_abs(absval);
14747 if (number_greater(absval, max)) {
14748 number_clone(max, absval);
14750 number_clone(absval, y2);
14751 number_abs(absval);
14752 if (number_greater(absval, max)) {
14753 number_clone(max, absval);
14755 number_clone(absval, y3);
14756 number_abs(absval);
14757 if (number_greater(absval, max)) {
14758 number_clone(max, absval);
14760 free_number (absval);
14761 if (number_zero(max))
14763 while (number_less (max, fraction_half_t)) {
14764 number_double(max);
14772 number_clone(t, x1);
14777 take_fraction (r1, x1, x);
14778 take_fraction (r2, y1, y);
14779 set_number_from_addition(x1, r1, r2);
14780 take_fraction (r1, y1, x);
14781 take_fraction (r2, t, y);
14782 set_number_from_substraction(y1, r1, r2);
14783 number_clone(t, x2);
14784 take_fraction (r1, x2, x);
14785 take_fraction (r2, y2, y);
14786 set_number_from_addition(x2, r1, r2);
14787 take_fraction (r1, y2, x);
14788 take_fraction (r2, t, y);
14789 set_number_from_substraction(y2, r1, r2);
14790 number_clone(t, x3);
14791 take_fraction (r1, x3 ,x);
14792 take_fraction (r2, y3, y);
14793 set_number_from_addition(x3, r1, r2);
14794 take_fraction (r1, y3, x);
14795 take_fraction (r2, t, y);
14796 set_number_from_substraction(y3, r1, r2);
14801 if (number_zero(y1))
14802 if (number_zero(x1) || number_positive(x1))
14804 if (number_positive(n)) {
14805 /* Exit to |found| if an eastward direction occurs at knot |p| */
14809 n_arg (theta, x1, y1);
14811 set_number_from_substraction (tmp, theta, one_eighty_deg_t);
14813 if (number_nonnegative(theta) && number_nonpositive(phi) && number_greaterequal(phi, tmp)) {
14815 free_number (theta);
14818 set_number_from_addition (tmp, theta, one_eighty_deg_t);
14819 if (number_nonpositive(theta) && number_nonnegative(phi) && number_lessequal(phi, tmp)) {
14821 free_number (theta);
14825 free_number (theta);
14830 if (number_nonzero(x3) || number_nonzero(y3)) {
14831 n_arg (phi, x3, y3);
14833 /* Exit to |found| if the curve whose derivatives are specified by
14834 |x1,x2,x3,y1,y2,y3| travels eastward at some time~|tt| */
14835 /* In this step we want to use the |crossing_point| routine to find the
14836 roots of the quadratic equation $B(y_1,y_2,y_3;t)=0$.
14837 Several complications arise: If the quadratic equation has a double root,
14838 the curve never crosses zero, and |crossing_point| will find nothing;
14839 this case occurs iff $y_1y_3=y_2^2$ and $y_1y_2<0$. If the quadratic
14840 equation has simple roots, or only one root, we may have to negate it
14841 so that $B(y_1,y_2,y_3;t)$ crosses from positive to negative at its first root.
14842 And finally, we need to do special things if $B(y_1,y_2,y_3;t)$ is
14843 identically zero. */
14844 if (number_negative(x1))
14845 if (number_negative(x2))
14846 if (number_negative(x3))
14849 ab_vs_cd (ab_vs_cd, y1, y3, y2, y2);
14850 if (number_zero(ab_vs_cd)) {
14851 /* Handle the test for eastward directions when $y_1y_3=y_2^2$;
14852 either |goto found| or |goto done| */
14854 ab_vs_cd (ab_vs_cd, y1, y2, zero_t, zero_t);
14855 if (number_negative(ab_vs_cd)) {
14856 mp_number tmp, arg2;
14859 set_number_from_substraction (arg2, y1, y2);
14860 make_fraction (t, y1, arg2);
14861 free_number (arg2);
14862 set_number_from_of_the_way(x1, t, x1, x2);
14863 set_number_from_of_the_way(x2, t, x2, x3);
14864 set_number_from_of_the_way(tmp, t, x1, x2);
14865 if (number_zero(tmp) || number_positive(tmp)) {
14870 } else if (number_zero(y3)) {
14871 if (number_zero(y1)) {
14872 /* Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0| */
14873 /* At this point we know that the derivative of |y(t)| is identically zero,
14874 and that |x1<0|; but either |x2>=0| or |x3>=0|, so there's some hope of
14877 mp_number arg1, arg2, arg3;
14881 number_clone(arg1, x1);
14882 number_negate(arg1);
14883 number_clone(arg2, x2);
14884 number_negate(arg2);
14885 number_clone(arg3, x3);
14886 number_negate(arg3);
14887 crossing_point (t, arg1, arg2, arg3);
14888 free_number (arg1);
14889 free_number (arg2);
14890 free_number (arg3);
14891 if (number_lessequal (t, fraction_one_t))
14893 ab_vs_cd (ab_vs_cd, x1, x3, x2, x2);
14894 if (number_nonpositive(ab_vs_cd)) {
14897 set_number_from_substraction (arg2, x1, x2);
14898 make_fraction (t, x1, arg2);
14899 free_number (arg2);
14906 } else if (number_zero(x3) || number_positive(x3)) {
14907 set_number_to_unity(tt);
14917 if (number_zero(y1) || number_negative(y1)) {
14918 if (number_negative(y1)) {
14922 } else if (number_positive(y2)) {
14927 /* Check the places where $B(y_1,y_2,y_3;t)=0$ to see if
14928 $B(x_1,x_2,x_3;t)\ge0$ */
14929 /* The quadratic polynomial $B(y_1,y_2,y_3;t)$ begins |>=0| and has at most
14930 two roots, because we know that it isn't identically zero.
14932 It must be admitted that the |crossing_point| routine is not perfectly accurate;
14933 rounding errors might cause it to find a root when $y_1y_3>y_2^2$, or to
14934 miss the roots when $y_1y_3<y_2^2$. The rotation process is itself
14935 subject to rounding errors. Yet this code optimistically tries to
14936 do the right thing.
14939 crossing_point (t, y1, y2, y3);
14940 if (number_greater (t, fraction_one_t))
14942 set_number_from_of_the_way(y2, t, y2, y3);
14943 set_number_from_of_the_way(x1, t, x1, x2);
14944 set_number_from_of_the_way(x2, t, x2, x3);
14945 set_number_from_of_the_way(x1, t, x1, x2);
14946 if (number_zero(x1) || number_positive(x1))
14948 if (number_positive(y2))
14949 set_number_to_zero(y2);
14950 number_clone(tt, t);
14952 mp_number arg1, arg2, arg3;
14956 number_clone(arg2, y2);
14957 number_negate(arg2);
14958 number_clone(arg3, y3);
14959 number_negate(arg3);
14960 crossing_point (t, arg1, arg2, arg3);
14961 free_number (arg1);
14962 free_number (arg2);
14963 free_number (arg3);
14965 if (number_greater (t, fraction_one_t))
14970 set_number_from_of_the_way(x1, t, x1, x2);
14971 set_number_from_of_the_way(x2, t, x2, x3);
14972 set_number_from_of_the_way(tmp, t, x1, x2);
14973 if (number_nonnegative(tmp)) {
14975 set_number_from_of_the_way (t, t, tt, fraction_one_t);
14983 @ The intersection of two cubics can be found by an interesting variant
14984 of the general bisection scheme described in the introduction to
14986 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)$,
14987 we wish to find a pair of times $(t_1,t_2)$ such that $w(t_1)=z(t_2)$,
14988 if an intersection exists. First we find the smallest rectangle that
14989 encloses the points $\{w_0,w_1,w_2,w_3\}$ and check that it overlaps
14990 the smallest rectangle that encloses
14991 $\{z_0,z_1,z_2,z_3\}$; if not, the cubics certainly don't intersect.
14992 But if the rectangles do overlap, we bisect the intervals, getting
14993 new cubics $w'$ and~$w''$, $z'$~and~$z''$; the intersection routine first
14994 tries for an intersection between $w'$ and~$z'$, then (if unsuccessful)
14995 between $w'$ and~$z''$, then (if still unsuccessful) between $w''$ and~$z'$,
14996 finally (if thrice unsuccessful) between $w''$ and~$z''$. After $l$~successful
14997 levels of bisection we will have determined the intersection times $t_1$
14998 and~$t_2$ to $l$~bits of accuracy.
15000 \def\submin{_{\rm min}} \def\submax{_{\rm max}}
15001 As before, it is better to work with the numbers $W_k=2^l(w_k-w_{k-1})$
15002 and $Z_k=2^l(z_k-z_{k-1})$ rather than the coefficients $w_k$ and $z_k$
15003 themselves. We also need one other quantity, $\Delta=2^l(w_0-z_0)$,
15004 to determine when the enclosing rectangles overlap. Here's why:
15005 The $x$~coordinates of~$w(t)$ are between $u\submin$ and $u\submax$,
15006 and the $x$~coordinates of~$z(t)$ are between $x\submin$ and $x\submax$,
15007 if we write $w_k=(u_k,v_k)$ and $z_k=(x_k,y_k)$ and $u\submin=
15008 \min(u_0,u_1,u_2,u_3)$, etc. These intervals of $x$~coordinates
15009 overlap if and only if $u\submin\L x\submax$ and
15010 $x\submin\L u\submax$. Letting
15011 $$U\submin=\min(0,U_1,U_1+U_2,U_1+U_2+U_3),\;
15012 U\submax=\max(0,U_1,U_1+U_2,U_1+U_2+U_3),$$
15013 we have $2^lu\submin=2^lu_0+U\submin$, etc.; the condition for overlap
15015 $$X\submin-U\submax\L 2^l(u_0-x_0)\L X\submax-U\submin.$$
15016 Thus we want to maintain the quantity $2^l(u_0-x_0)$; similarly,
15017 the quantity $2^l(v_0-y_0)$ accounts for the $y$~coordinates. The
15018 coordinates of $\Delta=2^l(w_0-z_0)$ must stay bounded as $l$ increases,
15019 because of the overlap condition; i.e., we know that $X\submin$,
15020 $X\submax$, and their relatives are bounded, hence $X\submax-
15021 U\submin$ and $X\submin-U\submax$ are bounded.
15023 @ Incidentally, if the given cubics intersect more than once, the process
15024 just sketched will not necessarily find the lexicographically smallest pair
15025 $(t_1,t_2)$. The solution actually obtained will be smallest in ``shuffled
15026 order''; i.e., if $t_1=(.a_1a_2\ldots a_{16})_2$ and
15027 $t_2=(.b_1b_2\ldots b_{16})_2$, then we will minimize
15028 $a_1b_1a_2b_2\ldots a_{16}b_{16}$, not
15029 $a_1a_2\ldots a_{16}b_1b_2\ldots b_{16}$.
15030 Shuffled order agrees with lexicographic order if all pairs of solutions
15031 $(t_1,t_2)$ and $(t_1',t_2')$ have the property that $t_1<t_1'$ iff
15032 $t_2<t_2'$; but in general, lexicographic order can be quite different,
15033 and the bisection algorithm would be substantially less efficient if it were
15034 constrained by lexicographic order.
15036 For example, suppose that an overlap has been found for $l=3$ and
15037 $(t_1,t_2)= (.101,.011)$ in binary, but that no overlap is produced by
15038 either of the alternatives $(.1010,.0110)$, $(.1010,.0111)$ at level~4.
15039 Then there is probably an intersection in one of the subintervals
15040 $(.1011,.011x)$; but lexicographic order would require us to explore
15041 $(.1010,.1xxx)$ and $(.1011,.00xx)$ and $(.1011,.010x)$ first. We wouldn't
15042 want to store all of the subdivision data for the second path, so the
15043 subdivisions would have to be regenerated many times. Such inefficiencies
15044 would be associated with every `1' in the binary representation of~$t_1$.
15046 @ The subdivision process introduces rounding errors, hence we need to
15047 make a more liberal test for overlap. It is not hard to show that the
15048 computed values of $U_i$ differ from the truth by at most~$l$, on
15049 level~$l$, hence $U\submin$ and $U\submax$ will be at most $3l$ in error.
15050 If $\beta$ is an upper bound on the absolute error in the computed
15051 components of $\Delta=(|delx|,|dely|)$ on level~$l$, we will replace
15052 the test `$X\submin-U\submax\L|delx|$' by the more liberal test
15053 `$X\submin-U\submax\L|delx|+|tol|$', where $|tol|=6l+\beta$.
15055 More accuracy is obtained if we try the algorithm first with |tol=0|;
15056 the more liberal tolerance is used only if an exact approach fails.
15057 It is convenient to do this double-take by letting `3' in the preceding
15058 paragraph be a parameter, which is first 0, then 3.
15061 unsigned int tol_step; /* either 0 or 3, usually */
15063 @ We shall use an explicit stack to implement the recursive bisection
15064 method described above. The |bisect_stack| array will contain numerous 5-word
15065 packets like $(U_1,U_2,U_3,U\submin,U\submax)$, as well as 20-word packets
15066 comprising the 5-word packets for $U$, $V$, $X$, and~$Y$.
15068 The following macros define the allocation of stack positions to
15069 the quantities needed for bisection-intersection.
15071 @d stack_1(A) mp->bisect_stack[(A)] /* $U_1$, $V_1$, $X_1$, or $Y_1$ */
15072 @d stack_2(A) mp->bisect_stack[(A)+1] /* $U_2$, $V_2$, $X_2$, or $Y_2$ */
15073 @d stack_3(A) mp->bisect_stack[(A)+2] /* $U_3$, $V_3$, $X_3$, or $Y_3$ */
15074 @d stack_min(A) mp->bisect_stack[(A)+3]
15075 /* $U\submin$, $V\submin$, $X\submin$, or $Y\submin$ */
15076 @d stack_max(A) mp->bisect_stack[(A)+4]
15077 /* $U\submax$, $V\submax$, $X\submax$, or $Y\submax$ */
15078 @d int_packets 20 /* number of words to represent $U_k$, $V_k$, $X_k$, and $Y_k$ */
15080 @d u_packet(A) ((A)-5)
15081 @d v_packet(A) ((A)-10)
15082 @d x_packet(A) ((A)-15)
15083 @d y_packet(A) ((A)-20)
15084 @d l_packets (mp->bisect_ptr-int_packets)
15085 @d r_packets mp->bisect_ptr
15086 @d ul_packet u_packet(l_packets) /* base of $U'_k$ variables */
15087 @d vl_packet v_packet(l_packets) /* base of $V'_k$ variables */
15088 @d xl_packet x_packet(l_packets) /* base of $X'_k$ variables */
15089 @d yl_packet y_packet(l_packets) /* base of $Y'_k$ variables */
15090 @d ur_packet u_packet(r_packets) /* base of $U''_k$ variables */
15091 @d vr_packet v_packet(r_packets) /* base of $V''_k$ variables */
15092 @d xr_packet x_packet(r_packets) /* base of $X''_k$ variables */
15093 @d yr_packet y_packet(r_packets) /* base of $Y''_k$ variables */
15095 @d u1l stack_1(ul_packet) /* $U'_1$ */
15096 @d u2l stack_2(ul_packet) /* $U'_2$ */
15097 @d u3l stack_3(ul_packet) /* $U'_3$ */
15098 @d v1l stack_1(vl_packet) /* $V'_1$ */
15099 @d v2l stack_2(vl_packet) /* $V'_2$ */
15100 @d v3l stack_3(vl_packet) /* $V'_3$ */
15101 @d x1l stack_1(xl_packet) /* $X'_1$ */
15102 @d x2l stack_2(xl_packet) /* $X'_2$ */
15103 @d x3l stack_3(xl_packet) /* $X'_3$ */
15104 @d y1l stack_1(yl_packet) /* $Y'_1$ */
15105 @d y2l stack_2(yl_packet) /* $Y'_2$ */
15106 @d y3l stack_3(yl_packet) /* $Y'_3$ */
15107 @d u1r stack_1(ur_packet) /* $U''_1$ */
15108 @d u2r stack_2(ur_packet) /* $U''_2$ */
15109 @d u3r stack_3(ur_packet) /* $U''_3$ */
15110 @d v1r stack_1(vr_packet) /* $V''_1$ */
15111 @d v2r stack_2(vr_packet) /* $V''_2$ */
15112 @d v3r stack_3(vr_packet) /* $V''_3$ */
15113 @d x1r stack_1(xr_packet) /* $X''_1$ */
15114 @d x2r stack_2(xr_packet) /* $X''_2$ */
15115 @d x3r stack_3(xr_packet) /* $X''_3$ */
15116 @d y1r stack_1(yr_packet) /* $Y''_1$ */
15117 @d y2r stack_2(yr_packet) /* $Y''_2$ */
15118 @d y3r stack_3(yr_packet) /* $Y''_3$ */
15120 @d stack_dx mp->bisect_stack[mp->bisect_ptr] /* stacked value of |delx| */
15121 @d stack_dy mp->bisect_stack[mp->bisect_ptr+1] /* stacked value of |dely| */
15122 @d stack_tol mp->bisect_stack[mp->bisect_ptr+2] /* stacked value of |tol| */
15123 @d stack_uv mp->bisect_stack[mp->bisect_ptr+3] /* stacked value of |uv| */
15124 @d stack_xy mp->bisect_stack[mp->bisect_ptr+4] /* stacked value of |xy| */
15125 @d int_increment (int_packets+int_packets+5) /* number of stack words per level */
15128 mp_number *bisect_stack;
15129 integer bisect_ptr;
15131 @ @<Allocate or initialize ...@>=
15132 mp->bisect_stack = xmalloc ((bistack_size + 1), sizeof (mp_number));
15135 for (i=0;i<bistack_size + 1;i++) {
15136 new_number (mp->bisect_stack[i]);
15140 @ @<Dealloc variables@>=
15143 for (i=0;i<bistack_size + 1;i++) {
15144 free_number (mp->bisect_stack[i]);
15147 xfree (mp->bisect_stack);
15149 @ @<Check the ``constant''...@>=
15150 if (int_packets + 17 * int_increment > bistack_size)
15153 @ Computation of the min and max is a tedious but fairly fast sequence of
15154 instructions; exactly four comparisons are made in each branch.
15157 debug_number (stack_1(A));
15158 debug_number (stack_3(A));
15159 debug_number (stack_2(A));
15160 debug_number (stack_min(A));
15161 debug_number (stack_max(A));
15162 if ( number_negative(stack_1((A))) ) {
15163 if ( number_nonnegative (stack_3((A))) ) {
15164 if ( number_negative (stack_2((A))) )
15165 set_number_from_addition (stack_min((A)), stack_1((A)), stack_2((A)));
15167 number_clone (stack_min((A)), stack_1((A)));
15168 set_number_from_addition (stack_max((A)), stack_1((A)), stack_2((A)));
15169 number_add (stack_max((A)), stack_3((A)));
15170 if ( number_negative (stack_max((A))) )
15171 set_number_to_zero (stack_max((A)));
15173 set_number_from_addition (stack_min((A)), stack_1((A)), stack_2((A)));
15174 number_add (stack_min((A)), stack_3((A)));
15175 if ( number_greater (stack_min((A)), stack_1((A))))
15176 number_clone (stack_min((A)), stack_1((A)));
15177 set_number_from_addition (stack_max((A)), stack_1((A)), stack_2((A)));
15178 if ( number_negative (stack_max((A))) )
15179 set_number_to_zero (stack_max((A)));
15181 } else if ( number_nonpositive (stack_3((A)))) {
15182 if ( number_positive (stack_2((A))) )
15183 set_number_from_addition (stack_max((A)), stack_1((A)), stack_2((A)));
15185 number_clone (stack_max((A)), stack_1((A)));
15186 set_number_from_addition (stack_min((A)), stack_1((A)), stack_2((A)));
15187 number_add (stack_min((A)), stack_3((A)));
15188 if ( number_positive (stack_min((A))) )
15189 set_number_to_zero (stack_min((A)));
15191 set_number_from_addition (stack_max((A)), stack_1((A)), stack_2((A)));
15192 number_add (stack_max((A)), stack_3((A)));
15193 if ( number_less (stack_max((A)), stack_1((A))))
15194 number_clone (stack_max((A)), stack_1((A)));
15195 set_number_from_addition (stack_min((A)), stack_1((A)), stack_2((A)));
15196 if ( number_positive (stack_min((A))) )
15197 set_number_to_zero (stack_min((A)));
15200 @ It's convenient to keep the current values of $l$, $t_1$, and $t_2$ in
15201 the integer form $2^l+2^lt_1$ and $2^l+2^lt_2$. The |cubic_intersection|
15202 routine uses global variables |cur_t| and |cur_tt| for this purpose;
15203 after successful completion, |cur_t| and |cur_tt| will contain |unity|
15204 plus the |scaled| values of $t_1$ and~$t_2$.
15206 The values of |cur_t| and |cur_tt| will be set to zero if |cubic_intersection|
15207 finds no intersection. The routine gives up and gives an approximate answer
15208 if it has backtracked
15209 more than 5000 times (otherwise there are cases where several minutes
15210 of fruitless computation would be possible).
15212 @d max_patience 5000
15216 mp_number cur_tt; /* controls and results of |cubic_intersection| */
15217 integer time_to_go; /* this many backtracks before giving up */
15218 mp_number max_t; /* maximum of $2^{l+1}$ so far achieved */
15220 @ @<Initialize table ...@>=
15221 new_number (mp->cur_t);
15222 new_number (mp->cur_tt);
15223 new_number (mp->max_t);
15226 free_number (mp->cur_t);
15227 free_number (mp->cur_tt);
15228 free_number (mp->max_t);
15230 @ The given cubics $B(w_0,w_1,w_2,w_3;t)$ and
15231 $B(z_0,z_1,z_2,z_3;t)$ are specified in adjacent knot nodes |(p,mp_link(p))|
15232 and |(pp,mp_link(pp))|, respectively.
15237 static void mp_cubic_intersection (MP mp, mp_knot p, mp_knot pp) {
15238 mp_knot q, qq; /* |mp_link(p)|, |mp_link(pp)| */
15239 mp->time_to_go = max_patience;
15240 set_number_from_scaled (mp->max_t, 2);
15241 @<Initialize for intersections at level zero@>;
15244 if (number_to_scaled (mp->delx) - mp->tol <=
15245 number_to_scaled (stack_max (x_packet (mp->xy))) - number_to_scaled (stack_min (u_packet (mp->uv))))
15246 if (number_to_scaled (mp->delx) + mp->tol >=
15247 number_to_scaled (stack_min (x_packet (mp->xy))) - number_to_scaled (stack_max (u_packet (mp->uv))))
15248 if (number_to_scaled (mp->dely) - mp->tol <=
15249 number_to_scaled (stack_max (y_packet (mp->xy))) - number_to_scaled (stack_min (v_packet (mp->uv))))
15250 if (number_to_scaled (mp->dely) + mp->tol >=
15251 number_to_scaled (stack_min (y_packet (mp->xy))) - number_to_scaled (stack_max (v_packet (mp->uv)))) {
15252 if (number_to_scaled (mp->cur_t) >= number_to_scaled (mp->max_t)) {
15253 if (number_equal(mp->max_t, two_t)) { /* we've done 17 bisections */
15254 set_number_from_scaled (mp->cur_t, ((number_to_scaled (mp->cur_t) + 1)/2));
15255 set_number_from_scaled (mp->cur_tt, ((number_to_scaled (mp->cur_tt) + 1)/2));
15258 number_double(mp->max_t);
15259 number_clone (mp->appr_t, mp->cur_t);
15260 number_clone (mp->appr_tt, mp->cur_tt);
15262 @<Subdivide for a new level of intersection@>;
15265 if (mp->time_to_go > 0) {
15266 decr (mp->time_to_go);
15268 while (number_less (mp->appr_t, unity_t)) {
15269 number_double(mp->appr_t);
15270 number_double(mp->appr_tt);
15272 number_clone (mp->cur_t, mp->appr_t);
15273 number_clone (mp->cur_tt, mp->appr_tt);
15277 /* Advance to the next pair |(cur_t,cur_tt)| */
15278 if (odd (number_to_scaled (mp->cur_tt))) {
15279 if (odd (number_to_scaled (mp->cur_t))) {
15280 /* Descend to the previous level and |goto not_found| */
15282 set_number_from_scaled (mp->cur_t, half (number_to_scaled (mp->cur_t)));
15283 set_number_from_scaled (mp->cur_tt, half (number_to_scaled (mp->cur_tt)));
15284 if (number_to_scaled (mp->cur_t) == 0)
15286 mp->bisect_ptr -= int_increment;
15287 mp->three_l -= (integer) mp->tol_step;
15288 number_clone (mp->delx, stack_dx);
15289 number_clone (mp->dely, stack_dy);
15290 mp->tol = number_to_scaled (stack_tol);
15291 mp->uv = number_to_scaled (stack_uv);
15292 mp->xy = number_to_scaled (stack_xy);
15297 set_number_from_scaled (mp->cur_t, number_to_scaled (mp->cur_t) + 1);
15298 number_add (mp->delx, stack_1 (u_packet (mp->uv)));
15299 number_add (mp->delx, stack_2 (u_packet (mp->uv)));
15300 number_add (mp->delx, stack_3 (u_packet (mp->uv)));
15301 number_add (mp->dely, stack_1 (v_packet (mp->uv)));
15302 number_add (mp->dely, stack_2 (v_packet (mp->uv)));
15303 number_add (mp->dely, stack_3 (v_packet (mp->uv)));
15304 mp->uv = mp->uv + int_packets; /* switch from |l_packets| to |r_packets| */
15305 set_number_from_scaled (mp->cur_tt, number_to_scaled (mp->cur_tt) - 1);
15306 mp->xy = mp->xy - int_packets;
15307 number_add (mp->delx, stack_1 (x_packet (mp->xy)));
15308 number_add (mp->delx, stack_2 (x_packet (mp->xy)));
15309 number_add (mp->delx, stack_3 (x_packet (mp->xy)));
15310 number_add (mp->dely, stack_1 (y_packet (mp->xy)));
15311 number_add (mp->dely, stack_2 (y_packet (mp->xy)));
15312 number_add (mp->dely, stack_3 (y_packet (mp->xy)));
15315 set_number_from_scaled (mp->cur_tt, number_to_scaled (mp->cur_tt) + 1);
15316 mp->tol = mp->tol + mp->three_l;
15317 number_substract (mp->delx, stack_1 (x_packet (mp->xy)));
15318 number_substract (mp->delx, stack_2 (x_packet (mp->xy)));
15319 number_substract (mp->delx, stack_3 (x_packet (mp->xy)));
15320 number_substract (mp->dely, stack_1 (y_packet (mp->xy)));
15321 number_substract (mp->dely, stack_2 (y_packet (mp->xy)));
15322 number_substract (mp->dely, stack_3 (y_packet (mp->xy)));
15323 mp->xy = mp->xy + int_packets; /* switch from |l_packets| to |r_packets| */
15329 @ The following variables are global, although they are used only by
15330 |cubic_intersection|, because it is necessary on some machines to
15331 split |cubic_intersection| up into two procedures.
15335 mp_number dely; /* the components of $\Delta=2^l(w_0-z_0)$ */
15336 integer tol; /* bound on the uncertainty in the overlap test */
15338 integer xy; /* pointers to the current packets of interest */
15339 integer three_l; /* |tol_step| times the bisection level */
15341 mp_number appr_tt; /* best approximations known to the answers */
15343 @ @<Initialize table ...@>=
15344 new_number (mp->delx);
15345 new_number (mp->dely);
15346 new_number (mp->appr_t);
15347 new_number (mp->appr_tt);
15350 free_number (mp->delx);
15351 free_number (mp->dely);
15352 free_number (mp->appr_t);
15353 free_number (mp->appr_tt);
15355 @ We shall assume that the coordinates are sufficiently non-extreme that
15356 integer overflow will not occur.
15357 @^overflow in arithmetic@>
15359 @<Initialize for intersections at level zero@>=
15360 q = mp_next_knot (p);
15361 qq = mp_next_knot (pp);
15362 mp->bisect_ptr = int_packets;
15363 set_number_from_substraction (u1r, p->right_x, p->x_coord);
15364 set_number_from_substraction (u2r, q->left_x, p->right_x);
15365 set_number_from_substraction (u3r, q->x_coord, q->left_x);
15366 set_min_max (ur_packet);
15367 set_number_from_substraction (v1r, p->right_y, p->y_coord );
15368 set_number_from_substraction (v2r, q->left_y, p->right_y);
15369 set_number_from_substraction (v3r, q->y_coord, q->left_y );
15370 set_min_max (vr_packet);
15371 set_number_from_substraction (x1r, pp->right_x, pp->x_coord );
15372 set_number_from_substraction (x2r, qq->left_x, pp->right_x );
15373 set_number_from_substraction (x3r, qq->x_coord, qq->left_x );
15374 set_min_max (xr_packet);
15375 set_number_from_substraction (y1r, pp->right_y, pp->y_coord );
15376 set_number_from_substraction (y2r, qq->left_y, pp->right_y);
15377 set_number_from_substraction (y3r, qq->y_coord, qq->left_y);
15378 set_min_max (yr_packet);
15379 set_number_from_substraction (mp->delx, p->x_coord, pp->x_coord );
15380 set_number_from_substraction (mp->dely, p->y_coord, pp->y_coord );
15382 mp->uv = r_packets;
15383 mp->xy = r_packets;
15385 set_number_from_scaled (mp->cur_t, 1);
15386 set_number_from_scaled (mp->cur_tt, 1)
15390 @<Subdivide for a new level of intersection@>=
15391 number_clone (stack_dx, mp->delx);
15392 number_clone (stack_dy, mp->dely);
15393 set_number_from_scaled (stack_tol, mp->tol);
15394 set_number_from_scaled (stack_uv, mp->uv);
15395 set_number_from_scaled (stack_xy, mp->xy);
15396 mp->bisect_ptr = mp->bisect_ptr + int_increment;
15397 number_double (mp->cur_t);
15398 number_double (mp->cur_tt);
15399 number_clone (u1l, stack_1 (u_packet (mp->uv)));
15400 number_clone (u3r, stack_3 (u_packet (mp->uv)));
15401 set_number_from_addition (u2l, u1l, stack_2 (u_packet (mp->uv))); number_half (u2l);
15402 set_number_from_addition (u2r, u3r, stack_2 (u_packet (mp->uv))); number_half (u2r);
15403 set_number_from_addition (u3l, u2l, u2r); number_half (u3l);
15404 number_clone (u1r, u3l);
15405 set_min_max (ul_packet);
15406 set_min_max (ur_packet);
15407 number_clone (v1l, stack_1 (v_packet (mp->uv)));
15408 number_clone (v3r, stack_3 (v_packet (mp->uv)));
15409 set_number_from_addition (v2l, v1l, stack_2 (v_packet (mp->uv))); number_half(v2l);
15410 set_number_from_addition (v2r, v3r, stack_2 (v_packet (mp->uv))); number_half(v2r);
15411 set_number_from_addition (v3l, v2l, v2r); number_half(v3l);
15412 number_clone (v1r, v3l);
15413 set_min_max (vl_packet);
15414 set_min_max (vr_packet);
15415 number_clone (x1l, stack_1 (x_packet (mp->xy)));
15416 number_clone (x3r, stack_3 (x_packet (mp->xy)));
15417 set_number_from_addition (x2l, x1l, stack_2 (x_packet (mp->xy))); number_half(x2l);
15418 set_number_from_addition (x2r, x3r, stack_2 (x_packet (mp->xy))); number_half(x2r);
15419 set_number_from_addition (x3l, x2l, x2r); number_half(x3l);
15420 number_clone (x1r, x3l);
15421 set_min_max (xl_packet);
15422 set_min_max (xr_packet);
15423 number_clone (y1l, stack_1 (y_packet (mp->xy)));
15424 number_clone (y3r, stack_3 (y_packet (mp->xy)));
15425 set_number_from_addition (y2l, y1l, stack_2 (y_packet (mp->xy))); number_half (y2l);
15426 set_number_from_addition (y2r, y3r, stack_2 (y_packet (mp->xy))); number_half (y2r);
15427 set_number_from_addition (y3l, y2l, y2r); number_half (y3l);
15428 number_clone (y1r, y3l);
15429 set_min_max (yl_packet);
15430 set_min_max (yr_packet);
15431 mp->uv = l_packets;
15432 mp->xy = l_packets;
15433 number_double(mp->delx);
15434 number_double(mp->dely);
15435 mp->tol = mp->tol - mp->three_l + (integer) mp->tol_step;
15436 mp->tol += mp->tol;
15437 mp->three_l = mp->three_l + (integer) mp->tol_step
15439 @ The |path_intersection| procedure is much simpler.
15440 It invokes |cubic_intersection| in lexicographic order until finding a
15441 pair of cubics that intersect. The final intersection times are placed in
15442 |cur_t| and~|cur_tt|.
15445 static void mp_path_intersection (MP mp, mp_knot h, mp_knot hh) {
15446 mp_knot p, pp; /* link registers that traverse the given paths */
15447 mp_number n, nn; /* integer parts of intersection times, minus |unity| */
15448 @<Change one-point paths into dead cycles@>;
15453 set_number_to_unity(n);
15457 if (mp_right_type (p) != mp_endpoint) {
15458 set_number_to_unity(nn);
15459 number_negate (nn);
15462 if (mp_right_type (pp) != mp_endpoint) {
15463 mp_cubic_intersection (mp, p, pp);
15464 if (number_positive (mp->cur_t)) {
15465 number_add (mp->cur_t, n);
15466 number_add (mp->cur_tt, nn);
15470 number_add(nn, unity_t);
15471 pp = mp_next_knot (pp);
15472 } while (pp != hh);
15474 number_add(n, unity_t);
15475 p = mp_next_knot (p);
15477 mp->tol_step = mp->tol_step + 3;
15478 } while (mp->tol_step <= 3);
15479 number_clone (mp->cur_t, unity_t);
15480 number_negate (mp->cur_t);
15481 number_clone (mp->cur_tt, unity_t);
15482 number_negate (mp->cur_tt);
15489 @ @<Change one-point paths...@>=
15490 if (mp_right_type (h) == mp_endpoint) {
15491 number_clone (h->right_x, h->x_coord);
15492 number_clone (h->left_x, h->x_coord);
15493 number_clone (h->right_y, h->y_coord);
15494 number_clone (h->left_y, h->y_coord);
15495 mp_right_type (h) = mp_explicit;
15497 if (mp_right_type (hh) == mp_endpoint) {
15498 number_clone (hh->right_x, hh->x_coord);
15499 number_clone (hh->left_x, hh->x_coord);
15500 number_clone (hh->right_y, hh->y_coord);
15501 number_clone (hh->left_y, hh->y_coord);
15502 mp_right_type (hh) = mp_explicit;
15505 @* Dynamic linear equations.
15506 \MP\ users define variables implicitly by stating equations that should be
15507 satisfied; the computer is supposed to be smart enough to solve those equations.
15508 And indeed, the computer tries valiantly to do so, by distinguishing five
15509 different types of numeric values:
15512 |type(p)=mp_known| is the nice case, when |value(p)| is the |scaled| value
15513 of the variable whose address is~|p|.
15516 |type(p)=mp_dependent| means that |value(p)| is not present, but |dep_list(p)|
15517 points to a {\sl dependency list\/} that expresses the value of variable~|p|
15518 as a |scaled| number plus a sum of independent variables with |fraction|
15522 |type(p)=mp_independent| means that |indep_value(p)=s|, where |s>0| is a ``serial
15523 number'' reflecting the time this variable was first used in an equation;
15524 and there is an extra field |indep_scale(p)=m|, with |0<=m<64|, each dependent
15525 variable that refers to this one is actually referring to the future value of
15526 this variable times~$2^m$. (Usually |m=0|, but higher degrees of
15527 scaling are sometimes needed to keep the coefficients in dependency lists
15528 from getting too large. The value of~|m| will always be even.)
15531 |type(p)=mp_numeric_type| means that variable |p| hasn't appeared in an
15532 equation before, but it has been explicitly declared to be numeric.
15535 |type(p)=undefined| means that variable |p| hasn't appeared before.
15537 \smallskip\noindent
15538 We have actually discussed these five types in the reverse order of their
15539 history during a computation: Once |known|, a variable never again
15540 becomes |dependent|; once |dependent|, it almost never again becomes
15541 |mp_independent|; once |mp_independent|, it never again becomes |mp_numeric_type|;
15542 and once |mp_numeric_type|, it never again becomes |undefined| (except
15543 of course when the user specifically decides to scrap the old value
15544 and start again). A backward step may, however, take place: Sometimes
15545 a |dependent| variable becomes |mp_independent| again, when one of the
15546 independent variables it depends on is reverting to |undefined|.
15548 @d indep_scale(A) ((mp_value_node)(A))->data.indep.scale
15549 @d set_indep_scale(A,B) ((mp_value_node)(A))->data.indep.scale=(B)
15550 @d indep_value(A) ((mp_value_node)(A))->data.indep.serial
15551 @d set_indep_value(A,B) ((mp_value_node)(A))->data.indep.serial=(B)
15555 void mp_new_indep(MP mp, mp_node p) { /* create a new independent variable */
15556 if ( mp->serial_no>=max_integer ) {
15557 mp_fatal_error(mp, "variable instance identifiers exhausted");
15559 mp_type(p)=mp_independent;
15560 mp->serial_no=mp->serial_no+1;
15561 set_indep_scale(p,0);
15562 set_indep_value(p,mp->serial_no);
15565 @ @<Declarations@>=
15566 void mp_new_indep(MP mp, mp_node p);
15570 integer serial_no; /* the most recent serial number */
15572 @ But how are dependency lists represented? It's simple: The linear combination
15573 $\alpha_1v_1+\cdots+\alpha_kv_k+\beta$ appears in |k+1| value nodes. If
15574 |q=dep_list(p)| points to this list, and if |k>0|, then |dep_value(q)=
15575 @t$\alpha_1$@>| (which is a |fraction|); |dep_info(q)| points to the location
15576 of $\alpha_1$; and |mp_link(p)| points to the dependency list
15577 $\alpha_2v_2+\cdots+\alpha_kv_k+\beta$. On the other hand if |k=0|,
15578 then |dep_value(q)=@t$\beta$@>| (which is |scaled|) and |dep_info(q)=NULL|.
15579 The independent variables $v_1$, \dots,~$v_k$ have been sorted so that
15580 they appear in decreasing order of their |value| fields (i.e., of
15581 their serial numbers). \ (It is convenient to use decreasing order,
15582 since |value(NULL)=0|. If the independent variables were not sorted by
15583 serial number but by some other criterion, such as their location in |mem|,
15584 the equation-solving mechanism would be too system-dependent, because
15585 the ordering can affect the computed results.)
15587 The |link| field in the node that contains the constant term $\beta$ is
15588 called the {\sl final link\/} of the dependency list. \MP\ maintains
15589 a doubly-linked master list of all dependency lists, in terms of a permanently
15591 in |mem| called |dep_head|. If there are no dependencies, we have
15592 |mp_link(dep_head)=dep_head| and |prev_dep(dep_head)=dep_head|;
15593 otherwise |mp_link(dep_head)| points to the first dependent variable, say~|p|,
15594 and |prev_dep(p)=dep_head|. We have |type(p)=mp_dependent|, and |dep_list(p)|
15595 points to its dependency list. If the final link of that dependency list
15596 occurs in location~|q|, then |mp_link(q)| points to the next dependent
15597 variable (say~|r|); and we have |prev_dep(r)=q|, etc.
15599 Dependency nodes sometimes mutate into value nodes and vice versa, so their
15600 structures have to match.
15602 @d dep_value(A) ((mp_value_node)(A))->data.n
15603 @d set_dep_value(A,B) do_set_dep_value(mp,(A),(B))
15604 @d dep_info(A) get_dep_info(mp, (A))
15605 @d set_dep_info(A,B) do {
15606 mp_value_node d = (mp_value_node)(B);
15607 FUNCTION_TRACE4("set_dep_info(%p,%p) on %d\n",(A),d,__LINE__);
15608 ((mp_value_node)(A))->parent_ = (mp_node)d;
15610 @d dep_list(A) ((mp_value_node)(A))->attr_head_ /* half of the |value| field in a |dependent| variable */
15611 @d set_dep_list(A,B) do {
15612 mp_value_node d = (mp_value_node)(B);
15613 FUNCTION_TRACE4("set_dep_list(%p,%p) on %d\n",(A),d,__LINE__);
15614 dep_list((A)) = (mp_node)d;
15616 @d prev_dep(A) ((mp_value_node)(A))->subscr_head_ /* the other half; makes a doubly linked list */
15617 @d set_prev_dep(A,B) do {
15618 mp_value_node d = (mp_value_node)(B);
15619 FUNCTION_TRACE4("set_prev_dep(%p,%p) on %d\n",(A),d,__LINE__);
15620 prev_dep((A)) = (mp_node)d;
15624 static mp_node get_dep_info (MP mp, mp_value_node p) {
15626 d = p->parent_; /* half of the |value| field in a |dependent| variable */
15627 FUNCTION_TRACE3 ("%p = dep_info(%p)\n", d, p);
15630 static void do_set_dep_value (MP mp, mp_value_node p, mp_number q) {
15631 number_clone (p->data.n, q); /* half of the |value| field in a |dependent| variable */
15632 FUNCTION_TRACE3("set_dep_value(%p,%d)\n", p, q);
15633 p->attr_head_ = NULL;
15634 p->subscr_head_ = NULL;
15637 @ @<Declarations...@>=
15638 static mp_node get_dep_info (MP mp, mp_value_node p);
15643 static mp_value_node mp_get_dep_node (MP mp) {
15644 mp_value_node p = (mp_value_node) mp_get_value_node (mp);
15645 mp_type (p) = mp_dep_node_type;
15648 static void mp_free_dep_node (MP mp, mp_value_node p) {
15649 mp_free_value_node (mp, (mp_node) p);
15653 @ @<Declarations...@>=
15654 static void mp_free_dep_node (MP mp, mp_value_node p);
15656 @ @<Initialize table entries@>=
15658 mp->dep_head = mp_get_dep_node (mp);
15659 set_mp_link (mp->dep_head, (mp_node) mp->dep_head);
15660 set_prev_dep (mp->dep_head, (mp_node) mp->dep_head);
15661 set_dep_info (mp->dep_head, NULL);
15662 set_dep_list (mp->dep_head, NULL);
15664 @ @<Free table entries@>=
15665 mp_free_dep_node (mp, mp->dep_head);
15667 @ Actually the description above contains a little white lie. There's
15668 another kind of variable called |mp_proto_dependent|, which is
15669 just like a |dependent| one except that the $\alpha$ coefficients
15670 in its dependency list are |scaled| instead of being fractions.
15671 Proto-dependency lists are mixed with dependency lists in the
15672 nodes reachable from |dep_head|.
15674 @ Here is a procedure that prints a dependency list in symbolic form.
15675 The second parameter should be either |dependent| or |mp_proto_dependent|,
15676 to indicate the scaling of the coefficients.
15679 static void mp_print_dependency (MP mp, mp_value_node p, quarterword t);
15682 void mp_print_dependency (MP mp, mp_value_node p, quarterword t) {
15683 mp_number v; /* a coefficient */
15684 mp_value_node pp; /* for list manipulation */
15689 number_clone (v, dep_value (p));
15692 if (q == NULL) { /* the constant term */
15693 if (number_nonzero(v) || (p == pp)) {
15694 if (number_positive(dep_value (p)))
15696 mp_print_char (mp, xord ('+'));
15697 print_number (dep_value (p));
15701 /* Print the coefficient, unless it's $\pm1.0$ */
15702 if (number_negative(dep_value (p)))
15703 mp_print_char (mp, xord ('-'));
15705 mp_print_char (mp, xord ('+'));
15706 if (t == mp_dependent) {
15707 fraction_to_round_scaled (v);
15709 if (!number_equal (v, unity_t))
15712 if (mp_type (q) != mp_independent)
15713 mp_confusion (mp, "dep");
15714 mp_print_variable_name (mp, q);
15715 set_number_from_scaled (v, indep_scale(q));
15716 while (number_positive (v)) {
15717 mp_print (mp, "*4");
15718 number_add_scaled (v, -2);
15720 p = (mp_value_node) mp_link (p);
15726 @ The maximum absolute value of a coefficient in a given dependency list
15727 is returned by the following simple function.
15730 static void mp_max_coef (MP mp, mp_number *x, mp_value_node p) {
15733 set_number_to_zero (*x);
15734 while (dep_info (p) != NULL) {
15735 number_clone (absv, dep_value (p));
15737 if (number_greater (absv, *x)) {
15738 number_clone (*x, absv);
15740 p = (mp_value_node) mp_link (p);
15742 free_number (absv);
15746 @ One of the main operations needed on dependency lists is to add a multiple
15747 of one list to the other; we call this |p_plus_fq|, where |p| and~|q| point
15748 to dependency lists and |f| is a fraction.
15750 If the coefficient of any independent variable becomes |coef_bound| or
15751 more, in absolute value, this procedure changes the type of that variable
15752 to `|independent_needing_fix|', and sets the global variable |fix_needed|
15753 to~|true|. The value of $|coef_bound|=\mu$ is chosen so that
15754 $\mu^2+\mu<8$; this means that the numbers we deal with won't
15755 get too large. (Instead of the ``optimum'' $\mu=(\sqrt{33}-1)/2\approx
15756 2.3723$, the safer value 7/3 is taken as the threshold.)
15758 The changes mentioned in the preceding paragraph are actually done only if
15759 the global variable |watch_coefs| is |true|. But it usually is; in fact,
15760 it is |false| only when \MP\ is making a dependency list that will soon
15761 be equated to zero.
15763 Several procedures that act on dependency lists, including |p_plus_fq|,
15764 set the global variable |dep_final| to the final (constant term) node of
15765 the dependency list that they produce.
15767 @d independent_needing_fix 0
15770 boolean fix_needed; /* does at least one |independent| variable need scaling? */
15771 boolean watch_coefs; /* should we scale coefficients that exceed |coef_bound|? */
15772 mp_value_node dep_final; /* location of the constant term and final link */
15775 mp->fix_needed = false;
15776 mp->watch_coefs = true;
15778 @ The |p_plus_fq| procedure has a fourth parameter, |t|, that should be
15779 set to |mp_proto_dependent| if |p| is a proto-dependency list. In this
15780 case |f| will be |scaled|, not a |fraction|. Similarly, the fifth parameter~|tt|
15781 should be |mp_proto_dependent| if |q| is a proto-dependency list.
15783 List |q| is unchanged by the operation; but list |p| is totally destroyed.
15785 The final link of the dependency list or proto-dependency list returned
15786 by |p_plus_fq| is the same as the original final link of~|p|. Indeed, the
15787 constant term of the result will be located in the same |mem| location
15788 as the original constant term of~|p|.
15790 Coefficients of the result are assumed to be zero if they are less than
15791 a certain threshold. This compensates for inevitable rounding errors,
15792 and tends to make more variables `|known|'. The threshold is approximately
15793 $10^{-5}$ in the case of normal dependency lists, $10^{-4}$ for
15794 proto-dependencies.
15796 @d fraction_threshold_k ((math_data *)mp->math)->fraction_threshold_t
15797 @d half_fraction_threshold_k ((math_data *)mp->math)->half_fraction_threshold_t
15798 @d scaled_threshold_k ((math_data *)mp->math)->scaled_threshold_t
15799 @d half_scaled_threshold_k ((math_data *)mp->math)->half_scaled_threshold_t
15802 static mp_value_node mp_p_plus_fq (MP mp, mp_value_node p, mp_number f,
15803 mp_value_node q, mp_variable_type t,
15804 mp_variable_type tt);
15807 static mp_value_node mp_p_plus_fq (MP mp, mp_value_node p, mp_number f,
15808 mp_value_node q, mp_variable_type t,
15809 mp_variable_type tt) {
15810 mp_node pp, qq; /* |dep_info(p)| and |dep_info(q)|, respectively */
15811 mp_value_node r, s; /* for list manipulation */
15812 mp_number threshold, half_threshold; /* defines a neighborhood of zero */
15813 mp_number v, vv; /* temporary registers */
15816 new_number (threshold);
15817 new_number (half_threshold);
15818 if (t == mp_dependent) {
15819 number_clone (threshold, fraction_threshold_k);
15820 number_clone (half_threshold, half_fraction_threshold_k);
15822 number_clone (threshold, scaled_threshold_k);
15823 number_clone (half_threshold, half_scaled_threshold_k);
15825 r = (mp_value_node) mp->temp_head;
15833 /* Contribute a term from |p|, plus |f| times the
15834 corresponding term from |q| */
15839 if (tt == mp_dependent) {
15840 take_fraction (r1, f, dep_value (q));
15842 take_scaled (r1, f, dep_value (q));
15844 set_number_from_addition (v, dep_value (p), r1);
15846 set_dep_value (p, v);
15848 p = (mp_value_node) mp_link (p);
15849 number_clone (absv, v);
15851 if (number_less (absv, threshold)) {
15852 mp_free_dep_node (mp, s);
15854 if (number_greaterequal (absv, coef_bound_k) && mp->watch_coefs) {
15855 mp_type (qq) = independent_needing_fix;
15856 /* If we set this , then we can drop (mp_type(pp) == independent_needing_fix && mp->fix_needed) later */
15857 /* set_number_from_scaled (value_number (qq), indep_value(qq)); */
15858 mp->fix_needed = true;
15860 set_mp_link (r, (mp_node) s);
15863 free_number (absv);
15865 q = (mp_value_node) mp_link (q);
15871 set_number_to_neg_inf(v);
15872 else if (mp_type(pp) == mp_independent || (mp_type(pp) == independent_needing_fix && mp->fix_needed))
15873 set_number_from_scaled(v, indep_value(pp));
15875 number_clone (v, value_number (pp));
15877 set_number_to_neg_inf(vv);
15878 else if (mp_type(qq) == mp_independent || (mp_type(qq) == independent_needing_fix && mp->fix_needed))
15879 set_number_from_scaled(vv, indep_value(qq));
15881 number_clone (vv, value_number (qq));
15882 if (number_less (v, vv)) {
15883 /* Contribute a term from |q|, multiplied by~|f| */
15888 mp_number arg1, arg2;
15892 number_clone (arg1, f);
15893 number_clone (arg2, dep_value (q));
15894 if (tt == mp_dependent) {
15895 take_fraction (r1, arg1, arg2);
15897 take_scaled (r1, arg1, arg2);
15899 number_clone (v, r1);
15901 free_number (arg1);
15902 free_number (arg2);
15904 number_clone (absv, v);
15906 if (number_greater (absv, half_threshold)) {
15907 s = mp_get_dep_node (mp);
15908 set_dep_info (s, qq);
15909 set_dep_value (s, v);
15910 if (number_greaterequal(absv, coef_bound_k) && mp->watch_coefs) {
15911 /* clang: dereference of a null pointer ('qq') */ assert(qq);
15912 mp_type (qq) = independent_needing_fix;
15913 mp->fix_needed = true;
15915 set_mp_link (r, (mp_node) s);
15918 q = (mp_value_node) mp_link (q);
15920 free_number (absv);
15923 set_mp_link (r, (mp_node) p);
15925 p = (mp_value_node) mp_link (p);
15932 mp_number arg1, arg2;
15936 number_clone (arg1, dep_value (q));
15937 number_clone (arg2, f);
15938 if (t == mp_dependent) {
15939 take_fraction (r1, arg1, arg2);
15941 take_scaled (r1, arg1, arg2);
15943 slow_add (arg1, dep_value (p), r1);
15944 set_dep_value (p, arg1);
15946 free_number (arg1);
15947 free_number (arg2);
15949 set_mp_link (r, (mp_node) p);
15951 free_number (threshold);
15952 free_number (half_threshold);
15955 return (mp_value_node) mp_link (mp->temp_head);
15959 @ It is convenient to have another subroutine for the special case
15960 of |p_plus_fq| when |f=1.0|. In this routine lists |p| and |q| are
15961 both of the same type~|t| (either |dependent| or |mp_proto_dependent|).
15964 static mp_value_node mp_p_plus_q (MP mp, mp_value_node p, mp_value_node q,
15965 mp_variable_type t) {
15966 mp_node pp, qq; /* |dep_info(p)| and |dep_info(q)|, respectively */
15967 mp_value_node s; /* for list manipulation */
15968 mp_value_node r; /* for list manipulation */
15969 mp_number threshold; /* defines a neighborhood of zero */
15970 mp_number v, vv; /* temporary register */
15973 new_number (threshold);
15974 if (t == mp_dependent)
15975 number_clone (threshold, fraction_threshold_k);
15977 number_clone (threshold, scaled_threshold_k);
15978 r = (mp_value_node) mp->temp_head;
15986 /* Contribute a term from |p|, plus the corresponding term from |q| */
15989 set_number_from_addition (v, dep_value (p), dep_value (q));
15990 set_dep_value (p, v);
15992 p = (mp_value_node) mp_link (p);
15994 number_clone (test, v);
15996 if (number_less (test, threshold)) {
15997 mp_free_dep_node (mp, s);
15999 if (number_greaterequal(test, coef_bound_k) && mp->watch_coefs) {
16000 mp_type (qq) = independent_needing_fix;
16001 /* If we set this , then we can drop (mp_type(pp) == independent_needing_fix && mp->fix_needed) later */
16002 /* set_number_from_scaled (value_number (qq), indep_value(qq)); */
16003 mp->fix_needed = true;
16005 set_mp_link (r, (mp_node) s);
16008 free_number (test);
16009 q = (mp_value_node) mp_link (q);
16015 set_number_to_zero (v);
16016 else if (mp_type(pp) == mp_independent || (mp_type(pp) == independent_needing_fix && mp->fix_needed))
16017 set_number_from_scaled (v, indep_value(pp));
16019 number_clone (v, value_number (pp));
16021 set_number_to_zero (vv);
16022 else if (mp_type(qq) == mp_independent || (mp_type(qq) == independent_needing_fix && mp->fix_needed))
16023 set_number_from_scaled (vv, indep_value(qq));
16025 number_clone (vv, value_number (qq));
16026 if (number_less (v, vv)) {
16027 s = mp_get_dep_node (mp);
16028 set_dep_info (s, qq);
16029 set_dep_value (s, dep_value (q));
16030 q = (mp_value_node) mp_link (q);
16032 set_mp_link (r, (mp_node) s);
16035 set_mp_link (r, (mp_node) p);
16037 p = (mp_value_node) mp_link (p);
16045 slow_add (r1, dep_value (p), dep_value (q));
16046 set_dep_value (p, r1);
16049 set_mp_link (r, (mp_node) p);
16053 free_number (threshold);
16054 return (mp_value_node) mp_link (mp->temp_head);
16057 @ A somewhat simpler routine will multiply a dependency list
16058 by a given constant~|v|. The constant is either a |fraction| less than
16059 |fraction_one|, or it is |scaled|. In the latter case we might be forced to
16060 convert a dependency list to a proto-dependency list.
16061 Parameters |t0| and |t1| are the list types before and after;
16062 they should agree unless |t0=mp_dependent| and |t1=mp_proto_dependent|
16063 and |v_is_scaled=true|.
16066 static mp_value_node mp_p_times_v (MP mp, mp_value_node p, mp_number v,
16067 quarterword t0, quarterword t1,
16068 boolean v_is_scaled) {
16069 mp_value_node r, s; /* for list manipulation */
16070 mp_number w; /* tentative coefficient */
16071 mp_number threshold;
16072 boolean scaling_down;
16073 new_number (threshold);
16076 scaling_down = true;
16078 scaling_down = (!v_is_scaled);
16079 if (t1 == mp_dependent)
16080 number_clone (threshold, half_fraction_threshold_k);
16082 number_clone (threshold, half_scaled_threshold_k);
16083 r = (mp_value_node) mp->temp_head;
16084 while (dep_info (p) != NULL) {
16087 if (scaling_down) {
16088 take_fraction (w, v, dep_value (p));
16090 take_scaled (w, v, dep_value (p));
16092 number_clone (test, w);
16094 if (number_lessequal (test, threshold)) {
16095 s = (mp_value_node) mp_link (p);
16096 mp_free_dep_node (mp, p);
16099 if (number_greaterequal(test, coef_bound_k)) {
16100 mp->fix_needed = true;
16101 mp_type (dep_info (p)) = independent_needing_fix;
16103 set_mp_link (r, (mp_node) p);
16105 set_dep_value (p, w);
16106 p = (mp_value_node) mp_link (p);
16108 free_number (test);
16110 set_mp_link (r, (mp_node) p);
16115 take_scaled (r1, dep_value (p), v);
16117 take_fraction (r1, dep_value (p), v);
16119 set_dep_value (p, r1);
16123 free_number (threshold);
16124 return (mp_value_node) mp_link (mp->temp_head);
16128 @ Similarly, we sometimes need to divide a dependency list
16129 by a given |scaled| constant.
16132 static mp_value_node mp_p_over_v (MP mp, mp_value_node p, mp_number v, quarterword
16133 t0, quarterword t1);
16136 @d p_over_v_threshold_k ((math_data *)mp->math)->p_over_v_threshold_t
16139 mp_value_node mp_p_over_v (MP mp, mp_value_node p, mp_number v_orig, quarterword
16140 t0, quarterword t1) {
16141 mp_value_node r, s; /* for list manipulation */
16142 mp_number w; /* tentative coefficient */
16143 mp_number threshold;
16145 boolean scaling_down;
16148 new_number (threshold);
16149 number_clone (v, v_orig);
16151 scaling_down = true;
16153 scaling_down = false;
16154 if (t1 == mp_dependent)
16155 number_clone (threshold, half_fraction_threshold_k);
16157 number_clone (threshold, half_scaled_threshold_k);
16158 r = (mp_value_node) mp->temp_head;
16159 while (dep_info (p) != NULL) {
16160 if (scaling_down) {
16164 number_clone (absv, v);
16166 if (number_less (absv, p_over_v_threshold_k)) {
16167 number_clone (x, v);
16168 convert_scaled_to_fraction (x);
16169 make_scaled (w, dep_value (p), x);
16171 number_clone (x, dep_value (p));
16172 fraction_to_round_scaled (x);
16173 make_scaled (w, x, v);
16176 free_number (absv);
16178 make_scaled (w, dep_value (p), v);
16183 number_clone (test, w);
16185 if (number_lessequal (test, threshold)) {
16186 s = (mp_value_node) mp_link (p);
16187 mp_free_dep_node (mp, p);
16190 if (number_greaterequal (test, coef_bound_k)) {
16191 mp->fix_needed = true;
16192 mp_type (dep_info (p)) = independent_needing_fix;
16194 set_mp_link (r, (mp_node) p);
16196 set_dep_value (p, w);
16197 p = (mp_value_node) mp_link (p);
16199 free_number (test);
16202 set_mp_link (r, (mp_node) p);
16206 make_scaled (ret, dep_value (p), v);
16207 set_dep_value (p, ret);
16212 free_number (threshold);
16213 return (mp_value_node) mp_link (mp->temp_head);
16217 @ Here's another utility routine for dependency lists. When an independent
16218 variable becomes dependent, we want to remove it from all existing
16219 dependencies. The |p_with_x_becoming_q| function computes the
16220 dependency list of~|p| after variable~|x| has been replaced by~|q|.
16222 This procedure has basically the same calling conventions as |p_plus_fq|:
16223 List~|q| is unchanged; list~|p| is destroyed; the constant node and the
16224 final link are inherited from~|p|; and the fourth parameter tells whether
16225 or not |p| is |mp_proto_dependent|. However, the global variable |dep_final|
16226 is not altered if |x| does not occur in list~|p|.
16229 static mp_value_node mp_p_with_x_becoming_q (MP mp, mp_value_node p,
16230 mp_node x, mp_node q,
16232 mp_value_node r, s; /* for list manipulation */
16233 integer sx; /* serial number of |x| */
16235 r = (mp_value_node) mp->temp_head;
16236 sx = indep_value (x);
16237 while (dep_info (s) != NULL && indep_value (dep_info (s)) > sx) {
16239 s = (mp_value_node) mp_link (s);
16241 if (dep_info (s) == NULL || dep_info (s) != x) {
16247 set_mp_link (mp->temp_head, (mp_node) p);
16248 set_mp_link (r, mp_link (s));
16249 number_clone (v1, dep_value (s));
16250 mp_free_dep_node (mp, s);
16251 ret = mp_p_plus_fq (mp, (mp_value_node) mp_link (mp->temp_head), v1,
16252 (mp_value_node) q, t, mp_dependent);
16259 @ Here's a simple procedure that reports an error when a variable
16260 has just received a known value that's out of the required range.
16263 static void mp_val_too_big (MP mp, mp_number x);
16266 static void mp_val_too_big (MP mp, mp_number x) {
16267 if (number_positive (internal_value (mp_warning_check))) {
16269 const char *hlp[] = {
16270 "The equation I just processed has given some variable a",
16271 "value outside of the safetyp range. Continue and I'll try",
16272 "to cope with that big value; but it might be dangerous.",
16273 "(Set warningcheck:=0 to suppress this message.)",
16275 mp_snprintf (msg, 256, "Value is too large (%s)", number_tostring(x));
16276 mp_error (mp, msg, hlp, true);
16280 @ When a dependent variable becomes known, the following routine
16281 removes its dependency list. Here |p| points to the variable, and
16282 |q| points to the dependency list (which is one node long).
16285 static void mp_make_known (MP mp, mp_value_node p, mp_value_node q);
16288 void mp_make_known (MP mp, mp_value_node p, mp_value_node q) {
16289 mp_variable_type t; /* the previous type */
16292 set_prev_dep (mp_link (q), prev_dep (p));
16293 set_mp_link (prev_dep (p), mp_link (q));
16295 mp_type (p) = mp_known;
16296 set_value_number (p, dep_value (q));
16297 mp_free_dep_node (mp, q);
16298 number_clone (absp, value_number (p));
16300 if (number_greaterequal (absp, warning_limit_t))
16301 mp_val_too_big (mp, value_number (p));
16302 if ((number_positive(internal_value (mp_tracing_equations)))
16303 && mp_interesting (mp, (mp_node) p)) {
16304 mp_begin_diagnostic (mp);
16305 mp_print_nl (mp, "#### ");
16306 mp_print_variable_name (mp, (mp_node) p);
16307 mp_print_char (mp, xord ('='));
16308 print_number (value_number (p));
16309 mp_end_diagnostic (mp, false);
16311 if (cur_exp_node () == (mp_node) p && mp->cur_exp.type == t) {
16312 mp->cur_exp.type = mp_known;
16313 set_cur_exp_value_number (value_number (p));
16314 mp_free_value_node (mp, (mp_node) p);
16316 free_number (absp);
16320 @ The |fix_dependencies| routine is called into action when |fix_needed|
16321 has been triggered. The program keeps a list~|s| of independent variables
16322 whose coefficients must be divided by~4.
16324 In unusual cases, this fixup process might reduce one or more coefficients
16325 to zero, so that a variable will become known more or less by default.
16328 static void mp_fix_dependencies (MP mp);
16331 @d independent_being_fixed 1 /* this variable already appears in |s| */
16333 static void mp_fix_dependencies (MP mp) {
16334 mp_value_node p, q, r, s, t; /* list manipulation registers */
16335 mp_node x; /* an independent variable */
16336 r = (mp_value_node) mp_link (mp->dep_head);
16338 while (r != mp->dep_head) {
16340 /* Run through the dependency list for variable |t|, fixing
16341 all nodes, and ending with final link~|q| */
16344 q = (mp_value_node) dep_list(t);
16346 q = (mp_value_node) mp_link (r);
16351 if (mp_type (x) <= independent_being_fixed) {
16352 if (mp_type (x) < independent_being_fixed) {
16353 p = mp_get_dep_node (mp);
16354 set_mp_link (p, (mp_node) s);
16356 set_dep_info (s, x);
16357 mp_type (x) = independent_being_fixed;
16359 set_dep_value (q, dep_value (q));
16360 number_divide_int (dep_value (q), 4);
16361 if (number_zero(dep_value (q))) {
16362 set_mp_link (r, mp_link (q));
16363 mp_free_dep_node (mp, q);
16370 r = (mp_value_node) mp_link (q);
16371 if (q == (mp_value_node) dep_list (t))
16372 mp_make_known (mp, t, q);
16374 while (s != NULL) {
16375 p = (mp_value_node) mp_link (s);
16377 mp_free_dep_node (mp, s);
16379 mp_type (x) = mp_independent;
16380 set_indep_scale (x, indep_scale (x) + 2);
16382 mp->fix_needed = false;
16386 @ The |new_dep| routine installs a dependency list~|p| based on the value node~|q|,
16387 linking it into the list of all known dependencies. It replaces |q| with the new
16388 dependency node. We assume that |dep_final| points to the final node of list~|p|.
16391 static void mp_new_dep (MP mp, mp_node q, mp_variable_type newtype,
16393 mp_node r; /* what used to be the first dependency */
16394 FUNCTION_TRACE4 ("mp_new_dep(%p,%d,%p)\n", q, newtype, p);
16395 mp_type (q) = newtype;
16396 set_dep_list (q, p);
16397 set_prev_dep (q, (mp_node) mp->dep_head);
16398 r = mp_link (mp->dep_head);
16399 set_mp_link (mp->dep_final, r);
16400 set_prev_dep (r, (mp_node) mp->dep_final);
16401 set_mp_link (mp->dep_head, q);
16405 @ Here is one of the ways a dependency list gets started.
16406 The |const_dependency| routine produces a list that has nothing but
16410 static mp_value_node mp_const_dependency (MP mp, mp_number v) {
16411 mp->dep_final = mp_get_dep_node (mp);
16412 set_dep_value (mp->dep_final, v);
16413 set_dep_info (mp->dep_final, NULL);
16414 FUNCTION_TRACE3 ("%p = mp_const_dependency(%d)\n", mp->dep_final, number_to_scaled (v));
16415 return mp->dep_final;
16419 @ And here's a more interesting way to start a dependency list from scratch:
16420 The parameter to |single_dependency| is the location of an
16421 independent variable~|x|, and the result is the simple dependency list
16424 In the unlikely event that the given independent variable has been doubled so
16425 often that we can't refer to it with a nonzero coefficient,
16426 |single_dependency| returns the simple list `0'. This case can be
16427 recognized by testing that the returned list pointer is equal to
16430 @d two_to_the(A) (1<<(unsigned)(A))
16433 static mp_value_node mp_single_dependency (MP mp, mp_node p) {
16434 mp_value_node q, rr; /* the new dependency list */
16435 integer m; /* the number of doublings */
16436 m = indep_scale (p);
16438 q = mp_const_dependency (mp, zero_t);
16440 q = mp_get_dep_node (mp);
16441 set_dep_value (q, zero_t);
16442 set_number_from_scaled (dep_value (q), (integer) two_to_the (28 - m));
16443 set_dep_info (q, p);
16444 rr = mp_const_dependency (mp, zero_t);
16445 set_mp_link (q, (mp_node) rr);
16447 FUNCTION_TRACE3 ("%p = mp_single_dependency(%p)\n", q, p);
16452 @ We sometimes need to make an exact copy of a dependency list.
16455 static mp_value_node mp_copy_dep_list (MP mp, mp_value_node p) {
16456 mp_value_node q; /* the new dependency list */
16457 FUNCTION_TRACE2 ("mp_copy_dep_list(%p)\n", p);
16458 q = mp_get_dep_node (mp);
16461 set_dep_info (mp->dep_final, dep_info (p));
16462 set_dep_value (mp->dep_final, dep_value (p));
16463 if (dep_info (mp->dep_final) == NULL)
16465 set_mp_link (mp->dep_final, (mp_node) mp_get_dep_node (mp));
16466 mp->dep_final = (mp_value_node) mp_link (mp->dep_final);
16467 p = (mp_value_node) mp_link (p);
16473 @ But how do variables normally become known? Ah, now we get to the heart of the
16474 equation-solving mechanism. The |linear_eq| procedure is given a |dependent|
16475 or |mp_proto_dependent| list,~|p|, in which at least one independent variable
16476 appears. It equates this list to zero, by choosing an independent variable
16477 with the largest coefficient and making it dependent on the others. The
16478 newly dependent variable is eliminated from all current dependencies,
16479 thereby possibly making other dependent variables known.
16481 The given list |p| is, of course, totally destroyed by all this processing.
16484 static mp_value_node find_node_with_largest_coefficient(MP mp, mp_value_node p, mp_number *v);
16485 static void display_new_dependency (MP mp, mp_value_node p, mp_node x, integer n);
16486 static void change_to_known (MP mp, mp_value_node p, mp_node x, mp_value_node final_node, integer n);
16487 static mp_value_node divide_p_by_minusv_removing_q (MP mp, mp_value_node p, mp_value_node q,
16488 mp_value_node *final_node, mp_number v, quarterword t);
16489 static mp_value_node divide_p_by_2_n (MP mp, mp_value_node p, integer n);
16490 static void mp_linear_eq (MP mp, mp_value_node p, quarterword t) {
16491 mp_value_node r; /* for link manipulation */
16492 mp_node x; /* the variable that loses its independence */
16493 integer n; /* the number of times |x| had been halved */
16494 mp_number v; /* the coefficient of |x| in list |p| */
16495 mp_value_node prev_r; /* lags one step behind |r| */
16496 mp_value_node final_node; /* the constant term of the new dependency list */
16499 FUNCTION_TRACE3 ("mp_linear_eq(%p,%d)\n", p, t);
16500 qq = find_node_with_largest_coefficient(mp, p, &v);
16502 n = indep_scale (x);
16503 p = divide_p_by_minusv_removing_q(mp, p, qq, &final_node, v, t);
16504 if (number_positive (internal_value (mp_tracing_equations))) {
16505 display_new_dependency(mp,p,(mp_node)x,n);
16507 prev_r = (mp_value_node) mp->dep_head;
16508 r = (mp_value_node) mp_link (mp->dep_head);
16509 while (r != mp->dep_head) {
16510 mp_value_node s = (mp_value_node) dep_list (r);
16511 mp_value_node q = mp_p_with_x_becoming_q (mp, s, x, (mp_node) p, mp_type (r));
16512 if (dep_info (q) == NULL) {
16513 mp_make_known (mp, r, q);
16515 set_dep_list (r, q);
16517 q = (mp_value_node) mp_link (q);
16518 } while (dep_info (q) != NULL);
16521 r = (mp_value_node) mp_link (prev_r);
16524 p = divide_p_by_2_n(mp, p, n);
16526 change_to_known(mp,p,(mp_node)x,final_node,n);
16527 if (mp->fix_needed)
16528 mp_fix_dependencies (mp);
16535 static mp_value_node find_node_with_largest_coefficient(MP mp, mp_value_node p, mp_number *v) {
16536 mp_number vabs; /* its absolute value of v*/
16537 mp_number rabs; /* the absolute value of |dep_value(r)| */
16538 mp_value_node q = p;
16539 mp_value_node r = (mp_value_node) mp_link (p);
16542 number_clone (*v, dep_value (q));
16543 while (dep_info (r) != NULL) {
16544 number_clone (vabs, *v);
16546 number_clone (rabs, dep_value (r));
16548 if (number_greater (rabs, vabs)) {
16550 number_clone (*v, dep_value (r));
16552 r = (mp_value_node) mp_link (r);
16554 free_number (vabs);
16555 free_number (rabs);
16560 @ Here we want to change the coefficients from |scaled| to |fraction|,
16561 except in the constant term. In the common case of a trivial equation
16562 like `\.{x=3.14}', we will have |v=-fraction_one|, |q=p|, and |t=mp_dependent|.
16565 static mp_value_node divide_p_by_minusv_removing_q (MP mp, mp_value_node p, mp_value_node q,
16566 mp_value_node *final_node, mp_number v, quarterword t) {
16567 mp_value_node r; /* for link manipulation */
16569 s = (mp_value_node) mp->temp_head;
16570 set_mp_link (s, (mp_node) p);
16574 set_mp_link (s, mp_link (r));
16575 mp_free_dep_node (mp, r);
16577 mp_number w; /* a tentative coefficient */
16581 make_fraction (w, dep_value (r), v);
16582 number_clone (absw, w);
16584 if (number_lessequal (absw, half_fraction_threshold_k)) {
16585 set_mp_link (s, mp_link (r));
16586 mp_free_dep_node (mp, r);
16589 set_dep_value (r, w);
16593 free_number (absw);
16595 r = (mp_value_node) mp_link (s);
16596 } while (dep_info (r) != NULL);
16598 if (t == mp_proto_dependent) {
16601 make_scaled (ret, dep_value (r), v);
16602 number_negate (ret);
16603 set_dep_value (r, ret);
16605 } else if (number_to_scaled (v) != -number_to_scaled (fraction_one_t)) {
16607 new_fraction (ret);
16608 make_fraction (ret, dep_value (r), v);
16609 number_negate (ret);
16610 set_dep_value (r, ret);
16614 return (mp_value_node) mp_link (mp->temp_head);
16620 static void display_new_dependency (MP mp, mp_value_node p, mp_node x, integer n) {
16621 if (mp_interesting (mp, x)) {
16623 mp_begin_diagnostic (mp);
16624 mp_print_nl (mp, "## ");
16625 mp_print_variable_name (mp, x);
16628 mp_print (mp, "*4");
16631 mp_print_char (mp, xord ('='));
16632 mp_print_dependency (mp, p, mp_dependent);
16633 mp_end_diagnostic (mp, false);
16637 @ The |n > 0| test is repeated here because it is of vital importance to the
16638 function's functioning.
16641 static mp_value_node divide_p_by_2_n (MP mp, mp_value_node p, integer n) {
16642 mp_value_node pp = NULL;
16644 /* Divide list |p| by $2^n$ */
16648 mp_number w; /* a tentative coefficient */
16651 s = (mp_value_node) mp->temp_head;
16652 set_mp_link (mp->temp_head, (mp_node) p);
16656 set_number_to_zero (w);
16658 number_clone (w, dep_value (r));
16659 number_divide_int (w, two_to_the (n));
16661 number_clone (absw, w);
16663 if (number_lessequal(absw, half_fraction_threshold_k) && (dep_info (r) != NULL)) {
16664 set_mp_link (s, mp_link (r));
16665 mp_free_dep_node (mp, r);
16667 set_dep_value (r, w);
16670 r = (mp_value_node) mp_link (s);
16671 } while (dep_info (s) != NULL);
16672 pp = (mp_value_node) mp_link (mp->temp_head);
16673 free_number (absw);
16681 static void change_to_known (MP mp, mp_value_node p, mp_node x, mp_value_node final_node, integer n) {
16682 if (dep_info (p) == NULL) {
16685 mp_type (x) = mp_known;
16686 set_value_number (x, dep_value (p));
16687 number_clone (absx, value_number (x));
16689 if (number_greaterequal (absx, warning_limit_t))
16690 mp_val_too_big (mp, value_number (x));
16691 free_number (absx);
16692 mp_free_dep_node (mp, p);
16693 if (cur_exp_node () == x && mp->cur_exp.type == mp_independent) {
16694 set_cur_exp_value_number (value_number (x));
16695 mp->cur_exp.type = mp_known;
16696 mp_free_value_node (mp, x);
16699 mp->dep_final = final_node;
16700 mp_new_dep (mp, x, mp_dependent, p);
16701 if (cur_exp_node () == x && mp->cur_exp.type == mp_independent) {
16702 mp->cur_exp.type = mp_dependent;
16707 @* Dynamic nonlinear equations.
16708 Variables of numeric type are maintained by the general scheme of
16709 independent, dependent, and known values that we have just studied;
16710 and the components of pair and transform variables are handled in the
16711 same way. But \MP\ also has five other types of values: \&{boolean},
16712 \&{string}, \&{pen}, \&{path}, and \&{picture}; what about them?
16714 Equations are allowed between nonlinear quantities, but only in a
16715 simple form. Two variables that haven't yet been assigned values are
16716 either equal to each other, or they're not.
16718 Before a boolean variable has received a value, its type is |mp_unknown_boolean|;
16719 similarly, there are variables whose type is |mp_unknown_string|, |mp_unknown_pen|,
16720 |mp_unknown_path|, and |mp_unknown_picture|. In such cases the value is either
16721 |NULL| (which means that no other variables are equivalent to this one), or
16722 it points to another variable of the same undefined type. The pointers in the
16723 latter case form a cycle of nodes, which we shall call a ``ring.''
16724 Rings of undefined variables may include capsules, which arise as
16725 intermediate results within expressions or as \&{expr} parameters to macros.
16727 When one member of a ring receives a value, the same value is given to
16728 all the other members. In the case of paths and pictures, this implies
16729 making separate copies of a potentially large data structure; users should
16730 restrain their enthusiasm for such generality, unless they have lots and
16731 lots of memory space.
16733 @ The following procedure is called when a capsule node is being
16734 added to a ring (e.g., when an unknown variable is mentioned in an expression).
16737 static mp_node mp_new_ring_entry (MP mp, mp_node p) {
16738 mp_node q; /* the new capsule node */
16739 q = mp_get_value_node (mp);
16740 mp_name_type (q) = mp_capsule;
16741 mp_type (q) = mp_type (p);
16742 if (value_node (p) == NULL)
16743 set_value_node (q, p);
16745 set_value_node (q, value_node (p));
16746 set_value_node (p, q);
16751 @ Conversely, we might delete a capsule or a variable before it becomes known.
16752 The following procedure simply detaches a quantity from its ring,
16753 without recycling the storage.
16756 static void mp_ring_delete (MP mp, mp_node p);
16759 void mp_ring_delete (MP mp, mp_node p) {
16762 q = value_node (p);
16763 if (q != NULL && q != p) {
16764 while (value_node (q) != p)
16765 q = value_node (q);
16766 set_value_node (q, value_node (p));
16771 @ Eventually there might be an equation that assigns values to all of the
16772 variables in a ring. The |nonlinear_eq| subroutine does the necessary
16773 propagation of values.
16775 If the parameter |flush_p| is |true|, node |p| itself needn't receive a
16776 value, it will soon be recycled.
16779 static void mp_nonlinear_eq (MP mp, mp_value v, mp_node p, boolean flush_p) {
16780 mp_variable_type t; /* the type of ring |p| */
16781 mp_node q, r; /* link manipulation registers */
16782 t = (mp_type (p) - unknown_tag);
16783 q = value_node (p);
16785 mp_type (p) = mp_vacuous;
16789 r = value_node (q);
16792 case mp_boolean_type:
16793 set_value_number (q, v.data.n);
16795 case mp_string_type:
16796 set_value_str (q, v.data.str);
16797 add_str_ref (v.data.str);
16800 set_value_knot (q, copy_pen (v.data.p));
16803 set_value_knot (q, mp_copy_path (mp, v.data.p));
16805 case mp_picture_type:
16806 set_value_node (q, v.data.node);
16807 add_edge_ref (v.data.node);
16811 } /* there ain't no more cases */
16817 @ If two members of rings are equated, and if they have the same type,
16818 the |ring_merge| procedure is called on to make them equivalent.
16821 static void mp_ring_merge (MP mp, mp_node p, mp_node q) {
16822 mp_node r; /* traverses one list */
16823 r = value_node (p);
16826 exclaim_redundant_equation(mp);
16829 r = value_node (r);
16831 r = value_node (p);
16832 set_value_node (p, value_node (q));
16833 set_value_node (q, r);
16838 static void exclaim_redundant_equation (MP mp) {
16839 const char *hlp[] = {
16840 "I already knew that this equation was true.",
16841 "But perhaps no harm has been done; let's continue.",
16843 mp_back_error (mp, "Redundant equation", hlp, true);
16844 mp_get_x_next (mp);
16847 @ @<Declarations@>=
16848 static void exclaim_redundant_equation (MP mp);
16850 @* Introduction to the syntactic routines.
16851 Let's pause a moment now and try to look at the Big Picture.
16852 The \MP\ program consists of three main parts: syntactic routines,
16853 semantic routines, and output routines. The chief purpose of the
16854 syntactic routines is to deliver the user's input to the semantic routines,
16855 while parsing expressions and locating operators and operands. The
16856 semantic routines act as an interpreter responding to these operators,
16857 which may be regarded as commands. And the output routines are
16858 periodically called on to produce compact font descriptions that can be
16859 used for typesetting or for making interim proof drawings. We have
16860 discussed the basic data structures and many of the details of semantic
16861 operations, so we are good and ready to plunge into the part of \MP\ that
16862 actually controls the activities.
16864 Our current goal is to come to grips with the |get_next| procedure,
16865 which is the keystone of \MP's input mechanism. Each call of |get_next|
16866 sets the value of three variables |cur_cmd|, |cur_mod|, and |cur_sym|,
16867 representing the next input token.
16868 $$\vbox{\halign{#\hfil\cr
16869 \hbox{|cur_cmd| denotes a command code from the long list of codes
16871 \hbox{|cur_mod| denotes a modifier or operand of the command code;}\cr
16872 \hbox{|cur_sym| is the hash address of the symbolic token that was
16874 \hbox{\qquad or zero in the case of a numeric or string
16875 or capsule token.}\cr}}$$
16876 Underlying this external behavior of |get_next| is all the machinery
16877 necessary to convert from character files to tokens. At a given time we
16878 may be only partially finished with the reading of several files (for
16879 which \&{input} was specified), and partially finished with the expansion
16880 of some user-defined macros and/or some macro parameters, and partially
16881 finished reading some text that the user has inserted online,
16882 and so on. When reading a character file, the characters must be
16883 converted to tokens; comments and blank spaces must
16884 be removed, numeric and string tokens must be evaluated.
16886 To handle these situations, which might all be present simultaneously,
16887 \MP\ uses various stacks that hold information about the incomplete
16888 activities, and there is a finite state control for each level of the
16889 input mechanism. These stacks record the current state of an implicitly
16890 recursive process, but the |get_next| procedure is not recursive.
16892 @d cur_cmd() (unsigned)(mp->cur_mod_->type)
16893 @d set_cur_cmd(A) mp->cur_mod_->type=(A)
16894 @d cur_mod_int() number_to_int (mp->cur_mod_->data.n) /* operand of current command */
16895 @d cur_mod() number_to_scaled (mp->cur_mod_->data.n) /* operand of current command */
16896 @d cur_mod_number() mp->cur_mod_->data.n /* operand of current command */
16897 @d set_cur_mod(A) set_number_from_scaled (mp->cur_mod_->data.n, (A))
16898 @d set_cur_mod_number(A) number_clone (mp->cur_mod_->data.n, (A))
16899 @d cur_mod_node() mp->cur_mod_->data.node
16900 @d set_cur_mod_node(A) mp->cur_mod_->data.node=(A)
16901 @d cur_mod_str() mp->cur_mod_->data.str
16902 @d set_cur_mod_str(A) mp->cur_mod_->data.str=(A)
16903 @d cur_sym() mp->cur_mod_->data.sym
16904 @d set_cur_sym(A) mp->cur_mod_->data.sym=(A)
16905 @d cur_sym_mod() mp->cur_mod_->name_type
16906 @d set_cur_sym_mod(A) mp->cur_mod_->name_type=(A)
16909 mp_node cur_mod_; /* current command, symbol, and its operands */
16911 @ @<Initialize table...@>=
16912 mp->cur_mod_ = mp_get_symbolic_node(mp);
16914 @ @<Free table...@>=
16915 mp_free_symbolic_node(mp, mp->cur_mod_);
16917 @ The |print_cmd_mod| routine prints a symbolic interpretation of a
16918 command code and its modifier.
16919 It consists of a rather tedious sequence of print
16920 commands, and most of it is essentially an inverse to the |primitive|
16921 routine that enters a \MP\ primitive into |hash| and |eqtb|. Therefore almost
16922 all of this procedure appears elsewhere in the program, together with the
16923 corresponding |primitive| calls.
16926 static void mp_print_cmd_mod (MP mp, integer c, integer m);
16929 void mp_print_cmd_mod (MP mp, integer c, integer m) {
16931 @<Cases of |print_cmd_mod| for symbolic printing of primitives@>
16933 mp_print (mp, "[unknown command code!]");
16939 @ Here is a procedure that displays a given command in braces, in the
16940 user's transcript file.
16942 @d show_cur_cmd_mod mp_show_cmd_mod(mp, cur_cmd(),cur_mod())
16945 static void mp_show_cmd_mod (MP mp, integer c, integer m) {
16946 mp_begin_diagnostic (mp);
16947 mp_print_nl (mp, "{");
16948 mp_print_cmd_mod (mp, c, m);
16949 mp_print_char (mp, xord ('}'));
16950 mp_end_diagnostic (mp, false);
16954 @* Input stacks and states.
16955 The state of \MP's input mechanism appears in the input stack, whose
16956 entries are records with five fields, called |index|, |start|, |loc|,
16957 |limit|, and |name|. The top element of this stack is maintained in a
16958 global variable for which no subscripting needs to be done; the other
16959 elements of the stack appear in an array. Hence the stack is declared thus:
16963 char *long_name_field;
16964 halfword start_field, loc_field, limit_field;
16965 mp_node nstart_field, nloc_field;
16966 mp_string name_field;
16967 quarterword index_field;
16971 in_state_record *input_stack;
16972 integer input_ptr; /* first unused location of |input_stack| */
16973 integer max_in_stack; /* largest value of |input_ptr| when pushing */
16974 in_state_record cur_input; /* the ``top'' input state */
16975 int stack_size; /* maximum number of simultaneous input sources */
16977 @ @<Allocate or initialize ...@>=
16978 mp->stack_size = 16;
16979 mp->input_stack = xmalloc ((mp->stack_size + 1), sizeof (in_state_record));
16981 @ @<Dealloc variables@>=
16982 xfree (mp->input_stack);
16984 @ We've already defined the special variable |loc==cur_input.loc_field|
16985 in our discussion of basic input-output routines. The other components of
16986 |cur_input| are defined in the same way:
16988 @d iindex mp->cur_input.index_field /* reference for buffer information */
16989 @d start mp->cur_input.start_field /* starting position in |buffer| */
16990 @d limit mp->cur_input.limit_field /* end of current line in |buffer| */
16991 @d name mp->cur_input.name_field /* name of the current file */
16993 @ Let's look more closely now at the five control variables
16994 (|index|,~|start|,~|loc|,~|limit|,~|name|),
16995 assuming that \MP\ is reading a line of characters that have been input
16996 from some file or from the user's terminal. There is an array called
16997 |buffer| that acts as a stack of all lines of characters that are
16998 currently being read from files, including all lines on subsidiary
16999 levels of the input stack that are not yet completed. \MP\ will return to
17000 the other lines when it is finished with the present input file.
17002 (Incidentally, on a machine with byte-oriented addressing, it would be
17003 appropriate to combine |buffer| with the |str_pool| array,
17004 letting the buffer entries grow downward from the top of the string pool
17005 and checking that these two tables don't bump into each other.)
17007 The line we are currently working on begins in position |start| of the
17008 buffer; the next character we are about to read is |buffer[loc]|; and
17009 |limit| is the location of the last character present. We always have
17010 |loc<=limit|. For convenience, |buffer[limit]| has been set to |"%"|, so
17011 that the end of a line is easily sensed.
17013 The |name| variable is a string number that designates the name of
17014 the current file, if we are reading an ordinary text file. Special codes
17015 |is_term..max_spec_src| indicate other sources of input text.
17017 @d is_term (mp_string)0 /* |name| value when reading from the terminal for normal input */
17018 @d is_read (mp_string)1 /* |name| value when executing a \&{readstring} or \&{readfrom} */
17019 @d is_scantok (mp_string)2 /* |name| value when reading text generated by \&{scantokens} */
17020 @d max_spec_src is_scantok
17022 @ Additional information about the current line is available via the
17023 |index| variable, which counts how many lines of characters are present
17024 in the buffer below the current level. We have |index=0| when reading
17025 from the terminal and prompting the user for each line; then if the user types,
17026 e.g., `\.{input figs}', we will have |index=1| while reading
17027 the file \.{figs.mp}. However, it does not follow that |index| is the
17028 same as the input stack pointer, since many of the levels on the input
17029 stack may come from token lists and some |index| values may correspond
17030 to \.{MPX} files that are not currently on the stack.
17032 The global variable |in_open| is equal to the highest |index| value counting
17033 \.{MPX} files but excluding token-list input levels. Thus, the number of
17034 partially read lines in the buffer is |in_open+1| and we have |in_open>=index|
17035 when we are not reading a token list.
17037 If we are not currently reading from the terminal,
17038 we are reading from the file variable |input_file[index]|. We use
17039 the notation |terminal_input| as a convenient abbreviation for |name=is_term|,
17040 and |cur_file| as an abbreviation for |input_file[index]|.
17042 When \MP\ is not reading from the terminal, the global variable |line| contains
17043 the line number in the current file, for use in error messages. More precisely,
17044 |line| is a macro for |line_stack[index]| and the |line_stack| array gives
17045 the line number for each file in the |input_file| array.
17047 When an \.{MPX} file is opened the file name is stored in the |mpx_name|
17048 array so that the name doesn't get lost when the file is temporarily removed
17049 from the input stack.
17050 Thus when |input_file[k]| is an \.{MPX} file, its name is |mpx_name[k]|
17051 and it contains translated \TeX\ pictures for |input_file[k-1]|.
17052 Since this is not an \.{MPX} file, we have
17053 $$ \hbox{|mpx_name[k-1]<=absent|}. $$
17054 This |name| field is set to |finished| when |input_file[k]| is completely
17057 If more information about the input state is needed, it can be
17058 included in small arrays like those shown here. For example,
17059 the current page or segment number in the input file might be put
17060 into a variable |page|, that is really a macro for the current entry
17061 in `\ignorespaces|page_stack:array[0..max_in_open] of integer|\unskip'
17062 by analogy with |line_stack|.
17063 @^system dependencies@>
17065 @d terminal_input (name==is_term) /* are we reading from the terminal? */
17066 @d cur_file mp->input_file[iindex] /* the current |void *| variable */
17067 @d line mp->line_stack[iindex] /* current line number in the current source file */
17068 @d in_ext mp->inext_stack[iindex] /* a string used to construct \.{MPX} file names */
17069 @d in_name mp->iname_stack[iindex] /* a string used to construct \.{MPX} file names */
17070 @d in_area mp->iarea_stack[iindex] /* another string for naming \.{MPX} files */
17071 @d absent (mp_string)1 /* |name_field| value for unused |mpx_in_stack| entries */
17072 @d mpx_reading (mp->mpx_name[iindex]>absent)
17073 /* when reading a file, is it an \.{MPX} file? */
17075 /* |name_field| value when the corresponding \.{MPX} file is finished */
17078 integer in_open; /* the number of lines in the buffer, less one */
17079 integer in_open_max; /* highest value of |in_open| ever seen */
17080 unsigned int open_parens; /* the number of open text files */
17082 integer *line_stack; /* the line number for each file */
17083 char **inext_stack; /* used for naming \.{MPX} files */
17084 char **iname_stack; /* used for naming \.{MPX} files */
17085 char **iarea_stack; /* used for naming \.{MPX} files */
17086 mp_string *mpx_name;
17088 @ @<Declarations@>=
17089 static void mp_reallocate_input_stack (MP mp, int newsize);
17092 static void mp_reallocate_input_stack (MP mp, int newsize) {
17094 int n = newsize +1;
17095 XREALLOC (mp->input_file, n, void *);
17096 XREALLOC (mp->line_stack, n, integer);
17097 XREALLOC (mp->inext_stack, n, char *);
17098 XREALLOC (mp->iname_stack, n, char *);
17099 XREALLOC (mp->iarea_stack, n, char *);
17100 XREALLOC (mp->mpx_name, n, mp_string);
17101 for (k = mp->max_in_open; k <= n; k++) {
17102 mp->input_file[k] = NULL;
17103 mp->line_stack[k] = 0;
17104 mp->inext_stack[k] = NULL;
17105 mp->iname_stack[k] = NULL;
17106 mp->iarea_stack[k] = NULL;
17107 mp->mpx_name[k] = NULL;
17109 mp->max_in_open = newsize;
17113 @ This has to be more than |file_bottom|, so:
17114 @<Allocate or ...@>=
17115 mp_reallocate_input_stack (mp, file_bottom+4);
17117 @ @<Dealloc variables@>=
17120 for (l = 0; l <= mp->max_in_open; l++) {
17121 xfree (mp->inext_stack[l]);
17122 xfree (mp->iname_stack[l]);
17123 xfree (mp->iarea_stack[l]);
17126 xfree (mp->input_file);
17127 xfree (mp->line_stack);
17128 xfree (mp->inext_stack);
17129 xfree (mp->iname_stack);
17130 xfree (mp->iarea_stack);
17131 xfree (mp->mpx_name);
17134 @ However, all this discussion about input state really applies only to the
17135 case that we are inputting from a file. There is another important case,
17136 namely when we are currently getting input from a token list. In this case
17137 |iindex>max_in_open|, and the conventions about the other state variables
17140 \yskip\hang|nloc| is a pointer to the current node in the token list, i.e.,
17141 the node that will be read next. If |nloc=NULL|, the token list has been
17144 \yskip\hang|start| points to the first node of the token list; this node
17145 may or may not contain a reference count, depending on the type of token
17148 \yskip\hang|token_type|, which takes the place of |iindex| in the
17149 discussion above, is a code number that explains what kind of token list
17152 \yskip\hang|name| points to the |eqtb| address of the control sequence
17153 being expanded, if the current token list is a macro not defined by
17154 \&{vardef}. Macros defined by \&{vardef} have |name=NULL|; their name
17155 can be deduced by looking at their first two parameters.
17157 \yskip\hang|param_start|, which takes the place of |limit|, tells where
17158 the parameters of the current macro or loop text begin in the |param_stack|.
17160 \yskip\noindent The |token_type| can take several values, depending on
17161 where the current token list came from:
17164 \indent|forever_text|, if the token list being scanned is the body of
17165 a \&{forever} loop;
17167 \indent|loop_text|, if the token list being scanned is the body of
17168 a \&{for} or \&{forsuffixes} loop;
17170 \indent|parameter|, if a \&{text} or \&{suffix} parameter is being scanned;
17172 \indent|backed_up|, if the token list being scanned has been inserted as
17173 `to be read again'.
17175 \indent|inserted|, if the token list being scanned has been inserted as
17176 part of error recovery;
17178 \indent|macro|, if the expansion of a user-defined symbolic token is being
17182 The token list begins with a reference count if and only if |token_type=
17184 @^reference counts@>
17186 @d nloc mp->cur_input.nloc_field /* location of next node node */
17187 @d nstart mp->cur_input.nstart_field /* location of next node node */
17189 @d token_type iindex /* type of current token list */
17190 @d token_state (iindex<=macro) /* are we scanning a token list? */
17191 @d file_state (iindex>macro) /* are we scanning a file line? */
17192 @d param_start limit /* base of macro parameters in |param_stack| */
17193 @d forever_text 0 /* |token_type| code for loop texts */
17194 @d loop_text 1 /* |token_type| code for loop texts */
17195 @d parameter 2 /* |token_type| code for parameter texts */
17196 @d backed_up 3 /* |token_type| code for texts to be reread */
17197 @d inserted 4 /* |token_type| code for inserted texts */
17198 @d macro 5 /* |token_type| code for macro replacement texts */
17199 @d file_bottom 6 /* lowest file code */
17201 @ The |param_stack| is an auxiliary array used to hold pointers to the token
17202 lists for parameters at the current level and subsidiary levels of input.
17203 This stack grows at a different rate from the others, and is dynamically reallocated
17207 mp_node *param_stack; /* token list pointers for parameters */
17208 integer param_ptr; /* first unused entry in |param_stack| */
17209 integer max_param_stack; /* largest value of |param_ptr| */
17211 @ @<Allocate or initialize ...@>=
17212 mp->param_stack = xmalloc ((mp->param_size + 1), sizeof (mp_node));
17215 static void mp_check_param_size (MP mp, int k) {
17216 while (k >= mp->param_size) {
17217 XREALLOC (mp->param_stack, (k + k / 4), mp_node);
17218 mp->param_size = k + k / 4;
17223 @ @<Dealloc variables@>=
17224 xfree (mp->param_stack);
17226 @ Notice that the |line| isn't valid when |token_state| is true because it
17227 depends on |iindex|. If we really need to know the line number for the
17228 topmost file in the iindex stack we use the following function. If a page
17229 number or other information is needed, this routine should be modified to
17230 compute it as well.
17231 @^system dependencies@>
17234 static integer mp_true_line (MP mp);
17237 integer mp_true_line (MP mp) {
17238 int k; /* an index into the input stack */
17239 if (file_state && (name > max_spec_src)) {
17244 ((mp->input_stack[(k - 1)].index_field < file_bottom) ||
17245 (mp->input_stack[(k - 1)].name_field <= max_spec_src))) {
17248 return (k > 0 ? mp->line_stack[(k - 1) + file_bottom] : 0);
17253 @ Thus, the ``current input state'' can be very complicated indeed; there
17254 can be many levels and each level can arise in a variety of ways. The
17255 |show_context| procedure, which is used by \MP's error-reporting routine to
17256 print out the current input state on all levels down to the most recent
17257 line of characters from an input file, illustrates most of these conventions.
17258 The global variable |file_ptr| contains the lowest level that was
17259 displayed by this procedure.
17262 integer file_ptr; /* shallowest level shown by |show_context| */
17264 @ The status at each level is indicated by printing two lines, where the first
17265 line indicates what was read so far and the second line shows what remains
17266 to be read. The context is cropped, if necessary, so that the first line
17267 contains at most |half_error_line| characters, and the second contains
17268 at most |error_line|. Non-current input levels whose |token_type| is
17269 `|backed_up|' are shown only if they have not been fully read.
17272 void mp_show_context (MP mp) { /* prints where the scanner is */
17273 unsigned old_setting; /* saved |selector| setting */
17274 @<Local variables for formatting calculations@>;
17275 mp->file_ptr = mp->input_ptr;
17276 mp->input_stack[mp->file_ptr] = mp->cur_input;
17277 /* store current state */
17279 mp->cur_input = mp->input_stack[mp->file_ptr]; /* enter into the context */
17280 @<Display the current context@>;
17282 if ((name > max_spec_src) || (mp->file_ptr == 0))
17284 decr (mp->file_ptr);
17286 mp->cur_input = mp->input_stack[mp->input_ptr]; /* restore original state */
17290 @ @<Display the current context@>=
17291 if ((mp->file_ptr == mp->input_ptr) || file_state ||
17292 (token_type != backed_up) || (nloc != NULL)) {
17293 /* we omit backed-up token lists that have already been read */
17294 mp->tally = 0; /* get ready to count characters */
17295 old_setting = mp->selector;
17297 @<Print location of current line@>;
17298 @<Pseudoprint the line@>;
17300 @<Print type of token list@>;
17301 @<Pseudoprint the token list@>;
17303 mp->selector = old_setting; /* stop pseudoprinting */
17304 @<Print two lines using the tricky pseudoprinted information@>;
17307 @ This routine should be changed, if necessary, to give the best possible
17308 indication of where the current line resides in the input file.
17309 For example, on some systems it is best to print both a page and line number.
17310 @^system dependencies@>
17312 @<Print location of current line@>=
17313 if (name > max_spec_src) {
17314 mp_print_nl (mp, "l.");
17315 mp_print_int (mp, mp_true_line (mp));
17316 } else if (terminal_input) {
17317 if (mp->file_ptr == 0)
17318 mp_print_nl (mp, "<*>");
17320 mp_print_nl (mp, "<insert>");
17321 } else if (name == is_scantok) {
17322 mp_print_nl (mp, "<scantokens>");
17324 mp_print_nl (mp, "<read>");
17326 mp_print_char (mp, xord (' '))
17329 @ Can't use case statement here because the |token_type| is not
17330 a constant expression.
17332 @<Print type of token list@>=
17334 if (token_type == forever_text) {
17335 mp_print_nl (mp, "<forever> ");
17336 } else if (token_type == loop_text) {
17337 @<Print the current loop value@>;
17338 } else if (token_type == parameter) {
17339 mp_print_nl (mp, "<argument> ");
17340 } else if (token_type == backed_up) {
17342 mp_print_nl (mp, "<recently read> ");
17344 mp_print_nl (mp, "<to be read again> ");
17345 } else if (token_type == inserted) {
17346 mp_print_nl (mp, "<inserted text> ");
17347 } else if (token_type == macro) {
17350 mp_print_str (mp, name);
17352 @<Print the name of a \&{vardef}'d macro@>;
17353 mp_print (mp, "->");
17355 mp_print_nl (mp, "?"); /* this should never happen */
17361 @ The parameter that corresponds to a loop text is either a token list
17362 (in the case of \&{forsuffixes}) or a ``capsule'' (in the case of \&{for}).
17363 We'll discuss capsules later; for now, all we need to know is that
17364 the |link| field in a capsule parameter is |void| and that
17365 |print_exp(p,0)| displays the value of capsule~|p| in abbreviated form.
17367 @<Print the current loop value@>=
17370 mp_print_nl (mp, "<for(");
17371 pp = mp->param_stack[param_start];
17373 if (mp_link (pp) == MP_VOID)
17374 mp_print_exp (mp, pp, 0); /* we're in a \&{for} loop */
17376 mp_show_token_list (mp, pp, NULL, 20, mp->tally);
17378 mp_print (mp, ")> ");
17382 @ The first two parameters of a macro defined by \&{vardef} will be token
17383 lists representing the macro's prefix and ``at point.'' By putting these
17384 together, we get the macro's full name.
17386 @<Print the name of a \&{vardef}'d macro@>=
17388 mp_node pp = mp->param_stack[param_start];
17390 mp_show_token_list (mp, mp->param_stack[param_start + 1], NULL, 20,
17394 while (mp_link (qq) != NULL)
17396 mp_link (qq) = mp->param_stack[param_start + 1];
17397 mp_show_token_list (mp, pp, NULL, 20, mp->tally);
17398 mp_link (qq) = NULL;
17403 @ Now it is necessary to explain a little trick. We don't want to store a long
17404 string that corresponds to a token list, because that string might take up
17405 lots of memory; and we are printing during a time when an error message is
17406 being given, so we dare not do anything that might overflow one of \MP's
17407 tables. So `pseudoprinting' is the answer: We enter a mode of printing
17408 that stores characters into a buffer of length |error_line|, where character
17409 $k+1$ is placed into \hbox{|trick_buf[k mod error_line]|} if
17410 |k<trick_count|, otherwise character |k| is dropped. Initially we set
17411 |tally:=0| and |trick_count:=1000000|; then when we reach the
17412 point where transition from line 1 to line 2 should occur, we
17413 set |first_count:=tally| and |trick_count:=@tmax@>(error_line,
17414 tally+1+error_line-half_error_line)|. At the end of the
17415 pseudoprinting, the values of |first_count|, |tally|, and
17416 |trick_count| give us all the information we need to print the two lines,
17417 and all of the necessary text is in |trick_buf|.
17419 Namely, let |l| be the length of the descriptive information that appears
17420 on the first line. The length of the context information gathered for that
17421 line is |k=first_count|, and the length of the context information
17422 gathered for line~2 is $m=\min(|tally|, |trick_count|)-k$. If |l+k<=h|,
17423 where |h=half_error_line|, we print |trick_buf[0..k-1]| after the
17424 descriptive information on line~1, and set |n:=l+k|; here |n| is the
17425 length of line~1. If $l+k>h$, some cropping is necessary, so we set |n:=h|
17426 and print `\.{...}' followed by
17427 $$\hbox{|trick_buf[(l+k-h+3)..k-1]|,}$$
17428 where subscripts of |trick_buf| are circular modulo |error_line|. The
17429 second line consists of |n|~spaces followed by |trick_buf[k..(k+m-1)]|,
17430 unless |n+m>error_line|; in the latter case, further cropping is done.
17431 This is easier to program than to explain.
17433 @<Local variables for formatting...@>=
17434 int i; /* index into |buffer| */
17435 integer l; /* length of descriptive information on line 1 */
17436 integer m; /* context information gathered for line 2 */
17437 int n; /* length of line 1 */
17438 integer p; /* starting or ending place in |trick_buf| */
17439 integer q; /* temporary index */
17441 @ The following code tells the print routines to gather
17442 the desired information.
17444 @d begin_pseudoprint {
17445 l=mp->tally; mp->tally=0; mp->selector=pseudo;
17446 mp->trick_count=1000000;
17448 @d set_trick_count() {
17449 mp->first_count=mp->tally;
17450 mp->trick_count=mp->tally+1+mp->error_line-mp->half_error_line;
17451 if ( mp->trick_count<mp->error_line ) mp->trick_count=mp->error_line;
17454 @ And the following code uses the information after it has been gathered.
17456 @<Print two lines using the tricky pseudoprinted information@>=
17457 if (mp->trick_count == 1000000)
17459 /* |set_trick_count| must be performed */
17460 if (mp->tally < mp->trick_count)
17461 m = mp->tally - mp->first_count;
17463 m = mp->trick_count - mp->first_count; /* context on line 2 */
17464 if (l + mp->first_count <= mp->half_error_line) {
17466 n = l + mp->first_count;
17468 mp_print (mp, "...");
17469 p = l + mp->first_count - mp->half_error_line + 3;
17470 n = mp->half_error_line;
17472 for (q = p; q <= mp->first_count - 1; q++) {
17473 mp_print_char (mp, mp->trick_buf[q % mp->error_line]);
17476 for (q = 1; q <= n; q++) {
17477 mp_print_char (mp, xord (' ')); /* print |n| spaces to begin line~2 */
17479 if (m + n <= mp->error_line)
17480 p = mp->first_count + m;
17482 p = mp->first_count + (mp->error_line - n - 3);
17483 for (q = mp->first_count; q <= p - 1; q++) {
17484 mp_print_char (mp, mp->trick_buf[q % mp->error_line]);
17486 if (m + n > mp->error_line)
17487 mp_print (mp, "...")
17490 @ But the trick is distracting us from our current goal, which is to
17491 understand the input state. So let's concentrate on the data structures that
17492 are being pseudoprinted as we finish up the |show_context| procedure.
17494 @<Pseudoprint the line@>=
17497 for (i = start; i <= limit - 1; i++) {
17500 mp_print_char (mp, mp->buffer[i]);
17504 @ @<Pseudoprint the token list@>=
17506 if (token_type != macro)
17507 mp_show_token_list (mp, nstart, nloc, 100000, 0);
17509 mp_show_macro (mp, nstart, nloc, 100000)
17512 @* Maintaining the input stacks.
17513 The following subroutines change the input status in commonly needed ways.
17515 First comes |push_input|, which stores the current state and creates a
17516 new level (having, initially, the same properties as the old).
17518 @d push_input { /* enter a new input level, save the old */
17519 if ( mp->input_ptr>mp->max_in_stack ) {
17520 mp->max_in_stack=mp->input_ptr;
17521 if ( mp->input_ptr==mp->stack_size ) {
17522 int l = (mp->stack_size+(mp->stack_size/4));
17523 XREALLOC(mp->input_stack, l, in_state_record);
17524 mp->stack_size = l;
17527 mp->input_stack[mp->input_ptr]=mp->cur_input; /* stack the record */
17528 incr(mp->input_ptr);
17531 @ And of course what goes up must come down.
17533 @d pop_input { /* leave an input level, re-enter the old */
17534 decr(mp->input_ptr); mp->cur_input=mp->input_stack[mp->input_ptr];
17537 @ Here is a procedure that starts a new level of token-list input, given
17538 a token list |p| and its type |t|. If |t=macro|, the calling routine should
17539 set |name|, reset~|loc|, and increase the macro's reference count.
17541 @d back_list(A) mp_begin_token_list(mp, (A), (quarterword)backed_up) /* backs up a simple token list */
17544 static void mp_begin_token_list (MP mp, mp_node p, quarterword t) {
17548 param_start = mp->param_ptr;
17553 @ When a token list has been fully scanned, the following computations
17554 should be done as we leave that level of input.
17558 static void mp_end_token_list (MP mp) { /* leave a token-list input level */
17559 mp_node p; /* temporary register */
17560 if (token_type >= backed_up) { /* token list to be deleted */
17561 if (token_type <= inserted) {
17562 mp_flush_token_list (mp, nstart);
17565 mp_delete_mac_ref (mp, nstart); /* update reference count */
17568 while (mp->param_ptr > param_start) { /* parameters must be flushed */
17569 decr (mp->param_ptr);
17570 p = mp->param_stack[mp->param_ptr];
17572 if (mp_link (p) == MP_VOID) { /* it's an \&{expr} parameter */
17573 mp_recycle_value (mp, p);
17574 mp_free_value_node (mp, p);
17576 mp_flush_token_list (mp, p); /* it's a \&{suffix} or \&{text} parameter */
17586 @ The contents of |cur_cmd,cur_mod,cur_sym| are placed into an equivalent
17587 token by the |cur_tok| routine.
17591 @<Declare the procedure called |make_exp_copy|@>;
17592 static mp_node mp_cur_tok (MP mp) {
17593 mp_node p; /* a new token node */
17594 if (cur_sym() == NULL && cur_sym_mod() == 0) {
17595 if (cur_cmd() == mp_capsule_token) {
17596 mp_number save_exp_num; /* possible |cur_exp| numerical to be restored */
17597 mp_value save_exp = mp->cur_exp; /* |cur_exp| to be restored */
17598 new_number (save_exp_num);
17599 number_clone (save_exp_num, cur_exp_value_number());
17600 mp_make_exp_copy (mp, cur_mod_node());
17601 p = mp_stash_cur_exp (mp);
17602 mp_link (p) = NULL;
17603 mp->cur_exp = save_exp;
17604 number_clone (mp->cur_exp.data.n, save_exp_num);
17605 free_number (save_exp_num);
17607 p = mp_get_token_node (mp);
17608 mp_name_type (p) = mp_token;
17609 if (cur_cmd() == mp_numeric_token) {
17610 set_value_number (p, cur_mod_number());
17611 mp_type (p) = mp_known;
17613 set_value_str (p, cur_mod_str());
17614 mp_type (p) = mp_string_type;
17618 p = mp_get_symbolic_node (mp);
17619 set_mp_sym_sym (p, cur_sym());
17620 mp_name_type (p) = cur_sym_mod();
17626 @ Sometimes \MP\ has read too far and wants to ``unscan'' what it has
17627 seen. The |back_input| procedure takes care of this by putting the token
17628 just scanned back into the input stream, ready to be read again.
17629 If |cur_sym<>0|, the values of |cur_cmd| and |cur_mod| are irrelevant.
17632 static void mp_back_input (MP mp);
17635 void mp_back_input (MP mp) { /* undoes one token of input */
17636 mp_node p; /* a token list of length one */
17637 p = mp_cur_tok (mp);
17638 while (token_state && (nloc == NULL))
17639 mp_end_token_list (mp); /* conserve stack space */
17644 @ The |back_error| routine is used when we want to restore or replace an
17645 offending token just before issuing an error message. We disable interrupts
17646 during the call of |back_input| so that the help message won't be lost.
17649 static void mp_back_error (MP mp, const char *msg, const char **hlp, boolean deletions_allowed) ;
17652 static void mp_back_error (MP mp, const char *msg, const char **hlp, boolean deletions_allowed) {
17653 /* back up one token and call |error| */
17654 mp->OK_to_interrupt = false;
17655 mp_back_input (mp);
17656 mp->OK_to_interrupt = true;
17657 mp_error (mp, msg, hlp, deletions_allowed);
17659 static void mp_ins_error (MP mp, const char *msg, const char **hlp, boolean deletions_allowed) {
17660 /* back up one inserted token and call |error| */
17661 mp->OK_to_interrupt = false;
17662 mp_back_input (mp);
17663 token_type = (quarterword) inserted;
17664 mp->OK_to_interrupt = true;
17665 mp_error (mp, msg, hlp, deletions_allowed);
17669 @ The |begin_file_reading| procedure starts a new level of input for lines
17670 of characters to be read from a file, or as an insertion from the
17671 terminal. It does not take care of opening the file, nor does it set |loc|
17672 or |limit| or |line|.
17673 @^system dependencies@>
17676 void mp_begin_file_reading (MP mp) {
17677 if (mp->in_open == (mp->max_in_open-1))
17678 mp_reallocate_input_stack (mp, (mp->max_in_open + mp->max_in_open / 4));
17679 if (mp->first == mp->buf_size)
17680 mp_reallocate_buffer (mp, (mp->buf_size + mp->buf_size / 4));
17683 iindex = (quarterword) mp->in_open;
17684 if (mp->in_open_max < mp->in_open)
17685 mp->in_open_max = mp->in_open;
17686 mp->mpx_name[iindex] = absent;
17687 start = (halfword) mp->first;
17688 name = is_term; /* |terminal_input| is now |true| */
17692 @ Conversely, the variables must be downdated when such a level of input
17693 is finished. Any associated \.{MPX} file must also be closed and popped
17694 off the file stack. While finishing preloading, it is possible that the file
17695 does not actually end with 'dump', so we capture that case here as well.
17698 static void mp_end_file_reading (MP mp) {
17699 if (mp->reading_preload && mp->input_ptr == 0) {
17700 set_cur_sym(mp->frozen_dump);
17701 mp_back_input (mp);
17704 if (mp->in_open > iindex) {
17705 if ((mp->mpx_name[mp->in_open] == absent) || (name <= max_spec_src)) {
17706 mp_confusion (mp, "endinput");
17707 @:this can't happen endinput}{\quad endinput@>;
17709 (mp->close_file) (mp, mp->input_file[mp->in_open]); /* close an \.{MPX} file */
17710 delete_str_ref (mp->mpx_name[mp->in_open]);
17711 decr (mp->in_open);
17714 mp->first = (size_t) start;
17715 if (iindex != mp->in_open)
17716 mp_confusion (mp, "endinput");
17717 if (name > max_spec_src) {
17718 (mp->close_file) (mp, cur_file);
17724 decr (mp->in_open);
17728 @ Here is a function that tries to resume input from an \.{MPX} file already
17729 associated with the current input file. It returns |false| if this doesn't
17733 static boolean mp_begin_mpx_reading (MP mp) {
17734 if (mp->in_open != iindex + 1) {
17737 if (mp->mpx_name[mp->in_open] <= absent)
17738 mp_confusion (mp, "mpx");
17739 if (mp->first == mp->buf_size)
17740 mp_reallocate_buffer (mp, (mp->buf_size + (mp->buf_size / 4)));
17742 iindex = (quarterword) mp->in_open;
17743 start = (halfword) mp->first;
17744 name = mp->mpx_name[mp->in_open];
17745 add_str_ref (name);
17746 /* Put an empty line in the input buffer */
17747 /* We want to make it look as though we have just read a blank line
17748 without really doing so. */
17749 mp->last = mp->first;
17750 limit = (halfword) mp->last;
17751 /* simulate |input_ln| and |firm_up_the_line| */
17752 mp->buffer[limit] = xord ('%');
17753 mp->first = (size_t) (limit + 1);
17760 @ This procedure temporarily stops reading an \.{MPX} file.
17763 static void mp_end_mpx_reading (MP mp) {
17764 if (mp->in_open != iindex)
17765 mp_confusion (mp, "mpx");
17766 @:this can't happen mpx}{\quad mpx@>;
17768 /* Complain that we are not at the end of a line in the \.{MPX} file */
17769 /* Here we enforce a restriction that simplifies the input stacks considerably.
17770 This should not inconvenience the user because \.{MPX} files are generated
17771 by an auxiliary program called \.{DVItoMP}. */
17772 const char *hlp[] = {
17773 "This file contains picture expressions for btex...etex",
17774 "blocks. Such files are normally generated automatically",
17775 "but this one seems to be messed up. I'm going to ignore",
17776 "the rest of this line.",
17778 mp_error (mp, "`mpxbreak' must be at the end of a line", hlp, true);
17780 mp->first = (size_t) start;
17784 @ In order to keep the stack from overflowing during a long sequence of
17785 inserted `\.{show}' commands, the following routine removes completed
17786 error-inserted lines from memory.
17789 void mp_clear_for_error_prompt (MP mp) {
17790 while (file_state && terminal_input && (mp->input_ptr > 0) && (loc == limit))
17791 mp_end_file_reading (mp);
17797 @ To get \MP's whole input mechanism going, we perform the following
17800 @<Initialize the input routines@>=
17803 mp->max_in_stack = file_bottom;
17804 mp->in_open = file_bottom;
17805 mp->open_parens = 0;
17806 mp->max_buf_stack = 0;
17808 mp->max_param_stack = 0;
17811 iindex = file_bottom;
17814 mp->mpx_name[file_bottom] = absent;
17815 mp->force_eof = false;
17816 if (!mp_init_terminal (mp))
17818 limit = (halfword) mp->last;
17819 mp->first = mp->last + 1;
17820 /* |init_terminal| has set |loc| and |last| */
17824 @* Getting the next token.
17825 The heart of \MP's input mechanism is the |get_next| procedure, which
17826 we shall develop in the next few sections of the program. Perhaps we
17827 shouldn't actually call it the ``heart,'' however; it really acts as \MP's
17828 eyes and mouth, reading the source files and gobbling them up. And it also
17829 helps \MP\ to regurgitate stored token lists that are to be processed again.
17831 The main duty of |get_next| is to input one token and to set |cur_cmd|
17832 and |cur_mod| to that token's command code and modifier. Furthermore, if
17833 the input token is a symbolic token, that token's |hash| address
17834 is stored in |cur_sym|; otherwise |cur_sym| is set to zero.
17836 Underlying this simple description is a certain amount of complexity
17837 because of all the cases that need to be handled.
17838 However, the inner loop of |get_next| is reasonably short and fast.
17840 @ Before getting into |get_next|, we need to consider a mechanism by which
17841 \MP\ helps keep errors from propagating too far. Whenever the program goes
17842 into a mode where it keeps calling |get_next| repeatedly until a certain
17843 condition is met, it sets |scanner_status| to some value other than |normal|.
17844 Then if an input file ends, or if an `\&{outer}' symbol appears,
17845 an appropriate error recovery will be possible.
17847 The global variable |warning_info| helps in this error recovery by providing
17848 additional information. For example, |warning_info| might indicate the
17849 name of a macro whose replacement text is being scanned.
17851 @d normal 0 /* |scanner_status| at ``quiet times'' */
17852 @d skipping 1 /* |scanner_status| when false conditional text is being skipped */
17853 @d flushing 2 /* |scanner_status| when junk after a statement is being ignored */
17854 @d absorbing 3 /* |scanner_status| when a \&{text} parameter is being scanned */
17855 @d var_defining 4 /* |scanner_status| when a \&{vardef} is being scanned */
17856 @d op_defining 5 /* |scanner_status| when a macro \&{def} is being scanned */
17857 @d loop_defining 6 /* |scanner_status| when a \&{for} loop is being scanned */
17860 #define tex_flushing 7 /* |scanner_status| when skipping \TeX\ material */
17861 integer scanner_status; /* are we scanning at high speed? */
17862 mp_sym warning_info; /* if so, what else do we need to know,
17863 in case an error occurs? */
17864 integer warning_line;
17865 mp_node warning_info_node;
17867 @ @<Initialize the input routines@>=
17868 mp->scanner_status = normal;
17870 @ The following subroutine
17871 is called when an `\&{outer}' symbolic token has been scanned or
17872 when the end of a file has been reached. These two cases are distinguished
17873 by |cur_sym|, which is zero at the end of a file.
17876 static boolean mp_check_outer_validity (MP mp) {
17877 mp_node p; /* points to inserted token list */
17878 if (mp->scanner_status == normal) {
17880 } else if (mp->scanner_status == tex_flushing) {
17881 @<Check if the file has ended while flushing \TeX\ material and set the
17882 result value for |check_outer_validity|@>;
17884 @<Back up an outer symbolic token so that it can be reread@>;
17885 if (mp->scanner_status > skipping) {
17886 @<Tell the user what has run away and try to recover@>;
17889 const char *hlp[] = {
17890 "A forbidden `outer' token occurred in skipped text.",
17891 "This kind of error happens when you say `if...' and forget",
17892 "the matching `fi'. I've inserted a `fi'; this might work.",
17894 mp_snprintf(msg, 256, "Incomplete if; all text was ignored after line %d", (int)mp->warning_line);
17895 @.Incomplete if...@>;
17896 if (cur_sym() == NULL) {
17897 hlp[0] = "The file ended while I was skipping conditional text.";
17899 set_cur_sym (mp->frozen_fi);
17900 mp_ins_error (mp, msg, hlp, false);
17907 @ @<Check if the file has ended while flushing \TeX\ material and set...@>=
17908 if (cur_sym() != NULL) {
17912 const char *hlp[] = {
17913 "The file ended while I was looking for the `etex' to",
17914 "finish this TeX material. I've inserted `etex' now.",
17916 mp_snprintf(msg, 256, "TeX mode didn't end; all text was ignored after line %d", (int)mp->warning_line);
17917 set_cur_sym(mp->frozen_etex);
17918 mp_ins_error (mp, msg, hlp, false);
17923 @ @<Back up an outer symbolic token so that it can be reread@>=
17924 if (cur_sym() != NULL) {
17925 p = mp_get_symbolic_node (mp);
17926 set_mp_sym_sym (p, cur_sym());
17927 mp_name_type (p) = cur_sym_mod();
17928 back_list (p); /* prepare to read the symbolic token again */
17931 @ @<Tell the user what has run away...@>=
17934 const char *msg_start = NULL;
17935 const char *hlp[] = {
17936 "I suspect you have forgotten an `enddef',",
17937 "causing me to read past where you wanted me to stop.",
17938 "I'll try to recover; but if the error is serious,",
17939 "you'd better type `E' or `X' now and fix your file.",
17941 mp_runaway (mp); /* print the definition-so-far */
17942 if (cur_sym() == NULL) {
17943 msg_start = "File ended while scanning";
17944 @.File ended while scanning...@>
17946 msg_start = "Forbidden token found while scanning";
17947 @.Forbidden token found...@>
17949 switch (mp->scanner_status) {
17950 @<Complete the error message,
17951 and set |cur_sym| to a token that might help recover from the error@>
17952 } /* there are no other cases */
17953 mp_ins_error (mp, msg, hlp, true);
17957 @ As we consider various kinds of errors, it is also appropriate to
17958 change the first line of the help message just given; |help_line[3]|
17959 points to the string that might be changed.
17961 @<Complete the error message,...@>=
17963 mp_snprintf (msg, 256, "%s to the end of the statement", msg_start);
17964 hlp[0] = "A previous error seems to have propagated,";
17965 set_cur_sym(mp->frozen_semicolon);
17968 mp_snprintf (msg, 256, "%s a text argument", msg_start);
17969 hlp[0] = "It seems that a right delimiter was left out,";
17970 if (mp->warning_info == NULL) {
17971 set_cur_sym(mp->frozen_end_group);
17973 set_cur_sym(mp->frozen_right_delimiter);
17974 /* the next line makes sure that the inserted delimiter will
17975 match the delimiter that already was read. */
17976 set_equiv_sym (cur_sym(), mp->warning_info);
17982 int old_setting = mp->selector;
17983 mp->selector = new_string;
17984 mp_print_variable_name (mp, mp->warning_info_node);
17985 s = mp_make_string (mp);
17986 mp->selector = old_setting;
17987 mp_snprintf (msg, 256, "%s the definition of %s", msg_start, s->str);
17990 set_cur_sym(mp->frozen_end_def);
17994 char *s = mp_str(mp, text(mp->warning_info));
17995 mp_snprintf (msg, 256, "%s the definition of %s", msg_start, s);
17997 set_cur_sym(mp->frozen_end_def);
17999 case loop_defining:
18001 char *s = mp_str(mp, text(mp->warning_info));
18002 mp_snprintf (msg, 256, "%s the text of a %s loop", msg_start, s);
18004 hlp[0] = "I suspect you have forgotten an `endfor',";
18005 set_cur_sym(mp->frozen_end_for);
18008 @ The |runaway| procedure displays the first part of the text that occurred
18009 when \MP\ began its special |scanner_status|, if that text has been saved.
18012 static void mp_runaway (MP mp);
18015 void mp_runaway (MP mp) {
18016 if (mp->scanner_status > flushing) {
18017 mp_print_nl (mp, "Runaway ");
18018 switch (mp->scanner_status) {
18020 mp_print (mp, "text?");
18024 mp_print (mp, "definition?");
18026 case loop_defining:
18027 mp_print (mp, "loop?");
18029 } /* there are no other cases */
18031 mp_show_token_list (mp, mp_link (mp->hold_head), NULL, mp->error_line - 10,
18037 @ We need to mention a procedure that may be called by |get_next|.
18040 static void mp_firm_up_the_line (MP mp);
18042 @ And now we're ready to take the plunge into |get_next| itself.
18043 Note that the behavior depends on the |scanner_status| because percent signs
18044 and double quotes need to be passed over when skipping TeX material.
18047 void mp_get_next (MP mp) {
18048 /* sets |cur_cmd|, |cur_mod|, |cur_sym| to next token */
18049 mp_sym cur_sym_; /* speed up access */
18052 set_cur_sym_mod(0);
18054 int k; /* an index into |buffer| */
18055 ASCII_code c; /* the current character in the buffer */
18056 int cclass; /* its class number */
18057 /* Input from external file; |goto restart| if no input found,
18058 or |return| if a non-symbolic token is found */
18059 /* A percent sign appears in |buffer[limit]|; this makes it unnecessary
18060 to have a special test for end-of-line. */
18062 c = mp->buffer[loc];
18064 cclass = mp->char_class[c];
18067 scan_numeric_token((c - '0'));
18071 cclass = mp->char_class[mp->buffer[loc]];
18072 if (cclass > period_class) {
18074 } else if (cclass < period_class) { /* |class=digit_class| */
18075 scan_fractional_token(0);
18082 case percent_class:
18083 if (mp->scanner_status == tex_flushing) {
18087 /* Move to next line of file, or |goto restart| if there is no next line */
18088 switch (move_to_next_line(mp)) {
18089 case 1: goto RESTART; break;
18090 case 2: goto COMMON_ENDING; break;
18097 if (mp->scanner_status == tex_flushing) {
18100 if (mp->buffer[loc] == '"') {
18101 set_cur_mod_str
(mp_rts
(mp
,""));
18104 mp-
>buffer
[limit
+ 1] = xord
('
"');
18107 } while (mp->buffer[loc] != '"'
);
18109 /* Decry the missing string delimiter and |goto restart|
*/
18110 /* We go to |restart| after this error message
, not to |SWITCH|
,
18111 because the |clear_for_error_prompt| routine might have reinstated
18112 |token_state| after |error| has finished.
*/
18113 const char
*hlp
[] = {
18114 "Strings should finish on the same line as they began.",
18115 "I've deleted the partial string; you might want to",
18116 "insert another by typing, e.g., `I\"new string\
"'.",
18118 loc
= limit
; /* the next character to be read on this line will be |
"%"|
*/
18119 mp_error
(mp
, "Incomplete string token has been flushed", hlp
, false
);
18122 str_room
((size_t
) (loc
- k
));
18124 append_char
(mp-
>buffer
[k
]);
18126 } while
(k
!= loc
);
18127 set_cur_mod_str
(mp_make_string
(mp
));
18130 set_cur_cmd
((mp_variable_type
)mp_string_token
);
18134 case isolated_classes
:
18138 case invalid_class
:
18139 if
(mp-
>scanner_status
== tex_flushing
) {
18142 /* Decry the invalid character and |goto restart|
*/
18143 /* We go to |restart| instead of to |SWITCH|
, because we might enter
18144 |token_state| after the error has been dealt with
18145 (cf.\ |clear_for_error_prompt|
).
*/
18146 const char
*hlp
[] = {
18147 "A funny symbol that I can\'t read has just been input.",
18148 "Continue, and I'll forget that it ever happened.",
18150 mp_error
(mp
, "Text line contains an invalid character", hlp
, false
);
18155 break
; /* letters
, etc.
*/
18158 while
(mp-
>char_class
[mp-
>buffer
[loc
]] == cclass
)
18161 set_cur_sym
(mp_id_lookup
(mp
, (char
*) (mp-
>buffer
+ k
), (size_t
) (loc
- k
), true
));
18164 /* Input from token list
; |goto restart| if end of list or
18165 if a parameter needs to be expanded
,
18166 or |return| if a non-symbolic token is found
*/
18167 if
(nloc
!= NULL && mp_type (nloc) == mp_symbol_node) { /* symbolic token */
18168 int cur_sym_mod_
= mp_name_type
(nloc
);
18169 halfword cur_info
= mp_sym_info
(nloc
);
18170 set_cur_sym
(mp_sym_sym
(nloc
));
18171 set_cur_sym_mod
(cur_sym_mod_
);
18172 nloc
= mp_link
(nloc
); /* move to next
*/
18173 if
(cur_sym_mod_
== mp_expr_sym
) {
18174 set_cur_cmd
((mp_variable_type
)mp_capsule_token
);
18175 set_cur_mod_node
(mp-
>param_stack
[param_start
+ cur_info
]);
18176 set_cur_sym_mod
(0);
18179 } else if
(cur_sym_mod_
== mp_suffix_sym || cur_sym_mod_
== mp_text_sym
) {
18180 mp_begin_token_list
(mp
,
18181 mp-
>param_stack
[param_start
+ cur_info
],
18182 (quarterword
) parameter
);
18185 } else if
(nloc
!= NULL) {
18186 /* Get a stored numeric or string or capsule token and |return|
*/
18187 if
(mp_name_type
(nloc
) == mp_token
) {
18188 if
(mp_type
(nloc
) == mp_known
) {
18189 set_cur_mod_number
(value_number
(nloc
));
18190 set_cur_cmd
((mp_variable_type
)mp_numeric_token
);
18192 set_cur_mod_str
(value_str
(nloc
));
18193 set_cur_cmd
((mp_variable_type
)mp_string_token
);
18194 add_str_ref
(cur_mod_str
());
18197 set_cur_mod_node
(nloc
);
18198 set_cur_cmd
((mp_variable_type
)mp_capsule_token
);
18200 nloc
= mp_link
(nloc
);
18202 } else
{ /* we are done with this token list
*/
18203 mp_end_token_list
(mp
);
18204 goto RESTART
; /* resume previous level
*/
18208 /* When a symbolic token is declared to be `\
&{outer}', its command code
18209 is increased by |outer_tag|.
*/
18210 cur_sym_
= cur_sym
();
18211 set_cur_cmd
(eq_type
(cur_sym_
));
18212 set_cur_mod
(equiv
(cur_sym_
));
18213 set_cur_mod_node
(equiv_node
(cur_sym_
));
18214 if
(cur_cmd
() >= mp_outer_tag
) {
18215 if
(mp_check_outer_validity
(mp
))
18216 set_cur_cmd
(cur_cmd
() - mp_outer_tag
);
18222 @ The global variable |force_eof| is normally |false|
; it is set |true|
18223 by an \
&{endinput} command.
18226 boolean force_eof
; /* should the next \
&{input} be aborted early? */
18228 @ @
<Declarations@
>=
18229 static int move_to_next_line
(MP mp
);
18232 static int move_to_next_line
(MP mp
) {
18233 if
(name
> max_spec_src
) {
18234 /* Read next line of file into |buffer|
, or return
1
18235 (|goto restart|
) if the file has ended
*/
18236 /* We must decrement |loc| in order to leave the buffer in a valid state
18237 when an error condition causes us to |goto restart| without calling
18238 |end_file_reading|.
*/
18241 mp-
>first
= (size_t
) start
;
18242 if
(!mp-
>force_eof
) {
18243 if
(mp_input_ln
(mp
, cur_file
)) /* not end of file
*/
18244 mp_firm_up_the_line
(mp
); /* this sets |limit|
*/
18246 mp-
>force_eof
= true
;
18248 if
(mp-
>force_eof
) {
18249 mp-
>force_eof
= false
;
18252 /* Complain that the \.
{MPX
} file ended unexpectly
; then set
18253 |cur_sym
:=mp-
>frozen_mpx_break| and |goto comon_ending|
*/
18254 /* We should never actually come to the end of an \.
{MPX
} file because such
18255 files should have an \
&{mpxbreak} after the translation of the last
18256 \
&{btex}$\,\ldots\,$\&{etex} block. */
18257 const char
*hlp
[] = {"The file had too few picture expressions for btex...etex",
18258 "blocks. Such files are normally generated automatically",
18259 "but this one got messed up. You might want to insert a",
18260 "picture expression now.",
18262 mp-
>mpx_name
[iindex
] = mpx_finished
;
18263 mp_error
(mp
, "mpx file ended unexpectedly", hlp
, false
);
18264 set_cur_sym
(mp-
>frozen_mpx_break
);
18267 mp_print_char
(mp
, xord
('
)'
));
18268 decr
(mp-
>open_parens
);
18269 update_terminal
(); /* show user that file has been read
*/
18270 mp_end_file_reading
(mp
); /* resume previous level
*/
18271 if
(mp_check_outer_validity
(mp
))
18277 mp-
>buffer
[limit
] = xord
('
%'
);
18278 mp-
>first
= (size_t
) (limit
+ 1);
18279 loc
= start
; /* ready to read
*/
18284 if
(mp-
>input_ptr
> 0) {
18285 /* text was inserted during error recovery or by \
&{scantokens} */
18286 mp_end_file_reading
(mp
);
18288 return
1; /* resume previous level
*/
18290 if
(mp-
>job_name
== NULL
18291 && (mp->selector < log_only || mp->selector >= write_file))
18292 mp_open_log_file
(mp
);
18293 if
(mp-
>interaction
> mp_nonstop_mode
) {
18294 if
(limit
== start
) /* previous line was empty
*/
18295 mp_print_nl
(mp
, "(Please type a command or say `end')");
18297 mp-
>first
= (size_t
) start
;
18298 prompt_input
("*"); /* input on-line into |buffer|
*/
18299 limit
= (halfword
) mp-
>last
;
18300 mp-
>buffer
[limit
] = xord
('
%'
);
18301 mp-
>first
= (size_t
) (limit
+ 1);
18304 mp_fatal_error
(mp
, "*** (job aborted, no legal end found)");
18305 /* nonstop mode
, which is intended for overnight batch processing
,
18306 never waits for on-line input
*/
18313 @ If the user has set the |mp_pausing| parameter to some positive value
,
18314 and if nonstop mode has not been selected
, each line of input is displayed
18315 on the terminal and the transcript file
, followed by `\.
{=>}'.
18316 \MP\ waits for a response. If the response is
NULL (i.e.
, if nothing is
18317 typed except perhaps a few blank spaces
), the original
18318 line is accepted as it stands
; otherwise the line typed is
18319 used instead of the line in the file.
18322 void mp_firm_up_the_line
(MP mp
) {
18323 size_t k
; /* an index into |buffer|
*/
18324 limit
= (halfword
) mp-
>last
;
18325 if
((!mp-
>noninteractive
)
18326 && (number_positive (internal_value (mp_pausing)))
18327 && (mp->interaction > mp_nonstop_mode)) {
18328 wake_up_terminal
();
18330 if
(start
< limit
) {
18331 for
(k
= (size_t
) start
; k
< (size_t
) limit
; k
++) {
18332 mp_print_char
(mp
, mp-
>buffer
[k
]);
18335 mp-
>first
= (size_t
) limit
;
18336 prompt_input
("=>"); /* wait for user response
*/
18338 if
(mp-
>last
> mp-
>first
) {
18339 for
(k
= mp-
>first
; k
< mp-
>last
; k
++) { /* move line down in buffer
*/
18340 mp-
>buffer
[k
+ (size_t
) start
- mp-
>first
] = mp-
>buffer
[k
];
18342 limit
= (halfword
) ((size_t
) start
+ mp-
>last
- mp-
>first
);
18348 @
* Dealing with \TeX\ material.
18349 The \
&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}$\,\ldots\,$\&{etex}
18350 features need to be implemented at a low level in the scanning process
18351 so that \MP\ can stay in synch with the a preprocessor that treats
18352 blocks of \TeX\ material as they occur in the input file without trying
18353 to expand \MP\ macros. Thus we need a special version of |get_next|
18354 that does not expand macros and such but does handle \
&{btex},
18355 \
&{verbatimtex}, etc.
18357 The special version of |get_next| is called |get_t_next|. It works by flushing
18358 \
&{btex}$\,\ldots\,$\&{etex} and \&{verbatimtex}\allowbreak
18359 $\
,\ldots\
,$\
&{etex} blocks, switching to the \.{MPX} file when it sees
18360 \
&{btex}, and switching back when it sees \&{mpxbreak}.
18366 mp_primitive
(mp
, "btex", mp_start_tex
, btex_code
);
18367 @
:btex_
}{\
&{btex} primitive@>;
18368 mp_primitive
(mp
, "verbatimtex", mp_start_tex
, verbatim_code
);
18369 @
:verbatimtex_
}{\
&{verbatimtex} primitive@>;
18370 mp_primitive
(mp
, "etex", mp_etex_marker
, 0);
18371 mp-
>frozen_etex
= mp_frozen_primitive
(mp
, "etex", mp_etex_marker
, 0);
18372 @
:etex_
}{\
&{etex} primitive@>;
18373 mp_primitive
(mp
, "mpxbreak", mp_mpx_break
, 0);
18374 mp-
>frozen_mpx_break
= mp_frozen_primitive
(mp
, "mpxbreak", mp_mpx_break
, 0);
18375 @
:mpx_break_
}{\
&{mpxbreak} primitive@>
18378 @ @
<Cases of |print_cmd...@
>=
18380 if
(m
== btex_code
)
18381 mp_print
(mp
, "btex");
18383 mp_print
(mp
, "verbatimtex");
18385 case mp_etex_marker
:
18386 mp_print
(mp
, "etex");
18389 mp_print
(mp
, "mpxbreak");
18392 @ Actually
, |get_t_next| is a macro that avoids procedure overhead except
18393 in the unusual case where \
&{btex}, \&{verbatimtex}, \&{etex}, or \&{mpxbreak}
18396 @d get_t_next
(a
) do
{
18398 if
(cur_cmd
() <= mp_max_pre_command
)
18403 @ @
<Declarations@
>=
18404 static void mp_t_next
(MP mp
);
18405 static void mp_start_mpx_input
(MP mp
);
18408 static void mp_t_next
(MP mp
) {
18409 int old_status
; /* saves the |scanner_status|
*/
18410 integer old_info
; /* saves the |warning_info|
*/
18411 while
(cur_cmd
() <= mp_max_pre_command
) {
18412 if
(cur_cmd
() == mp_mpx_break
) {
18413 if
(!file_state ||
(mp-
>mpx_name
[iindex
] == absent
)) {
18414 @
<Complain about a misplaced \
&{mpxbreak}@>;
18416 mp_end_mpx_reading
(mp
);
18419 } else if
(cur_cmd
() == mp_start_tex
) {
18420 if
(token_state ||
(name
<= max_spec_src
)) {
18421 @
<Complain that we are not reading a file@
>;
18422 } else if
(mpx_reading
) {
18423 @
<Complain that \.
{MPX
} files cannot contain \TeX\ material@
>;
18424 } else if
((cur_mod
() != verbatim_code
) &&
18425 (mp-
>mpx_name
[iindex
] != mpx_finished
)) {
18426 if
(!mp_begin_mpx_reading
(mp
))
18427 mp_start_mpx_input
(mp
);
18432 @
<Complain about a misplaced \
&{etex}@>;
18434 goto COMMON_ENDING
;
18436 @
<Flush the \TeX\ material@
>;
18443 @ We could be in the middle of an operation such as skipping false conditional
18444 text when \TeX\ material is encountered
, so we must be careful to save the
18447 @
<Flush the \TeX\ material@
>=
18448 old_status
= mp-
>scanner_status
;
18449 old_info
= mp-
>warning_line
;
18450 mp-
>scanner_status
= tex_flushing
;
18451 mp-
>warning_line
= line
;
18454 } while
(cur_cmd
() != mp_etex_marker
);
18455 mp-
>scanner_status
= old_status
;
18456 mp-
>warning_line
= old_info
18458 @ @
<Complain that \.
{MPX
} files cannot contain \TeX\ material@
>=
18460 const char
*hlp
[] = {
18461 "This file contains picture expressions for btex...etex",
18462 "blocks. Such files are normally generated automatically",
18463 "but this one seems to be messed up. I'll just keep going",
18464 "and hope for the best.",
18466 mp_error
(mp
, "An mpx file cannot contain btex or verbatimtex blocks", hlp
, true
);
18470 @ @
<Complain that we are not reading a file@
>=
18472 const char
*hlp
[] = {
18473 "I'll have to ignore this preprocessor command because it",
18474 "only works when there is a file to preprocess. You might",
18475 "want to delete everything up to the next `etex`.",
18477 mp_error
(mp
, "You can only use `btex' or `verbatimtex' in a file", hlp
, true
);
18481 @ @
<Complain about a misplaced \
&{mpxbreak}@>=
18483 const char
*hlp
[] = {
18484 "I'll ignore this preprocessor command because it",
18485 "doesn't belong here",
18487 mp_error
(mp
, "Misplaced mpxbreak", hlp
, true
);
18491 @ @
<Complain about a misplaced \
&{etex}@>=
18493 const char
*hlp
[] = {
18494 "There is no btex or verbatimtex for this to match",
18496 mp_error
(mp
, "Extra etex will be ignored", hlp
, true
);
18500 @
* Scanning macro definitions.
18501 \MP\ has a variety of ways to tuck tokens away into token lists for later
18502 use
: Macros can be defined with \
&{def}, \&{vardef}, \&{primarydef}, etc.;
18503 repeatable code can be defined with \
&{for}, \&{forever}, \&{forsuffixes}.
18504 All such operations are handled by the routines in this part of the program.
18506 The modifier part of each command code is zero for the ``ending delimiters''
18507 like \
&{enddef} and \&{endfor}.
18509 @d start_def
1 /* command modifier for \
&{def} */
18510 @d var_def
2 /* command modifier for \
&{vardef} */
18511 @d end_def
0 /* command modifier for \
&{enddef} */
18512 @d start_forever
1 /* command modifier for \
&{forever} */
18513 @d start_for
2 /* command modifier for \
&{forever} */
18514 @d start_forsuffixes
3 /* command modifier for \
&{forever} */
18515 @d end_for
0 /* command modifier for \
&{endfor} */
18518 mp_primitive
(mp
, "def", mp_macro_def
, start_def
);
18519 @
:def_
}{\
&{def} primitive@>;
18520 mp_primitive
(mp
, "vardef", mp_macro_def
, var_def
);
18521 @
:var_def_
}{\
&{vardef} primitive@>;
18522 mp_primitive
(mp
, "primarydef", mp_macro_def
, mp_secondary_primary_macro
);
18523 @
:primary_def_
}{\
&{primarydef} primitive@>;
18524 mp_primitive
(mp
, "secondarydef", mp_macro_def
, mp_tertiary_secondary_macro
);
18525 @
:secondary_def_
}{\
&{secondarydef} primitive@>;
18526 mp_primitive
(mp
, "tertiarydef", mp_macro_def
, mp_expression_tertiary_macro
);
18527 @
:tertiary_def_
}{\
&{tertiarydef} primitive@>;
18528 mp_primitive
(mp
, "enddef", mp_macro_def
, end_def
);
18529 mp-
>frozen_end_def
= mp_frozen_primitive
(mp
, "enddef", mp_macro_def
, end_def
);
18530 @
:end_def_
}{\
&{enddef} primitive@>;
18531 mp_primitive
(mp
, "for", mp_iteration
, start_for
);
18532 @
:for_
}{\
&{for} primitive@>;
18533 mp_primitive
(mp
, "forsuffixes", mp_iteration
, start_forsuffixes
);
18534 @
:for_suffixes_
}{\
&{forsuffixes} primitive@>;
18535 mp_primitive
(mp
, "forever", mp_iteration
, start_forever
);
18536 @
:forever_
}{\
&{forever} primitive@>;
18537 mp_primitive
(mp
, "endfor", mp_iteration
, end_for
);
18538 mp-
>frozen_end_for
= mp_frozen_primitive
(mp
, "endfor", mp_iteration
, end_for
);
18539 @
:end_for_
}{\
&{endfor} primitive@>
18542 @ @
<Cases of |print_cmd...@
>=
18544 if
(m
<= var_def
) {
18545 if
(m
== start_def
)
18546 mp_print
(mp
, "def");
18547 else if
(m
< start_def
)
18548 mp_print
(mp
, "enddef");
18550 mp_print
(mp
, "vardef");
18551 } else if
(m
== mp_secondary_primary_macro
) {
18552 mp_print
(mp
, "primarydef");
18553 } else if
(m
== mp_tertiary_secondary_macro
) {
18554 mp_print
(mp
, "secondarydef");
18556 mp_print
(mp
, "tertiarydef");
18560 if
(m
== start_forever
)
18561 mp_print
(mp
, "forever");
18562 else if
(m
== end_for
)
18563 mp_print
(mp
, "endfor");
18564 else if
(m
== start_for
)
18565 mp_print
(mp
, "for");
18567 mp_print
(mp
, "forsuffixes");
18570 @ Different macro-absorbing operations have different syntaxes
, but they
18571 also have a lot in common. There is a list of special symbols that are to
18572 be replaced by parameter tokens
; there is a special command code that
18573 ends the definition
; the quotation conventions are identical. Therefore
18574 it makes sense to have most of the work done by a single subroutine. That
18575 subroutine is called |scan_toks|.
18577 The first parameter to |scan_toks| is the command code that will
18578 terminate scanning
(either |macro_def| or |iteration|
).
18580 The second parameter
, |subst_list|
, points to a
(possibly empty
) list
18581 of non-symbolic nodes whose |info| and |value| fields specify symbol tokens
18582 before and after replacement. The list will be returned to free storage
18585 The third parameter is simply appended to the token list that is built.
18586 And the final parameter tells how many of the special operations
18587 \.
{\#\
AT!}, \.
{\
AT!}, and \.
{\
AT!\#
} are to be replaced by suffix parameters.
18588 When such parameters are present
, they are called \.
{(SUFFIX0
)},
18589 \.
{(SUFFIX1
)}, and \.
{(SUFFIX2
)}.
18592 typedef struct mp_subst_list_item
{
18593 mp_name_type_type info_mod
;
18594 quarterword value_mod
;
18596 halfword value_data
;
18597 struct mp_subst_list_item
*link
;
18598 } mp_subst_list_item
;
18602 static mp_node mp_scan_toks
(MP mp
, mp_command_code terminator
,
18603 mp_subst_list_item
* subst_list
, mp_node tail_end
,
18604 quarterword suffix_count
) {
18605 mp_node p
; /* tail of the token list being built
*/
18606 mp_subst_list_item
*q
= NULL; /* temporary for link management
*/
18607 integer balance
; /* left delimiters minus right delimiters
*/
18609 quarterword cur_data_mod
= 0;
18612 mp_link
(mp-
>hold_head
) = NULL;
18616 if
(cur_sym
() != NULL) {
18617 @
<Substitute for |cur_sym|
, if it's on the |subst_list|@
>;
18618 if
(cur_cmd
() == terminator
) {
18619 @
<Adjust the balance
; |break| if it's zero@
>;
18620 } else if
(cur_cmd
() == mp_macro_special
) {
18621 /* Handle quoted symbols
, \.
{\#\
AT!}, \.
{\
AT!}, or \.
{\
AT!\#
} */
18622 if
(cur_mod
() == quote
) {
18624 } else if
(cur_mod
() <= suffix_count
) {
18625 cur_data
= cur_mod
() - 1;
18626 cur_data_mod
= mp_suffix_sym
;
18630 if
(cur_data
!= -1) {
18631 mp_node pp
= mp_get_symbolic_node
(mp
);
18632 set_mp_sym_info
(pp
, cur_data
);
18633 mp_name_type
(pp
) = cur_data_mod
;
18636 mp_link
(p
) = mp_cur_tok
(mp
);
18640 mp_link
(p
) = tail_end
;
18641 while
(subst_list
) {
18642 q
= subst_list-
>link
;
18643 xfree
(subst_list
);
18646 return mp_link
(mp-
>hold_head
);
18651 void mp_print_sym
(mp_sym sym
) {
18652 printf
("{type = %d, v = {type = %d, data = {indep = {scale = %d, serial = %d}, n = %d, str = %p, sym = %p, node = %p, p = %p}}, text = %p}\n", sym-
>type
, sym-
>v.type
, (int
)sym-
>v.data.indep.scale
, (int
)sym-
>v.data.indep.serial
,
18653 sym-
>v.data.n.type
, sym-
>v.data.str
, sym-
>v.data.sym
, sym-
>v.data.node
, sym-
>v.data.p
, sym-
>text
);
18654 if
(is_number
(sym-
>v.data.n
)) {
18655 mp_number n
= sym-
>v.data.n
;
18656 printf
("{data = {dval = %f, val = %d}, type = %d}\n", n.data.dval
, n.data.val
, n.type
);
18658 if
(sym-
>text
!= NULL) {
18659 mp_string t
= sym-
>text
;
18660 printf
("{str = %p \"%s\
", len = %d, refs = %d}\n", t-
>str
, t-
>str
, (int
)t-
>len
, t-
>refs
);
18666 void mp_print_sym
(mp_sym sym
) ;
18668 @ @
<Substitute for |cur_sym|...@
>=
18671 while
(q
!= NULL) {
18672 if
(q-
>info
== cur_sym
() && q->info_mod == cur_sym_mod()) {
18673 cur_data
= q-
>value_data
;
18674 cur_data_mod
= q-
>value_mod
;
18675 set_cur_cmd
((mp_variable_type
)mp_relax
);
18683 @ @
<Adjust the balance
; |break| if it's zero@
>=
18684 if
(cur_mod
() > 0) {
18693 @ Four commands are intended to be used only within macro texts
: \
&{quote},
18694 \.
{\#\
AT!}, \.
{\
AT!}, and \.
{\
AT!\#
}. They are variants of a single command
18695 code called |macro_special|.
18697 @d quote
0 /* |macro_special| modifier for \
&{quote} */
18698 @d macro_prefix
1 /* |macro_special| modifier for \.
{\#\
AT!} */
18699 @d macro_at
2 /* |macro_special| modifier for \.
{\
AT!} */
18700 @d macro_suffix
3 /* |macro_special| modifier for \.
{\
AT!\#
} */
18703 mp_primitive
(mp
, "quote", mp_macro_special
, quote
);
18704 @
:quote_
}{\
&{quote} primitive@>;
18705 mp_primitive
(mp
, "#@@", mp_macro_special
, macro_prefix
);
18706 @
:]]]\#\
AT!_
}{\.
{\#\
AT!} primitive@
>;
18707 mp_primitive
(mp
, "@@", mp_macro_special
, macro_at
);
18708 @
:]]]\
AT!_
}{\.
{\
AT!} primitive@
>;
18709 mp_primitive
(mp
, "@@#", mp_macro_special
, macro_suffix
);
18710 @
:]]]\
AT!\#_
}{\.
{\
AT!\#
} primitive@
>
18713 @ @
<Cases of |print_cmd...@
>=
18714 case mp_macro_special
:
18717 mp_print
(mp
, "#@@");
18720 mp_print_char
(mp
, xord
('@@'
));
18723 mp_print
(mp
, "@@#");
18726 mp_print
(mp
, "quote");
18731 @ Here is a routine that's used whenever a token will be redefined. If
18732 the user's token is unredefinable
, the `|mp-
>frozen_inaccessible|' token is
18733 substituted
; the latter is redefinable but essentially impossible to use
,
18734 hence \MP's tables won't get fouled up.
18737 static void mp_get_symbol
(MP mp
) { /* sets |cur_sym| to a safe symbol
*/
18740 if
((cur_sym
() == NULL) || mp_is_frozen
(mp
, cur_sym
())) {
18741 const char
*hlp
[] = {
18742 "Sorry: You can\'t redefine a number, string, or expr.",
18743 "I've inserted an inaccessible symbol so that your",
18744 "definition will be completed without mixing me up too badly.",
18746 if
(cur_sym
() != NULL)
18747 hlp
[0] = "Sorry: You can\'t redefine my error-recovery tokens.";
18748 else if
(cur_cmd
() == mp_string_token
)
18749 delete_str_ref
(cur_mod_str
());
18750 set_cur_sym
(mp-
>frozen_inaccessible
);
18751 mp_ins_error
(mp
, "Missing symbolic token inserted", hlp
, true
);
18752 @.Missing symbolic token...@
>;
18758 @ Before we actually redefine a symbolic token
, we need to clear away its
18759 former value
, if it was a variable. The following stronger version of
18760 |get_symbol| does that.
18763 static void mp_get_clear_symbol
(MP mp
) {
18764 mp_get_symbol
(mp
);
18765 mp_clear_symbol
(mp
, cur_sym
(), false
);
18769 @ Here's another little subroutine
; it checks that an equals sign
18770 or assignment sign comes along at the proper place in a macro definition.
18773 static void mp_check_equals
(MP mp
) {
18774 if
(cur_cmd
() != mp_equals
)
18775 if
(cur_cmd
() != mp_assignment
) {
18776 const char
*hlp
[] = {
18777 "The next thing in this `def' should have been `=',",
18778 "because I've already looked at the definition heading.",
18779 "But don't worry; I'll pretend that an equals sign",
18780 "was present. Everything from here to `enddef'",
18781 "will be the replacement text of this macro.",
18783 mp_back_error
(mp
, "Missing `=' has been inserted", hlp
, true
);
18789 @ A \
&{primarydef}, \&{secondarydef}, or \&{tertiarydef} is rather easily
18790 handled now that we have |scan_toks|. In this case there are
18791 two parameters
, which will be \.
{EXPR0
} and \.
{EXPR1
}.
18794 static void mp_make_op_def
(MP mp
) {
18795 mp_command_code m
; /* the type of definition
*/
18796 mp_node q
, r
; /* for list manipulation
*/
18797 mp_subst_list_item
*qm
= NULL, *qn
= NULL;
18799 mp_get_symbol
(mp
);
18800 qm
= xmalloc
(1, sizeof
(mp_subst_list_item
));
18802 qm-
>info
= cur_sym
();
18803 qm-
>info_mod
= cur_sym_mod
();
18804 qm-
>value_data
= 0;
18805 qm-
>value_mod
= mp_expr_sym
;
18806 mp_get_clear_symbol
(mp
);
18807 mp-
>warning_info
= cur_sym
();
18808 mp_get_symbol
(mp
);
18809 qn
= xmalloc
(1, sizeof
(mp_subst_list_item
));
18811 qn-
>info
= cur_sym
();
18812 qn-
>info_mod
= cur_sym_mod
();
18813 qn-
>value_data
= 1;
18814 qn-
>value_mod
= mp_expr_sym
;
18816 mp_check_equals
(mp
);
18817 mp-
>scanner_status
= op_defining
;
18818 q
= mp_get_symbolic_node
(mp
);
18819 set_ref_count
(q
, 0);
18820 r
= mp_get_symbolic_node
(mp
);
18822 set_mp_sym_info
(r
, mp_general_macro
);
18823 mp_name_type
(r
) = mp_macro_sym
;
18824 mp_link
(r
) = mp_scan_toks
(mp
, mp_macro_def
, qn
, NULL, 0);
18825 mp-
>scanner_status
= normal
;
18826 set_eq_type
(mp-
>warning_info
, m
);
18827 set_equiv_node
(mp-
>warning_info
, q
);
18828 mp_get_x_next
(mp
);
18832 @ Parameters to macros are introduced by the keywords \
&{expr},
18833 \
&{suffix}, \&{text}, \&{primary}, \&{secondary}, and \&{tertiary}.
18836 mp_primitive
(mp
, "expr", mp_param_type
, mp_expr_param
);
18837 @
:expr_
}{\
&{expr} primitive@>;
18838 mp_primitive
(mp
, "suffix", mp_param_type
, mp_suffix_param
);
18839 @
:suffix_
}{\
&{suffix} primitive@>;
18840 mp_primitive
(mp
, "text", mp_param_type
, mp_text_param
);
18841 @
:text_
}{\
&{text} primitive@>;
18842 mp_primitive
(mp
, "primary", mp_param_type
, mp_primary_macro
);
18843 @
:primary_
}{\
&{primary} primitive@>;
18844 mp_primitive
(mp
, "secondary", mp_param_type
, mp_secondary_macro
);
18845 @
:secondary_
}{\
&{secondary} primitive@>;
18846 mp_primitive
(mp
, "tertiary", mp_param_type
, mp_tertiary_macro
);
18847 @
:tertiary_
}{\
&{tertiary} primitive@>
18850 @ @
<Cases of |print_cmd...@
>=
18851 case mp_param_type
:
18852 if
(m
== mp_expr_param
)
18853 mp_print
(mp
, "expr");
18854 else if
(m
== mp_suffix_param
)
18855 mp_print
(mp
, "suffix");
18856 else if
(m
== mp_text_param
)
18857 mp_print
(mp
, "text");
18858 else if
(m
== mp_primary_macro
)
18859 mp_print
(mp
, "primary");
18860 else if
(m
== mp_secondary_macro
)
18861 mp_print
(mp
, "secondary");
18863 mp_print
(mp
, "tertiary");
18866 @ Let's turn next to the more complex processing associated with \
&{def}
18867 and \
&{vardef}. When the following procedure is called, |cur_mod|
18868 should be either |start_def| or |var_def|.
18870 Note that although the macro scanner allows |def
= := enddef| and
18871 |def
:= = enddef|
; |def
= = enddef| and |def
:= := enddef| will generate
18872 an error because by the time the second of the two identical tokens is
18873 seen
, its meaning has already become undefined.
18876 static void mp_scan_def
(MP mp
) {
18877 int m
; /* the type of definition
*/
18878 int n
; /* the number of special suffix parameters
*/
18879 int k
; /* the total number of parameters
*/
18880 int c
; /* the kind of macro we're defining
*/
18881 mp_subst_list_item
*r
= NULL, *rp
= NULL; /* parameter-substitution list
*/
18882 mp_node q
; /* tail of the macro token list
*/
18883 mp_node p
; /* temporary storage
*/
18884 quarterword sym_type
; /* |expr_sym|
, |suffix_sym|
, or |text_sym|
*/
18885 mp_sym l_delim
, r_delim
; /* matching delimiters
*/
18887 c
= mp_general_macro
;
18888 mp_link
(mp-
>hold_head
) = NULL;
18889 q
= mp_get_symbolic_node
(mp
);
18890 set_ref_count
(q
, 0);
18892 /* Scan the token or variable to be defined
;
18893 set |n|
, |scanner_status|
, and |warning_info|
*/
18894 if
(m
== start_def
) {
18895 mp_get_clear_symbol
(mp
);
18896 mp-
>warning_info
= cur_sym
();
18898 mp-
>scanner_status
= op_defining
;
18900 set_eq_type
(mp-
>warning_info
, mp_defined_macro
);
18901 set_equiv_node
(mp-
>warning_info
, q
);
18902 } else
{ /* |var_def|
*/
18903 p
= mp_scan_declared_variable
(mp
);
18904 mp_flush_variable
(mp
, equiv_node
(mp_sym_sym
(p
)), mp_link
(p
), true
);
18905 mp-
>warning_info_node
= mp_find_variable
(mp
, p
);
18906 mp_flush_node_list
(mp
, p
);
18907 if
(mp-
>warning_info_node
== NULL) {
18908 /* Change to `\.
{a bad variable
}'
*/
18909 const char
*hlp
[] = {
18910 "After `vardef a' you can\'t say `vardef a.b'.",
18911 "So I'll have to discard this definition.",
18913 mp_error
(mp
, "This variable already starts with a macro", hlp
, true
);
18914 mp-
>warning_info_node
= mp-
>bad_vardef
;
18916 mp-
>scanner_status
= var_defining
;
18918 if
(cur_cmd
() == mp_macro_special
&& cur_mod() == macro_suffix) { /* \.{\AT!\#} */
18922 mp_type
(mp-
>warning_info_node
) = (quarterword
) (mp_unsuffixed_macro
- 2 + n
);
18923 /* |mp_suffixed_macro
=mp_unsuffixed_macro
+1|
*/
18924 set_value_node
(mp-
>warning_info_node
, q
);
18928 if
(cur_cmd
() == mp_left_delimiter
) {
18929 /* Absorb delimited parameters
, putting them into lists |q| and |r|
*/
18931 l_delim
= cur_sym
();
18932 r_delim
= equiv_sym
(cur_sym
());
18934 if
((cur_cmd
() == mp_param_type
) && (cur_mod() == mp_expr_param)) {
18935 sym_type
= mp_expr_sym
;
18936 } else if
((cur_cmd
() == mp_param_type
) && (cur_mod() == mp_suffix_param)) {
18937 sym_type
= mp_suffix_sym
;
18938 } else if
((cur_cmd
() == mp_param_type
) && (cur_mod() == mp_text_param)) {
18939 sym_type
= mp_text_sym
;
18941 const char
*hlp
[] = { "You should've had `expr' or `suffix' or `text' here.", NULL };
18942 mp_back_error
(mp
, "Missing parameter type; `expr' will be assumed", hlp
, true
);
18943 sym_type
= mp_expr_sym
;
18945 /* Absorb parameter tokens for type |sym_type|
*/
18947 mp_link
(q
) = mp_get_symbolic_node
(mp
);
18949 mp_name_type
(q
) = sym_type
;
18950 set_mp_sym_info
(q
, k
);
18951 mp_get_symbol
(mp
);
18952 rp
= xmalloc
(1, sizeof
(mp_subst_list_item
));
18954 rp-
>value_data
= k
;
18955 rp-
>value_mod
= sym_type
;
18956 rp-
>info
= cur_sym
();
18957 rp-
>info_mod
= cur_sym_mod
();
18958 mp_check_param_size
(mp
, k
);
18963 } while
(cur_cmd
() == mp_comma
);
18965 mp_check_delimiter
(mp
, l_delim
, r_delim
);
18967 } while
(cur_cmd
() == mp_left_delimiter
);
18970 if
(cur_cmd
() == mp_param_type
) {
18971 /* Absorb undelimited parameters
, putting them into list |r|
*/
18972 rp
= xmalloc
(1, sizeof
(mp_subst_list_item
));
18974 rp-
>value_data
= k
;
18975 if
(cur_mod
() == mp_expr_param
) {
18976 rp-
>value_mod
= mp_expr_sym
;
18978 } else if
(cur_mod
() == mp_suffix_param
) {
18979 rp-
>value_mod
= mp_suffix_sym
;
18980 c
= mp_suffix_macro
;
18981 } else if
(cur_mod
() == mp_text_param
) {
18982 rp-
>value_mod
= mp_text_sym
;
18986 rp-
>value_mod
= mp_expr_sym
;
18988 mp_check_param_size
(mp
, k
);
18990 mp_get_symbol
(mp
);
18991 rp-
>info
= cur_sym
();
18992 rp-
>info_mod
= cur_sym_mod
();
18996 if
(c
== mp_expr_macro
) {
18997 if
(cur_cmd
() == mp_of_token
) {
18999 rp
= xmalloc
(1, sizeof
(mp_subst_list_item
));
19001 mp_check_param_size
(mp
, k
);
19002 rp-
>value_data
= k
;
19003 rp-
>value_mod
= mp_expr_sym
;
19004 mp_get_symbol
(mp
);
19005 rp-
>info
= cur_sym
();
19006 rp-
>info_mod
= cur_sym_mod
();
19013 mp_check_equals
(mp
);
19014 p
= mp_get_symbolic_node
(mp
);
19015 set_mp_sym_info
(p
, c
);
19016 mp_name_type
(p
) = mp_macro_sym
;
19018 /* Attach the replacement text to the tail of node |p|
*/
19019 /* We don't put `|mp-
>frozen_end_group|' into the replacement text of
19020 a \
&{vardef}, because the user may want to redefine `\.{endgroup}'. */
19021 if
(m
== start_def
) {
19022 mp_link
(p
) = mp_scan_toks
(mp
, mp_macro_def
, r
, NULL, (quarterword
) n
);
19024 mp_node qq
= mp_get_symbolic_node
(mp
);
19025 set_mp_sym_sym
(qq
, mp-
>bg_loc
);
19027 p
= mp_get_symbolic_node
(mp
);
19028 set_mp_sym_sym
(p
, mp-
>eg_loc
);
19029 mp_link
(qq
) = mp_scan_toks
(mp
, mp_macro_def
, r
, p
, (quarterword
) n
);
19031 if
(mp-
>warning_info_node
== mp-
>bad_vardef
)
19032 mp_flush_token_list
(mp
, value_node
(mp-
>bad_vardef
));
19033 mp-
>scanner_status
= normal
;
19034 mp_get_x_next
(mp
);
19039 mp_sym eg_loc
; /* hash addresses of `\.
{begingroup
}' and `\.
{endgroup
}'
*/
19041 @ @
<Initialize table entries@
>=
19042 mp-
>bad_vardef
= mp_get_value_node
(mp
);
19043 mp_name_type
(mp-
>bad_vardef
) = mp_root
;
19044 set_value_sym
(mp-
>bad_vardef
, mp-
>frozen_bad_vardef
);
19046 @ @
<Free table entries@
>=
19047 mp_free_value_node
(mp
, mp-
>bad_vardef
);
19050 @
* Expanding the next token.
19051 Only a few command codes |
<min_command| can possibly be returned by
19052 |get_t_next|
; in increasing order
, they are
19053 |if_test|
, |fi_or_else|
, |input|
, |iteration|
, |repeat_loop|
,
19054 |exit_test|
, |relax|
, |scan_tokens|
, |run_script|
, |expand_after|
, and |defined_macro|.
19056 \MP\ usually gets the next token of input by saying |get_x_next|. This is
19057 like |get_t_next| except that it keeps getting more tokens until
19058 finding |cur_cmd
>=min_command|. In other words
, |get_x_next| expands
19059 macros and removes conditionals or iterations or input instructions that
19062 It follows that |get_x_next| might invoke itself recursively. In fact
,
19063 there is massive recursion
, since macro expansion can involve the
19064 scanning of arbitrarily complex expressions
, which in turn involve
19065 macro expansion and conditionals
, etc.
19068 Therefore it's necessary to declare a whole bunch of |forward|
19069 procedures at this point
, and to insert some other procedures
19070 that will be invoked by |get_x_next|.
19073 static void mp_scan_primary
(MP mp
);
19074 static void mp_scan_secondary
(MP mp
);
19075 static void mp_scan_tertiary
(MP mp
);
19076 static void mp_scan_expression
(MP mp
);
19077 static void mp_scan_suffix
(MP mp
);
19078 static void mp_pass_text
(MP mp
);
19079 static void mp_conditional
(MP mp
);
19080 static void mp_start_input
(MP mp
);
19081 static void mp_begin_iteration
(MP mp
);
19082 static void mp_resume_iteration
(MP mp
);
19083 static void mp_stop_iteration
(MP mp
);
19085 @ A recursion depth counter is used to discover infinite recursions.
19086 (Near
) infinite recursion is a problem because it translates into
19087 C function calls that eat up the available call stack. A better solution
19088 would be to depend on signal trapping
, but that is problematic when
19089 Metapost is used as a library.
19092 int expand_depth_count
; /* current expansion depth
*/
19093 int expand_depth
; /* current expansion depth
*/
19095 @ The limit is set at |
10000|
, which should be enough to allow
19096 normal usages of metapost while preventing the most obvious
19097 crashes on most all operating systems
, but the value can be
19098 raised if the runtime system allows a larger C stack.
19099 @^system dependencies@
>
19101 @
<Set initial...@
>=
19102 mp-
>expand_depth
= 10000;
19104 @ Even better would be if the system allows discovery of the amount of
19105 space available on the call stack.
19106 @^system dependencies@
>
19108 In any case
, when the limit is crossed
, that is a fatal error.
19110 @d check_expansion_depth
() if
(++mp-
>expand_depth_count
>= mp-
>expand_depth
)
19111 mp_expansion_depth_error
(mp
)
19114 static void mp_expansion_depth_error
(MP mp
) {
19115 const char
*hlp
[] = {
19116 "Recursive macro expansion cannot be unlimited because of runtime",
19117 "stack constraints. The limit is 10000 recursion levels in total.",
19119 if
( mp-
>interaction
==mp_error_stop_mode
)
19120 mp-
>interaction
=mp_scroll_mode
; /* no more interaction
*/
19121 if
( mp-
>log_opened
)
19122 mp_error
(mp
, "Maximum expansion depth reached", hlp
, true
);
19123 mp-
>history
=mp_fatal_error_stop
;
19128 @ An auxiliary subroutine called |expand| is used by |get_x_next|
19129 when it has to do exotic expansion commands.
19132 static void mp_expand
(MP mp
) {
19133 size_t k
; /* something that we hope is |
<=buf_size|
*/
19134 size_t j
; /* index into |str_pool|
*/
19135 check_expansion_depth
();
19136 if
(number_greater
(internal_value
(mp_tracing_commands
), unity_t
))
19137 if
(cur_cmd
() != mp_defined_macro
)
19139 switch
(cur_cmd
()) {
19141 mp_conditional
(mp
); /* this procedure is discussed in Part
36 below
*/
19143 case mp_fi_or_else
:
19144 @
<Terminate the current conditional and skip to \
&{fi}@>;
19147 @
<Initiate or terminate input from a file@
>;
19150 if
(cur_mod
() == end_for
) {
19151 @
<Scold the user for having an extra \
&{endfor}@>;
19153 mp_begin_iteration
(mp
); /* this procedure is discussed in Part
37 below
*/
19156 case mp_repeat_loop
:
19160 @
<Exit a loop if the proper time has come@
>;
19164 case mp_expand_after
:
19165 @
<Expand the token after the next token@
>;
19167 case mp_scan_tokens
:
19168 @
<Put a string into the input buffer@
>;
19171 @
<Put a script result string into the input buffer@
>;
19173 case mp_defined_macro
:
19174 mp_macro_call
(mp
, cur_mod_node
(), NULL, cur_sym
());
19177 break
; /* make the compiler happy
*/
19178 }; /* there are no other cases
*/
19179 mp-
>expand_depth_count--
;
19183 @ @
<Scold the user...@
>=
19185 const char
*hlp
[] = {
19186 "I'm not currently working on a for loop,",
19187 "so I had better not try to end anything.",
19189 mp_error
(mp
, "Extra `endfor'", hlp
, true
);
19190 @.Extra `endfor'@
>;
19194 @ The processing of \
&{input} involves the |start_input| subroutine,
19195 which will be declared later
; the processing of \
&{endinput} is trivial.
19198 mp_primitive
(mp
, "input", mp_input
, 0);
19199 @
:input_
}{\
&{input} primitive@>;
19200 mp_primitive
(mp
, "endinput", mp_input
, 1);
19201 @
:end_input_
}{\
&{endinput} primitive@>
19204 @ @
<Cases of |print_cmd_mod|...@
>=
19207 mp_print
(mp
, "input");
19209 mp_print
(mp
, "endinput");
19212 @ @
<Initiate or terminate input...@
>=
19214 mp-
>force_eof
= true
;
19216 mp_start_input
(mp
)
19219 @ We'll discuss the complicated parts of loop operations later. For now
19220 it suffices to know that there's a global variable called |loop_ptr|
19221 that will be |
NULL| if no loop is in progress.
19225 while
(token_state
&& (nloc == NULL))
19226 mp_end_token_list
(mp
); /* conserve stack space
*/
19227 if
(mp-
>loop_ptr
== NULL) {
19228 const char
*hlp
[] = {
19229 "I'm confused; after exiting from a loop, I still seem",
19230 "to want to repeat it. I'll try to forget the problem.",
19232 mp_error
(mp
, "Lost loop", hlp
, true
);
19235 mp_resume_iteration
(mp
); /* this procedure is in Part
37 below
*/
19240 @ @
<Exit a loop if the proper time has come@
>=
19242 mp_get_boolean
(mp
);
19243 if
(number_greater
(internal_value
(mp_tracing_commands
), unity_t
))
19244 mp_show_cmd_mod
(mp
, mp_nullary
, cur_exp_value_boolean
());
19245 if
(cur_exp_value_boolean
() == mp_true_code
) {
19246 if
(mp-
>loop_ptr
== NULL) {
19247 const char
*hlp
[] = {
19248 "Why say `exitif' when there's nothing to exit from?",
19250 if
(cur_cmd
() == mp_semicolon
)
19251 mp_error
(mp
, "No loop is in progress", hlp
, true
);
19253 mp_back_error
(mp
, "No loop is in progress", hlp
, true
);
19254 @.No loop is in progress@
>;
19256 @
<Exit prematurely from an iteration@
>;
19258 } else if
(cur_cmd
() != mp_semicolon
) {
19259 const char
*hlp
[] = {
19260 "After `exitif <boolean exp>' I expect to see a semicolon.",
19261 "I shall pretend that one was there.",
19263 mp_back_error
(mp
, "Missing `;' has been inserted", hlp
, true
);
19269 @ Here we use the fact that |forever_text| is the only |token_type| that
19270 is less than |loop_text|.
19272 @
<Exit prematurely...@
>=
19277 mp_end_file_reading
(mp
);
19279 if
(token_type
<= loop_text
)
19281 mp_end_token_list
(mp
);
19283 } while
(p
== NULL);
19284 if
(p
!= mp-
>loop_ptr-
>info
)
19285 mp_fatal_error
(mp
, "*** (loop confusion)");
19286 @.loop confusion@
>;
19287 mp_stop_iteration
(mp
); /* this procedure is in Part
34 below
*/
19291 @ @
<Expand the token after the next token@
>=
19295 p
= mp_cur_tok
(mp
);
19297 if
(cur_cmd
() < mp_min_command
)
19300 mp_back_input
(mp
);
19305 @ @
<Put a string into the input buffer@
>=
19307 mp_get_x_next
(mp
);
19308 mp_scan_primary
(mp
);
19309 if
(mp-
>cur_exp.type
!= mp_string_type
) {
19311 const char
*hlp
[] = {
19312 "I'm going to flush this expression, since",
19313 "scantokens should be followed by a known string.",
19315 memset
(&new_expr,0,sizeof(mp_value));
19316 new_number
(new_expr.data.n
);
19317 mp_disp_err
(mp
, NULL);
19318 mp_back_error
(mp
, "Not a string", hlp
, true
);
19320 mp_get_x_next
(mp
);
19321 mp_flush_cur_exp
(mp
, new_expr
);
19323 mp_back_input
(mp
);
19324 if
(cur_exp_str
()->len
> 0)
19325 @
<Pretend we're reading a new one-line file@
>;
19329 @ @
<Put a script result string into the input buffer@
>=
19331 mp_get_x_next
(mp
);
19332 mp_scan_primary
(mp
);
19333 if
(mp-
>cur_exp.type
!= mp_string_type
) {
19335 const char
*hlp
[] = {
19336 "I'm going to flush this expression, since",
19337 "runscript should be followed by a known string.",
19339 memset
(&new_expr,0,sizeof(mp_value));
19340 new_number
(new_expr.data.n
);
19341 mp_disp_err
(mp
, NULL);
19342 mp_back_error
(mp
, "Not a string", hlp
, true
);
19344 mp_get_x_next
(mp
);
19345 mp_flush_cur_exp
(mp
, new_expr
);
19347 mp_back_input
(mp
);
19348 if
(cur_exp_str
()->len
> 0) {
19350 char
*s
= mp-
>run_script
(mp
,(const char
*) cur_exp_str
()->str
) ;
19352 size_t size
= strlen
(s
);
19353 memset
(&new_expr,0,sizeof(mp_value));
19354 new_number
(new_expr.data.n
);
19355 mp_begin_file_reading
(mp
);
19357 mp-
>last
= mp-
>first
;
19358 k
= mp-
>first
+ size
;
19359 if
(k
>= mp-
>max_buf_stack
) {
19360 while
(k
>= mp-
>buf_size
) {
19361 mp_reallocate_buffer
(mp
, (mp-
>buf_size
+ (mp-
>buf_size
/ 4)));
19363 mp-
>max_buf_stack
= k
+ 1;
19365 limit
= (halfword
) k
;
19366 (void
) memcpy
((mp-
>buffer
+ mp-
>first
), s
, size
);
19368 mp-
>buffer
[limit
] = xord
('
%'
);
19369 mp-
>first
= (size_t
) (limit
+ 1);
19371 mp_flush_cur_exp
(mp
, new_expr
);
19377 @ @
<Pretend we're reading a new one-line file@
>=
19380 memset
(&new_expr,0,sizeof(mp_value));
19381 new_number
(new_expr.data.n
);
19382 mp_begin_file_reading
(mp
);
19384 k
= mp-
>first
+ (size_t
) cur_exp_str
()->len
;
19385 if
(k
>= mp-
>max_buf_stack
) {
19386 while
(k
>= mp-
>buf_size
) {
19387 mp_reallocate_buffer
(mp
, (mp-
>buf_size
+ (mp-
>buf_size
/ 4)));
19389 mp-
>max_buf_stack
= k
+ 1;
19392 limit
= (halfword
) k
;
19393 while
(mp-
>first
< (size_t
) limit
) {
19394 mp-
>buffer
[mp-
>first
] = *(cur_exp_str
()->str
+ j
);
19398 mp-
>buffer
[limit
] = xord
('
%'
);
19399 mp-
>first
= (size_t
) (limit
+ 1);
19401 mp_flush_cur_exp
(mp
, new_expr
);
19405 @ Here finally is |get_x_next|.
19407 The expression scanning routines to be considered later
19408 communicate via the global quantities |cur_type| and |cur_exp|
;
19409 we must be very careful to save and restore these quantities while
19410 macros are being expanded.
19414 static void mp_get_x_next
(MP mp
);
19417 void mp_get_x_next
(MP mp
) {
19418 mp_node save_exp
; /* a capsule to save |cur_type| and |cur_exp|
*/
19420 if
(cur_cmd
() < mp_min_command
) {
19421 save_exp
= mp_stash_cur_exp
(mp
);
19423 if
(cur_cmd
() == mp_defined_macro
)
19424 mp_macro_call
(mp
, cur_mod_node
(), NULL, cur_sym
());
19428 } while
(cur_cmd
() < mp_min_command
);
19429 mp_unstash_cur_exp
(mp
, save_exp
); /* that restores |cur_type| and |cur_exp|
*/
19434 @ Now let's consider the |macro_call| procedure
, which is used to start up
19435 all user-defined macros. Since the arguments to a macro might be expressions
,
19436 |macro_call| is recursive.
19439 The first parameter to |macro_call| points to the reference count of the
19440 token list that defines the macro. The second parameter contains any
19441 arguments that have already been parsed
(see below
). The third parameter
19442 points to the symbolic token that names the macro. If the third parameter
19443 is |
NULL|
, the macro was defined by \
&{vardef}, so its name can be
19444 reconstructed from the prefix and ``at'' arguments found within the
19447 What is this second parameter? It's simply a linked list of symbolic items
,
19448 whose |info| fields point to the arguments. In other words
, if |arg_list
=NULL|
,
19449 no arguments have been scanned yet
; otherwise |mp_info
(arg_list
)| points to
19450 the first scanned argument
, and |mp_link
(arg_list
)| points to the list of
19451 further arguments
(if any
).
19453 Arguments of type \
&{expr} are so-called capsules, which we will
19454 discuss later when we concentrate on expressions
; they can be
19455 recognized easily because their |link| field is |void|. Arguments of type
19456 \
&{suffix} and \&{text} are token lists without reference counts.
19458 @ After argument scanning is complete
, the arguments are moved to the
19459 |param_stack|.
(They can't be put on that stack any sooner
, because
19460 the stack is growing and shrinking in unpredictable ways as more arguments
19461 are being acquired.
) Then the macro body is fed to the scanner
; i.e.
,
19462 the replacement text of the macro is placed at the top of the \MP's
19463 input stack
, so that |get_t_next| will proceed to read it next.
19466 static void mp_macro_call
(MP mp
, mp_node def_ref
, mp_node arg_list
,
19467 mp_sym macro_name
);
19470 void mp_macro_call
(MP mp
, mp_node def_ref
, mp_node arg_list
, mp_sym macro_name
) {
19471 /* invokes a user-defined control sequence
*/
19472 mp_node r
; /* current node in the macro's token list
*/
19473 mp_node p
, q
; /* for list manipulation
*/
19474 integer n
; /* the number of arguments
*/
19475 mp_node tail
= 0; /* tail of the argument list
*/
19476 mp_sym l_delim
= NULL, r_delim
= NULL; /* a delimiter pair
*/
19477 r
= mp_link
(def_ref
);
19478 add_mac_ref
(def_ref
);
19479 if
(arg_list
== NULL) {
19482 @
<Determine the number |n| of arguments already supplied
,
19483 and set |tail| to the tail of |arg_list|@
>;
19485 if
(number_positive
(internal_value
(mp_tracing_macros
))) {
19486 @
<Show the text of the macro being expanded
, and the existing arguments@
>;
19488 @
<Scan the remaining arguments
, if any
; set |r| to the first token
19489 of the replacement text@
>;
19490 @
<Feed the arguments and replacement text to the scanner@
>;
19494 @ @
<Show the text of the macro...@
>=
19495 mp_begin_diagnostic
(mp
);
19497 mp_print_macro_name
(mp
, arg_list
, macro_name
);
19499 mp_print
(mp
, "@@#"); /* indicate a suffixed macro
*/
19500 mp_show_macro
(mp
, def_ref
, NULL, 100000);
19501 if
(arg_list
!= NULL) {
19505 q
= (mp_node
)mp_sym_sym
(p
);
19506 mp_print_arg
(mp
, q
, n
, 0, 0);
19509 } while
(p
!= NULL);
19511 mp_end_diagnostic
(mp
, false
)
19514 @ @
<Declarations@
>=
19515 static void mp_print_macro_name
(MP mp
, mp_node a
, mp_sym n
);
19518 void mp_print_macro_name
(MP mp
, mp_node a
, mp_sym n
) {
19519 mp_node p
, q
; /* they traverse the first part of |a|
*/
19523 p
= (mp_node
)mp_sym_sym
(a
);
19525 mp_print_text
(mp_sym_sym
((mp_node
)mp_sym_sym
(mp_link
(a
))));
19528 while
(mp_link
(q
) != NULL)
19530 mp_link
(q
) = (mp_node
)mp_sym_sym
(mp_link
(a
));
19531 mp_show_token_list
(mp
, p
, NULL, 1000, 0);
19532 mp_link
(q
) = NULL;
19538 @ @
<Declarations@
>=
19539 static void mp_print_arg
(MP mp
, mp_node q
, integer n
, halfword b
,
19543 void mp_print_arg
(MP mp
, mp_node q
, integer n
, halfword b
, quarterword bb
) {
19544 if
(q
&& mp_link (q) == MP_VOID) {
19545 mp_print_nl
(mp
, "(EXPR");
19547 if
((bb
< mp_text_sym
) && (b != mp_text_macro))
19548 mp_print_nl
(mp
, "(SUFFIX");
19550 mp_print_nl
(mp
, "(TEXT");
19552 mp_print_int
(mp
, n
);
19553 mp_print
(mp
, ")<-");
19554 if
(q
&& mp_link (q) == MP_VOID)
19555 mp_print_exp
(mp
, q
, 1);
19557 mp_show_token_list
(mp
, q
, NULL, 1000, 0);
19561 @ @
<Determine the number |n| of arguments already supplied...@
>=
19565 while
(mp_link
(tail
) != NULL) {
19567 tail
= mp_link
(tail
);
19572 @ @
<Scan the remaining arguments
, if any
; set |r|...@
>=
19573 set_cur_cmd
(mp_comma
+ 1); /* anything |
<>comma| will do
*/
19574 while
(mp_name_type
(r
) == mp_expr_sym ||
19575 mp_name_type
(r
) == mp_suffix_sym || mp_name_type
(r
) == mp_text_sym
) {
19576 @
<Scan the delimited argument represented by |mp_sym_info
(r
)|@
>;
19579 if
(cur_cmd
() == mp_comma
) {
19581 const char
*hlp
[] = {
19582 "I'm going to assume that the comma I just read was a",
19583 "right delimiter, and then I'll begin expanding the macro.",
19584 "You might want to delete some tokens before continuing.",
19587 int old_setting
= mp-
>selector
;
19588 mp-
>selector
= new_string
;
19589 mp_print_macro_name
(mp
, arg_list
, macro_name
);
19590 rname
= mp_make_string
(mp
);
19591 mp-
>selector
= old_setting
;
19592 mp_snprintf
(msg
, 256, "Too many arguments to %s; Missing `%s' has been inserted",
19593 mp_str
(mp
, rname
), mp_str
(mp
, text
(r_delim
)));
19594 delete_str_ref
(rname
);
19595 @.Too many arguments...@
>;
19596 @.Missing `
)'...@
>;
19597 mp_error
(mp
, msg
, hlp
, true
);
19599 if
(mp_sym_info
(r
) != mp_general_macro
) {
19600 @
<Scan undelimited argument
(s
)@
>;
19605 @ At this point
, the reader will find it advisable to review the explanation
19606 of token list format that was presented earlier
, paying special attention to
19607 the conventions that apply only at the beginning of a macro's token list.
19609 On the other hand
, the reader will have to take the expression-parsing
19610 aspects of the following program on faith
; we will explain |cur_type|
19611 and |cur_exp| later.
(Several things in this program depend on each other
,
19612 and it's necessary to jump into the circle somewhere.
)
19614 @
<Scan the delimited argument represented by |mp_sym_info
(r
)|@
>=
19615 if
(cur_cmd
() != mp_comma
) {
19616 mp_get_x_next
(mp
);
19617 if
(cur_cmd
() != mp_left_delimiter
) {
19619 const char
*hlp
[] = {
19620 "That macro has more parameters than you thought.",
19621 "I'll continue by pretending that each missing argument",
19622 "is either zero or null.",
19625 int old_setting
= mp-
>selector
;
19626 mp-
>selector
= new_string
;
19627 mp_print_macro_name
(mp
, arg_list
, macro_name
);
19628 sname
= mp_make_string
(mp
);
19629 mp-
>selector
= old_setting
;
19630 mp_snprintf
(msg
, 256, "Missing argument to %s", mp_str
(mp
, sname
));
19631 @.Missing argument...@
>;
19632 delete_str_ref
(sname
);
19633 if
(mp_name_type
(r
) == mp_suffix_sym || mp_name_type
(r
) == mp_text_sym
) {
19634 set_cur_exp_value_number
(zero_t
); /* todo
: this was |null|
*/
19635 mp-
>cur_exp.type
= mp_token_list
;
19637 set_cur_exp_value_number
(zero_t
);
19638 mp-
>cur_exp.type
= mp_known
;
19640 mp_back_error
(mp
, msg
, hlp
, true
);
19641 set_cur_cmd
((mp_variable_type
)mp_right_delimiter
);
19644 l_delim
= cur_sym
();
19645 r_delim
= equiv_sym
(cur_sym
());
19647 @
<Scan the argument represented by |mp_sym_info
(r
)|@
>;
19648 if
(cur_cmd
() != mp_comma
)
19649 @
<Check that the proper right delimiter was present@
>;
19651 @
<Append the current expression to |arg_list|@
>
19654 @ @
<Check that the proper right delim...@
>=
19655 if
((cur_cmd
() != mp_right_delimiter
) ||
(equiv_sym
(cur_sym
()) != l_delim
)) {
19656 if
(mp_name_type
(mp_link
(r
)) == mp_expr_sym ||
19657 mp_name_type
(mp_link
(r
)) == mp_suffix_sym ||
19658 mp_name_type
(mp_link
(r
)) == mp_text_sym
) {
19659 const char
*hlp
[] = {
19660 "I've finished reading a macro argument and am about to",
19661 "read another; the arguments weren't delimited correctly.",
19662 "You might want to delete some tokens before continuing.",
19664 mp_back_error
(mp
, "Missing `,' has been inserted", hlp
, true
);
19666 set_cur_cmd
((mp_variable_type
)mp_comma
);
19669 const char
*hlp
[] = {
19670 "I've gotten to the end of the macro parameter list.",
19671 "You might want to delete some tokens before continuing.",
19673 mp_snprintf
(msg
, 256, "Missing `%s' has been inserted", mp_str
(mp
, text
(r_delim
)));
19675 mp_back_error
(mp
, msg
, hlp
, true
);
19679 @ A \
&{suffix} or \&{text} parameter will have been scanned as
19680 a token list pointed to by |cur_exp|
, in which case we will have
19681 |cur_type
=token_list|.
19683 @
<Append the current expression to |arg_list|@
>=
19685 p
= mp_get_symbolic_node
(mp
);
19686 if
(mp-
>cur_exp.type
== mp_token_list
)
19687 set_mp_sym_sym
(p
, mp-
>cur_exp.data.node
);
19689 set_mp_sym_sym
(p
, mp_stash_cur_exp
(mp
));
19690 if
(number_positive
(internal_value
(mp_tracing_macros
))) {
19691 mp_begin_diagnostic
(mp
);
19692 mp_print_arg
(mp
, (mp_node
)mp_sym_sym
(p
), n
, mp_sym_info
(r
), mp_name_type
(r
));
19693 mp_end_diagnostic
(mp
, false
);
19695 if
(arg_list
== NULL) {
19698 mp_link
(tail
) = p
;
19705 @ @
<Scan the argument represented by |mp_sym_info
(r
)|@
>=
19706 if
(mp_name_type
(r
) == mp_text_sym
) {
19707 mp_scan_text_arg
(mp
, l_delim
, r_delim
);
19709 mp_get_x_next
(mp
);
19710 if
(mp_name_type
(r
) == mp_suffix_sym
)
19711 mp_scan_suffix
(mp
);
19713 mp_scan_expression
(mp
);
19717 @ The parameters to |scan_text_arg| are either a pair of delimiters
19718 or zero
; the latter case is for undelimited text arguments
, which
19719 end with the first semicolon or \
&{endgroup} or \&{end} that is not
19720 contained in a group.
19723 static void mp_scan_text_arg
(MP mp
, mp_sym l_delim
, mp_sym r_delim
);
19726 void mp_scan_text_arg
(MP mp
, mp_sym l_delim
, mp_sym r_delim
) {
19727 integer balance
; /* excess of |l_delim| over |r_delim|
*/
19728 mp_node p
; /* list tail
*/
19729 mp-
>warning_info
= l_delim
;
19730 mp-
>scanner_status
= absorbing
;
19733 mp_link
(mp-
>hold_head
) = NULL;
19736 if
(l_delim
== NULL) {
19737 @
<Adjust the balance for an undelimited argument
; |break| if done@
>;
19739 @
<Adjust the balance for a delimited argument
; |break| if done@
>;
19741 mp_link
(p
) = mp_cur_tok
(mp
);
19744 set_cur_exp_node
(mp_link
(mp-
>hold_head
));
19745 mp-
>cur_exp.type
= mp_token_list
;
19746 mp-
>scanner_status
= normal
;
19750 @ @
<Adjust the balance for a delimited argument...@
>=
19751 if
(cur_cmd
() == mp_right_delimiter
) {
19752 if
(equiv_sym
(cur_sym
()) == l_delim
) {
19757 } else if
(cur_cmd
() == mp_left_delimiter
) {
19758 if
(equiv_sym
(cur_sym
()) == r_delim
)
19762 @ @
<Adjust the balance for an undelimited...@
>=
19763 if
(mp_end_of_statement
) { /* |cur_cmd
=semicolon|
, |end_group|
, or |stop|
*/
19764 if
(balance
== 1) {
19767 if
(cur_cmd
() == mp_end_group
)
19770 } else if
(cur_cmd
() == mp_begin_group
) {
19774 @ @
<Scan undelimited argument
(s
)@
>=
19776 if
(mp_sym_info
(r
) < mp_text_macro
) {
19777 mp_get_x_next
(mp
);
19778 if
(mp_sym_info
(r
) != mp_suffix_macro
) {
19779 if
((cur_cmd
() == mp_equals
) ||
(cur_cmd
() == mp_assignment
))
19780 mp_get_x_next
(mp
);
19783 switch
(mp_sym_info
(r
)) {
19784 case mp_primary_macro
:
19785 mp_scan_primary
(mp
);
19787 case mp_secondary_macro
:
19788 mp_scan_secondary
(mp
);
19790 case mp_tertiary_macro
:
19791 mp_scan_tertiary
(mp
);
19793 case mp_expr_macro
:
19794 mp_scan_expression
(mp
);
19797 @
<Scan an expression followed by `\
&{of} $\langle$primary$\rangle$'@>;
19799 case mp_suffix_macro
:
19800 @
<Scan a suffix with optional delimiters@
>;
19802 case mp_text_macro
:
19803 mp_scan_text_arg
(mp
, NULL, NULL);
19805 } /* there are no other cases
*/
19806 mp_back_input
(mp
);
19807 @
<Append the current expression to |arg_list|@
>;
19811 @ @
<Scan an expression followed by `\
&{of} $\langle$primary$\rangle$'@>=
19813 mp_scan_expression
(mp
);
19814 p
= mp_get_symbolic_node
(mp
);
19815 set_mp_sym_sym
(p
, mp_stash_cur_exp
(mp
));
19816 if
(number_positive
(internal_value
(mp_tracing_macros
))) {
19817 mp_begin_diagnostic
(mp
);
19818 mp_print_arg
(mp
, (mp_node
)mp_sym_sym
(p
), n
, 0, 0);
19819 mp_end_diagnostic
(mp
, false
);
19821 if
(arg_list
== NULL)
19824 mp_link
(tail
) = p
;
19827 if
(cur_cmd
() != mp_of_token
) {
19830 const char
*hlp
[] = {
19831 "I've got the first argument; will look now for the other.",
19833 int old_setting
= mp-
>selector
;
19834 mp-
>selector
= new_string
;
19835 mp_print_macro_name
(mp
, arg_list
, macro_name
);
19836 sname
= mp_make_string
(mp
);
19837 mp-
>selector
= old_setting
;
19838 mp_snprintf
(msg
, 256, "Missing `of' has been inserted for %s", mp_str
(mp
, sname
));
19839 delete_str_ref
(sname
);
19841 mp_back_error
(mp
, msg
, hlp
, true
);
19843 mp_get_x_next
(mp
);
19844 mp_scan_primary
(mp
);
19848 @ @
<Scan a suffix with optional delimiters@
>=
19850 if
(cur_cmd
() != mp_left_delimiter
) {
19853 l_delim
= cur_sym
();
19854 r_delim
= equiv_sym
(cur_sym
());
19855 mp_get_x_next
(mp
);
19857 mp_scan_suffix
(mp
);
19858 if
(l_delim
!= NULL) {
19859 if
((cur_cmd
() != mp_right_delimiter
) ||
(equiv_sym
(cur_sym
()) != l_delim
)) {
19861 const char
*hlp
[] = {
19862 "I've gotten to the end of the macro parameter list.",
19863 "You might want to delete some tokens before continuing.",
19865 mp_snprintf
(msg
, 256, "Missing `%s' has been inserted", mp_str
(mp
, text
(r_delim
)));
19867 mp_back_error
(mp
, msg
, hlp
, true
);
19869 mp_get_x_next
(mp
);
19874 @ Before we put a new token list on the input stack
, it is wise to clean off
19875 all token lists that have recently been depleted. Then a user macro that ends
19876 with a call to itself will not require unbounded stack space.
19878 @
<Feed the arguments and replacement text to the scanner@
>=
19879 while
(token_state
&& (nloc == NULL))
19880 mp_end_token_list
(mp
); /* conserve stack space
*/
19881 if
(mp-
>param_ptr
+ n
> mp-
>max_param_stack
) {
19882 mp-
>max_param_stack
= mp-
>param_ptr
+ n
;
19883 mp_check_param_size
(mp
, mp-
>max_param_stack
);
19884 @
:MetaPost capacity exceeded parameter stack size
}{\quad parameter stack size@
>
19886 mp_begin_token_list
(mp
, def_ref
, (quarterword
) macro
);
19888 name
= text
(macro_name
);
19895 mp-
>param_stack
[mp-
>param_ptr
] = (mp_node
)mp_sym_sym
(p
);
19896 incr
(mp-
>param_ptr
);
19898 } while
(p
!= NULL);
19899 mp_flush_node_list
(mp
, arg_list
);
19902 @ It's sometimes necessary to put a single argument onto |param_stack|.
19903 The |stack_argument| subroutine does this.
19906 static void mp_stack_argument
(MP mp
, mp_node p
) {
19907 if
(mp-
>param_ptr
== mp-
>max_param_stack
) {
19908 incr
(mp-
>max_param_stack
);
19909 mp_check_param_size
(mp
, mp-
>max_param_stack
);
19911 mp-
>param_stack
[mp-
>param_ptr
] = p
;
19912 incr
(mp-
>param_ptr
);
19916 @
* Conditional processing.
19917 Let's consider now the way \
&{if} commands are handled.
19919 Conditions can be inside conditions
, and this nesting has a stack
19920 that is independent of other stacks.
19921 Four global variables represent the top of the condition stack
:
19922 |cond_ptr| points to pushed-down entries
, if~any
; |cur_if| tells whether
19923 we are processing \
&{if} or \&{elseif}; |if_limit| specifies
19924 the largest code of a |fi_or_else| command that is syntactically legal
;
19925 and |if_line| is the line number at which the current conditional began.
19927 If no conditions are currently in progress
, the condition stack has the
19928 special state |cond_ptr
=NULL|
, |if_limit
=normal|
, |cur_if
=0|
, |if_line
=0|.
19929 Otherwise |cond_ptr| points to a non-symbolic node
; the |type|
, |name_type|
, and
19930 |link| fields of the first word contain |if_limit|
, |cur_if|
, and
19931 |cond_ptr| at the next level
, and the second word contains the
19932 corresponding |if_line|.
19934 @d if_line_field
(A
) ((mp_if_node
)(A
))->if_line_field_
19935 @d if_code
1 /* code for \
&{if} being evaluated */
19936 @d fi_code
2 /* code for \
&{fi} */
19937 @d else_code
3 /* code for \
&{else} */
19938 @d else_if_code
4 /* code for \
&{elseif} */
19940 @
<MPlib internal header stuff@
>=
19941 typedef struct mp_if_node_data
{
19943 int if_line_field_
;
19945 typedef struct mp_if_node_data
*mp_if_node
;
19948 @d if_node_size sizeof
(struct mp_if_node_data
) /* number of words in stack entry for conditionals
*/
19951 static mp_node mp_get_if_node
(MP mp
) {
19952 mp_if_node p
= (mp_if_node
) malloc_node
(if_node_size
);
19953 mp_type
(p
) = mp_if_node_type
;
19954 return
(mp_node
) p
;
19959 mp_node cond_ptr
; /* top of the condition stack
*/
19960 integer if_limit
; /* upper bound on |fi_or_else| codes
*/
19961 quarterword cur_if
; /* type of conditional being worked on
*/
19962 integer if_line
; /* line where that conditional began
*/
19965 mp-
>cond_ptr
= NULL;
19966 mp-
>if_limit
= normal
;
19971 mp_primitive
(mp
, "if", mp_if_test
, if_code
);
19972 @
:if_
}{\
&{if} primitive@>;
19973 mp_primitive
(mp
, "fi", mp_fi_or_else
, fi_code
);
19974 mp-
>frozen_fi
= mp_frozen_primitive
(mp
, "fi", mp_fi_or_else
, fi_code
);
19975 @
:fi_
}{\
&{fi} primitive@>;
19976 mp_primitive
(mp
, "else", mp_fi_or_else
, else_code
);
19977 @
:else_
}{\
&{else} primitive@>;
19978 mp_primitive
(mp
, "elseif", mp_fi_or_else
, else_if_code
);
19979 @
:else_if_
}{\
&{elseif} primitive@>
19982 @ @
<Cases of |print_cmd_mod|...@
>=
19984 case mp_fi_or_else
:
19987 mp_print
(mp
, "if");
19990 mp_print
(mp
, "fi");
19993 mp_print
(mp
, "else");
19996 mp_print
(mp
, "elseif");
20001 @ Here is a procedure that ignores text until coming to an \
&{elseif},
20002 \
&{else}, or \&{fi} at level zero of $\&{if}\ldots\&{fi}$
20003 nesting. After it has acted
, |cur_mod| will indicate the token that
20006 \MP's smallest two command codes are |if_test| and |fi_or_else|
; this
20007 makes the skipping process a bit simpler.
20010 void mp_pass_text
(MP mp
) {
20012 mp-
>scanner_status
= skipping
;
20013 mp-
>warning_line
= mp_true_line
(mp
);
20016 if
(cur_cmd
() <= mp_fi_or_else
) {
20017 if
(cur_cmd
() < mp_fi_or_else
) {
20022 if
(cur_mod
() == fi_code
)
20026 @
<Decrease the string reference count
,
20027 if the current token is a string@
>;
20030 mp-
>scanner_status
= normal
;
20034 @ @
<Decrease the string reference count...@
>=
20035 if
(cur_cmd
() == mp_string_token
) {
20036 delete_str_ref
(cur_mod_str
());
20039 @ When we begin to process a new \
&{if}, we set |if_limit:=if_code|; then
20040 if \
&{elseif} or \&{else} or \&{fi} occurs before the current \&{if}
20041 condition has been evaluated
, a colon will be inserted.
20042 A construction like `\.
{if fi
}' would otherwise get \MP\ confused.
20044 @
<Push the condition stack@
>=
20046 p
= mp_get_if_node
(mp
);
20047 mp_link
(p
) = mp-
>cond_ptr
;
20048 mp_type
(p
) = (quarterword
) mp-
>if_limit
;
20049 mp_name_type
(p
) = mp-
>cur_if
;
20050 if_line_field
(p
) = mp-
>if_line
;
20052 mp-
>if_limit
= if_code
;
20053 mp-
>if_line
= mp_true_line
(mp
);
20054 mp-
>cur_if
= if_code
;
20058 @ @
<Pop the condition stack@
>=
20060 mp_node p
= mp-
>cond_ptr
;
20061 mp-
>if_line
= if_line_field
(p
);
20062 mp-
>cur_if
= mp_name_type
(p
);
20063 mp-
>if_limit
= mp_type
(p
);
20064 mp-
>cond_ptr
= mp_link
(p
);
20065 mp_free_node
(mp
, p
, if_node_size
);
20069 @ Here's a procedure that changes the |if_limit| code corresponding to
20070 a given value of |cond_ptr|.
20073 static void mp_change_if_limit
(MP mp
, quarterword l
, mp_node p
) {
20075 if
(p
== mp-
>cond_ptr
) {
20076 mp-
>if_limit
= l
; /* that's the easy case
*/
20081 mp_confusion
(mp
, "if");
20082 @
:this can't happen if
}{\quad if@
>;
20083 /* clang
: dereference of null pointer
*/ assert
(q
);
20084 if
(mp_link
(q
) == p
) {
20094 @ The user is supposed to put colons into the proper parts of conditional
20095 statements. Therefore
, \MP\ has to check for their presence.
20098 static void mp_check_colon
(MP mp
) {
20099 if
(cur_cmd
() != mp_colon
) {
20100 const char
*hlp
[] = {
20101 "There should've been a colon after the condition.",
20102 "I shall pretend that one was there.",
20104 mp_back_error
(mp
, "Missing `:' has been inserted", hlp
, true
);
20110 @ A condition is started when the |get_x_next| procedure encounters
20111 an |if_test| command
; in that case |get_x_next| calls |conditional|
,
20112 which is a recursive procedure.
20116 void mp_conditional
(MP mp
) {
20117 mp_node save_cond_ptr
; /* |cond_ptr| corresponding to this conditional
*/
20118 int new_if_limit
; /* future value of |if_limit|
*/
20119 mp_node p
; /* temporary register
*/
20120 @
<Push the condition stack@
>;
20121 save_cond_ptr
= mp-
>cond_ptr
;
20123 mp_get_boolean
(mp
);
20124 new_if_limit
= else_if_code
;
20125 if
(number_greater
(internal_value
(mp_tracing_commands
), unity_t
)) {
20126 @
<Display the boolean value of |cur_exp|@
>;
20129 mp_check_colon
(mp
);
20130 if
(cur_exp_value_boolean
() == mp_true_code
) {
20131 mp_change_if_limit
(mp
, (quarterword
) new_if_limit
, save_cond_ptr
);
20132 return
; /* wait for \
&{elseif}, \&{else}, or \&{fi} */
20134 @
<Skip to \
&{elseif} or \&{else} or \&{fi}, then |goto done|@>;
20136 mp-
>cur_if
= (quarterword
) cur_mod
();
20137 mp-
>if_line
= mp_true_line
(mp
);
20138 if
(cur_mod
() == fi_code
) {
20139 @
<Pop the condition stack@
>
20140 } else if
(cur_mod
() == else_if_code
) {
20143 set_cur_exp_value_boolean
(mp_true_code
);
20144 new_if_limit
= fi_code
;
20145 mp_get_x_next
(mp
);
20151 @ In a construction like `\
&{if} \&{if} \&{true}: $0=1$: \\{foo}
20152 \
&{else}: \\{bar} \&{fi}', the first \&{else}
20153 that we come to after learning that the \
&{if} is false is not the
20154 \
&{else} we're looking for. Hence the following curious logic is needed.
20156 @
<Skip to \
&{elseif}...@>=
20159 if
(mp-
>cond_ptr
== save_cond_ptr
)
20161 else if
(cur_mod
() == fi_code
)
20162 @
<Pop the condition stack@
>;
20166 @ @
<Display the boolean value...@
>=
20168 mp_begin_diagnostic
(mp
);
20169 if
(cur_exp_value_boolean
() == mp_true_code
)
20170 mp_print
(mp
, "{true}");
20172 mp_print
(mp
, "{false}");
20173 mp_end_diagnostic
(mp
, false
);
20177 @ The processing of conditionals is complete except for the following
20178 code
, which is actually part of |get_x_next|. It comes into play when
20179 \
&{elseif}, \&{else}, or \&{fi} is scanned.
20181 @
<Terminate the current conditional and skip to \
&{fi}@>=
20182 if
(cur_mod
() > mp-
>if_limit
) {
20183 if
(mp-
>if_limit
== if_code
) { /* condition not yet evaluated
*/
20184 const char
*hlp
[] = { "Something was missing here", NULL };
20185 mp_back_input
(mp
);
20186 set_cur_sym
(mp-
>frozen_colon
);
20187 mp_ins_error
(mp
, "Missing `:' has been inserted", hlp
, true
);
20190 const char
*hlp
[] = {"I'm ignoring this; it doesn't match any if.", NULL};
20191 if
(cur_mod
() == fi_code
) {
20192 mp_error
(mp
, "Extra fi", hlp
, true
);
20194 } else if
(cur_mod
() == else_code
) {
20195 mp_error
(mp
, "Extra else", hlp
, true
);
20198 mp_error
(mp
, "Extra elseif", hlp
, true
);
20203 while
(cur_mod
() != fi_code
)
20204 mp_pass_text
(mp
); /* skip to \
&{fi} */
20205 @
<Pop the condition stack@
>;
20210 To bring our treatment of |get_x_next| to a close
, we need to consider what
20211 \MP\ does when it sees \
&{for}, \&{forsuffixes}, and \&{forever}.
20213 There's a global variable |loop_ptr| that keeps track of the \
&{for} loops
20214 that are currently active. If |loop_ptr
=NULL|
, no loops are in progress
;
20215 otherwise |loop_ptr.info| points to the iterative text of the current
20216 (innermost
) loop
, and |loop_ptr.link| points to the data for any other
20217 loops that enclose the current one.
20219 A loop-control node also has two other fields
, called |type| and
20220 |list|
, whose contents depend on the type of loop
:
20222 \yskip\indent|loop_ptr.type
=NULL| means that the link of |loop_ptr.list|
20223 points to a list of symbolic nodes whose |info| fields point to the
20224 remaining argument values of a suffix list and expression list.
20225 In this case
, an extra field |loop_ptr.start_list| is needed to
20226 make sure that |resume_operation| skips ahead.
20228 \yskip\indent|loop_ptr.type
=MP_VOID| means that the current loop is
20231 \yskip\indent|loop_ptr.type
=PROGRESSION_FLAG| means that
20232 |loop_ptr.value|
, |loop_ptr.step_size|
, and |loop_ptr.final_value|
20233 contain the data for an arithmetic progression.
20235 \yskip\indent|loop_ptr.type
=p
>PROGRESSION_FLAG| means that |p| points to an edge
20236 header and |loop_ptr.list| points into the graphical object list for
20239 @d PROGRESSION_FLAG
(mp_node
)(2) /* |
NULL+2|
*/
20240 /* |loop_type| value when |loop_list| points to a progression node
*/
20243 typedef struct mp_loop_data
{
20244 mp_node info
; /* iterative text of this loop
*/
20245 mp_node type
; /* the special type of this loop
, or a pointer into
20247 mp_node list
; /* the remaining list elements
*/
20248 mp_node list_start
; /* head fo the list of elements
*/
20249 mp_number value
; /* current arithmetic value
*/
20250 mp_number step_size
; /* arithmetic step size
*/
20251 mp_number final_value
; /* end arithmetic value
*/
20252 struct mp_loop_data
*link
; /* the enclosing loop
, if any
*/
20256 mp_loop_data
*loop_ptr
; /* top of the loop-control-node stack
*/
20259 mp-
>loop_ptr
= NULL;
20261 @ If the expressions that define an arithmetic progression in a
20262 \
&{for} loop don't have known numeric values, the |bad_for| subroutine
20263 screams at the user.
20266 static void mp_bad_for
(MP mp
, const char
*s
) {
20269 const char
*hlp
[] = {"When you say `for x=a step b until c',",
20270 "the initial value `a' and the step size `b'",
20271 "and the final value `c' must have known numeric values.",
20272 "I'm zeroing this one. Proceed, with fingers crossed.",
20274 memset
(&new_expr,0,sizeof(mp_value));
20275 new_number
(new_expr.data.n
);
20276 mp_disp_err
(mp
, NULL);
20277 /* show the bad expression above the message
*/
20278 mp_snprintf
(msg
, 256, "Improper %s has been replaced by 0", s
);
20279 @.Improper...replaced by
0@
>;
20280 mp_back_error
(mp
, msg
, hlp
, true
);
20281 mp_get_x_next
(mp
);
20282 mp_flush_cur_exp
(mp
, new_expr
);
20286 @ Here's what \MP\ does when \
&{for}, \&{forsuffixes}, or \&{forever}
20287 has just been scanned.
(This code requires slight familiarity with
20288 expression-parsing routines that we have not yet discussed
; but it
20289 seems to belong in the present part of the program
, even though the
20290 original author didn't write it until later. The reader may wish to
20294 void mp_begin_iteration
(MP mp
) {
20295 halfword m
; /* |start_for|
(\
&{for}) or |start_forsuffixes|
20296 (\
&{forsuffixes}) */
20297 mp_sym n
; /* hash address of the current symbol
*/
20298 mp_loop_data
*s
; /* the new loop-control node
*/
20299 mp_subst_list_item
*p
= NULL; /* substitution list for |scan_toks|
20301 mp_node q
; /* link manipulation register
*/
20304 s
= xmalloc
(1, sizeof
(mp_loop_data
));
20305 s-
>type
= s-
>list
= s-
>info
= s-
>list_start
= NULL;
20307 new_number
(s-
>value
);
20308 new_number
(s-
>step_size
);
20309 new_number
(s-
>final_value
);
20310 if
(m
== start_forever
) {
20313 mp_get_x_next
(mp
);
20315 mp_get_symbol
(mp
);
20316 p
= xmalloc
(1, sizeof
(mp_subst_list_item
));
20318 p-
>info
= cur_sym
();
20319 p-
>info_mod
= cur_sym_mod
();
20321 if
(m
== start_for
) {
20322 p-
>value_mod
= mp_expr_sym
;
20323 } else
{ /* |start_forsuffixes|
*/
20324 p-
>value_mod
= mp_suffix_sym
;
20326 mp_get_x_next
(mp
);
20327 if
(cur_cmd
() == mp_within_token
) {
20328 @
<Set up a picture iteration@
>;
20330 @
<Check for the assignment in a loop header@
>;
20331 @
<Scan the values to be used in the loop@
>;
20334 @
<Check for the presence of a colon@
>;
20335 @
<Scan the loop text and put it on the loop control stack@
>;
20336 mp_resume_iteration
(mp
);
20340 @ @
<Check for the assignment in a loop header@
>=
20341 if
((cur_cmd
() != mp_equals
) && (cur_cmd() != mp_assignment)) {
20342 const char
*hlp
[] = {
20343 "The next thing in this loop should have been `=' or `:='.",
20344 "But don't worry; I'll pretend that an equals sign",
20345 "was present, and I'll look for the values next.",
20347 mp_back_error
(mp
, "Missing `=' has been inserted", hlp
, true
);
20351 @ @
<Check for the presence of a colon@
>=
20352 if
(cur_cmd
() != mp_colon
) {
20353 const char
*hlp
[] = {
20354 "The next thing in this loop should have been a `:'.",
20355 "So I'll pretend that a colon was present;",
20356 "everything from here to `endfor' will be iterated.",
20358 mp_back_error
(mp
, "Missing `:' has been inserted", hlp
, true
);
20362 @ We append a special |mp-
>frozen_repeat_loop| token in place of the
20363 `\
&{endfor}' at the end of the loop. This will come through \MP's
20364 scanner at the proper time to cause the loop to be repeated.
20366 (If the user tries some shenanigan like `\
&{for} $\ldots$ \&{let}
20367 \
&{endfor}', he will be foiled by the |get_symbol| routine, which
20368 keeps frozen tokens unchanged. Furthermore the
20369 |mp-
>frozen_repeat_loop| is an \
&{outer} token, so it won't be lost
20372 @ @
<Scan the loop text...@
>=
20373 q
= mp_get_symbolic_node
(mp
);
20374 set_mp_sym_sym
(q
, mp-
>frozen_repeat_loop
);
20375 mp-
>scanner_status
= loop_defining
;
20376 mp-
>warning_info
= n
;
20377 s-
>info
= mp_scan_toks
(mp
, mp_iteration
, p
, q
, 0);
20378 mp-
>scanner_status
= normal
;
20379 s-
>link
= mp-
>loop_ptr
;
20382 @ @
<Initialize table...@
>=
20383 mp-
>frozen_repeat_loop
=
20384 mp_frozen_primitive
(mp
, " ENDFOR", mp_repeat_loop
+ mp_outer_tag
, 0);
20386 @ The loop text is inserted into \MP's scanning apparatus by the
20387 |resume_iteration| routine.
20390 void mp_resume_iteration
(MP mp
) {
20391 mp_node p
, q
; /* link registers
*/
20392 p
= mp-
>loop_ptr-
>type
;
20393 if
(p
== PROGRESSION_FLAG
) {
20394 set_cur_exp_value_number
(mp-
>loop_ptr-
>value
);
20395 if
(@
<The arithmetic progression has ended@
>) {
20396 mp_stop_iteration
(mp
);
20399 mp-
>cur_exp.type
= mp_known
;
20400 q
= mp_stash_cur_exp
(mp
); /* make |q| an \
&{expr} argument */
20401 set_number_from_addition
(mp-
>loop_ptr-
>value
, cur_exp_value_number
(), mp-
>loop_ptr-
>step_size
);
20402 /* set |value
(p
)| for the next iteration
*/
20403 /* detect numeric overflow
*/
20404 if
(number_positive
(mp-
>loop_ptr-
>step_size
) &&
20405 number_less
(mp-
>loop_ptr-
>value
, cur_exp_value_number
())) {
20406 if
(number_positive
(mp-
>loop_ptr-
>final_value
)) {
20407 number_clone
(mp-
>loop_ptr-
>value
, mp-
>loop_ptr-
>final_value
);
20408 number_add_scaled
(mp-
>loop_ptr-
>final_value
, -1);
20410 number_clone
(mp-
>loop_ptr-
>value
, mp-
>loop_ptr-
>final_value
);
20411 number_add_scaled
(mp-
>loop_ptr-
>value
, 1);
20413 } else if
(number_negative
(mp-
>loop_ptr-
>step_size
) &&
20414 number_greater
(mp-
>loop_ptr-
>value
, cur_exp_value_number
())) {
20415 if
(number_negative
(mp-
>loop_ptr-
>final_value
)) {
20416 number_clone
(mp-
>loop_ptr-
>value
, mp-
>loop_ptr-
>final_value
);
20417 number_add_scaled
(mp-
>loop_ptr-
>final_value
, 1);
20419 number_clone
(mp-
>loop_ptr-
>value
, mp-
>loop_ptr-
>final_value
);
20420 number_add_scaled
(mp-
>loop_ptr-
>value
, -1);
20423 } else if
(p
== NULL) {
20424 p
= mp-
>loop_ptr-
>list
;
20425 if
(p
!= NULL && p == mp->loop_ptr->list_start) {
20428 mp_free_symbolic_node
(mp
, q
);
20429 mp-
>loop_ptr-
>list
= p
;
20432 mp_stop_iteration
(mp
);
20435 mp-
>loop_ptr-
>list
= mp_link
(p
);
20436 q
= (mp_node
)mp_sym_sym
(p
);
20437 mp_free_symbolic_node
(mp
, p
);
20438 } else if
(p
== MP_VOID
) {
20439 mp_begin_token_list
(mp
, mp-
>loop_ptr-
>info
, (quarterword
) forever_text
);
20442 @
<Make |q| a capsule containing the next picture component from
20443 |loop_list
(loop_ptr
)| or |goto not_found|@
>;
20445 mp_begin_token_list
(mp
, mp-
>loop_ptr-
>info
, (quarterword
) loop_text
);
20446 mp_stack_argument
(mp
, q
);
20447 if
(number_greater
(internal_value
(mp_tracing_commands
), unity_t
)) {
20448 @
<Trace the start of a loop@
>;
20452 mp_stop_iteration
(mp
);
20456 @ @
<The arithmetic progression has ended@
>=
20457 (number_positive
(mp-
>loop_ptr-
>step_size
) && number_greater(cur_exp_value_number (), mp->loop_ptr->final_value))
20459 (number_negative
(mp-
>loop_ptr-
>step_size
) && number_less(cur_exp_value_number (), mp->loop_ptr->final_value))
20462 @ @
<Trace the start of a loop@
>=
20464 mp_begin_diagnostic
(mp
);
20465 mp_print_nl
(mp
, "{loop value=");
20467 if
((q
!= NULL) && (mp_link (q) == MP_VOID))
20468 mp_print_exp
(mp
, q
, 1);
20470 mp_show_token_list
(mp
, q
, NULL, 50, 0);
20471 mp_print_char
(mp
, xord
('
}'
));
20472 mp_end_diagnostic
(mp
, false
);
20476 @ @
<Make |q| a capsule containing the next picture component
20479 q
= mp-
>loop_ptr-
>list
;
20482 if
( ! is_start_or_stop
(q
) )
20484 else if
( ! is_stop
(q
) )
20485 q
=mp_skip_1component
(mp
, q
);
20489 set_cur_exp_node
((mp_node
)mp_copy_objects
(mp
, mp-
>loop_ptr-
>list
, q
));
20490 mp_init_bbox
(mp
, (mp_edge_header_node
)cur_exp_node
());
20491 mp-
>cur_exp.type
= mp_picture_type
;
20492 mp-
>loop_ptr-
>list
= q
;
20493 q
= mp_stash_cur_exp
(mp
);
20497 @ A level of loop control disappears when |resume_iteration| has
20498 decided not to resume
, or when an \
&{exitif} construction has removed
20499 the loop text from the input stack.
20502 void mp_stop_iteration
(MP mp
) {
20503 mp_node p
, q
; /* the usual
*/
20504 mp_loop_data
*tmp
; /* for free
() */
20505 p
= mp-
>loop_ptr-
>type
;
20506 if
(p
== PROGRESSION_FLAG
) {
20507 mp_free_symbolic_node
(mp
, mp-
>loop_ptr-
>list
);
20508 } else if
(p
== NULL) {
20509 q
= mp-
>loop_ptr-
>list
;
20510 while
(q
!= NULL) {
20511 p
= (mp_node
)mp_sym_sym
(q
);
20513 if
(mp_link
(p
) == MP_VOID
) { /* it's an \
&{expr} parameter */
20514 mp_recycle_value
(mp
, p
);
20515 mp_free_value_node
(mp
, p
);
20517 mp_flush_token_list
(mp
, p
); /* it's a \
&{suffix} or \&{text}
20523 mp_free_symbolic_node
(mp
, p
);
20525 } else if
(p
> PROGRESSION_FLAG
) {
20526 delete_edge_ref
(p
);
20528 tmp
= mp-
>loop_ptr
;
20529 mp-
>loop_ptr
= tmp-
>link
;
20530 mp_flush_token_list
(mp
, tmp-
>info
);
20531 free_number
(tmp-
>value
);
20532 free_number
(tmp-
>step_size
);
20533 free_number
(tmp-
>final_value
);
20538 @ Now that we know all about loop control
, we can finish up the
20539 missing portion of |begin_iteration| and we'll be done.
20541 The following code is performed after the `\.
=' has been scanned in a
20542 \
&{for} construction (if |m=start_for|) or a \&{forsuffixes}
20543 construction
(if |m
=start_forsuffixes|
).
20545 @
<Scan the values to be used in the loop@
>=
20547 s-
>list
= mp_get_symbolic_node
(mp
);
20548 s-
>list_start
= s-
>list
;
20551 mp_get_x_next
(mp
);
20552 if
(m
!= start_for
) {
20553 mp_scan_suffix
(mp
);
20555 if
(cur_cmd
() >= mp_colon
)
20556 if
(cur_cmd
() <= mp_comma
)
20558 mp_scan_expression
(mp
);
20559 if
(cur_cmd
() == mp_step_token
)
20560 if
(q
== s-
>list
) {
20561 @
<Prepare for step-until construction and |break|@
>;
20563 set_cur_exp_node
(mp_stash_cur_exp
(mp
));
20565 mp_link
(q
) = mp_get_symbolic_node
(mp
);
20567 set_mp_sym_sym
(q
, mp-
>cur_exp.data.node
);
20568 if
(m
== start_for
)
20569 mp_name_type
(q
) = mp_expr_sym
;
20570 else if
(m
== start_forsuffixes
)
20571 mp_name_type
(q
) = mp_suffix_sym
;
20572 mp-
>cur_exp.type
= mp_vacuous
;
20575 } while
(cur_cmd
() == mp_comma
)
20577 @ @
<Prepare for step-until construction and |break|@
>=
20579 if
(mp-
>cur_exp.type
!= mp_known
)
20580 mp_bad_for
(mp
, "initial value");
20581 number_clone
(s-
>value
, cur_exp_value_number
());
20582 mp_get_x_next
(mp
);
20583 mp_scan_expression
(mp
);
20584 if
(mp-
>cur_exp.type
!= mp_known
)
20585 mp_bad_for
(mp
, "step size");
20586 number_clone
(s-
>step_size
, cur_exp_value_number
());
20587 if
(cur_cmd
() != mp_until_token
) {
20588 const char
*hlp
[] = {
20589 "I assume you meant to say `until' after `step'.",
20590 "So I'll look for the final value and colon next.",
20592 mp_back_error
(mp
, "Missing `until' has been inserted", hlp
, true
);
20593 @.Missing `until'@
>;
20595 mp_get_x_next
(mp
);
20596 mp_scan_expression
(mp
);
20597 if
(mp-
>cur_exp.type
!= mp_known
)
20598 mp_bad_for
(mp
, "final value");
20599 number_clone
(s-
>final_value
, cur_exp_value_number
());
20600 s-
>type
= PROGRESSION_FLAG
;
20605 @ The last case is when we have just seen ``\
&{within}'', and we need to
20606 parse a picture expression and prepare to iterate over it.
20608 @
<Set up a picture iteration@
>=
20610 mp_get_x_next
(mp
);
20611 mp_scan_expression
(mp
);
20612 @
<Make sure the current expression is a known picture@
>;
20613 s-
>type
= mp-
>cur_exp.data.node
;
20614 mp-
>cur_exp.type
= mp_vacuous
;
20615 q
= mp_link
(edge_list
(mp-
>cur_exp.data.node
));
20617 if
(is_start_or_stop
(q
))
20618 if
(mp_skip_1component
(mp
, q
) == NULL)
20624 @ @
<Make sure the current expression is a known picture@
>=
20625 if
(mp-
>cur_exp.type
!= mp_picture_type
) {
20627 const char
*hlp
[] = { "When you say `for x in p', p must be a known picture.", NULL };
20628 memset
(&new_expr,0,sizeof(mp_value));
20629 new_number
(new_expr.data.n
);
20630 new_expr.data.node
= (mp_node
)mp_get_edge_header_node
(mp
);
20631 mp_disp_err
(mp
, NULL);
20632 mp_back_error
(mp
,"Improper iteration spec has been replaced by nullpicture", hlp
, true
);
20633 mp_get_x_next
(mp
);
20634 mp_flush_cur_exp
(mp
, new_expr
);
20635 mp_init_edges
(mp
, (mp_edge_header_node
)mp-
>cur_exp.data.node
);
20636 mp-
>cur_exp.type
= mp_picture_type
;
20640 It's time now to fret about file names. Besides the fact that different
20641 operating systems treat files in different ways
, we must cope with the
20642 fact that completely different naming conventions are used by different
20643 groups of people. The following programs show what is required for one
20644 particular operating system
; similar routines for other systems are not
20645 difficult to devise.
20646 @^system dependencies@
>
20648 \MP\ assumes that a file name has three parts
: the name proper
; its
20649 ``extension''
; and a ``file area'' where it is found in an external file
20650 system. The extension of an input file is assumed to be
20651 `\.
{.mp
}' unless otherwise specified
; it is `\.
{.log
}' on the
20652 transcript file that records each run of \MP
; it is `\.
{.tfm
}' on the font
20653 metric files that describe characters in any fonts created by \MP
; it is
20654 `\.
{.ps
}' or `.
{\it nnn
}' for some number
{\it nnn
} on the \ps\ output files.
20655 The file area can be arbitrary on input files
, but files are usually
20656 output to the user's current area. If an input file cannot be
20657 found on the specified area
, \MP\ will look for it on a special system
20658 area
; this special area is intended for commonly used input files.
20660 Simple uses of \MP\ refer only to file names that have no explicit
20661 extension or area. For example
, a person usually says `\.
{input
} \.
{cmr10
}'
20662 instead of `\.
{input
} \.
{cmr10.new
}'. Simple file
20663 names are best
, because they make the \MP\ source files portable
;
20664 whenever a file name consists entirely of letters and digits
, it should be
20665 treated in the same way by all implementations of \MP. However
, users
20666 need the ability to refer to other files in their environment
, especially
20667 when responding to error messages concerning unopenable files
; therefore
20668 we want to let them use the syntax that appears in their favorite
20671 @ \MP\ uses the same conventions that have proved to be satisfactory for
20672 \TeX\ and \MF. In order to isolate the system-dependent aspects of file names
,
20673 @^system dependencies@
>
20674 the system-independent parts of \MP\ are expressed in terms
20675 of three system-dependent
20676 procedures called |begin_name|
, |more_name|
, and |end_name|. In
20677 essence
, if the user-specified characters of the file name are $c_1\ldots c_n$
,
20678 the system-independent driver program does the operations
20679 $$|begin_name|
;\
,|more_name|
(c_1
);\
,\ldots\
,;\
,|more_name|
(c_n
);
20681 These three procedures communicate with each other via global variables.
20682 Afterwards the file name will appear in the string pool as three strings
20683 called |cur_name|\penalty10000\hskip-
.05em
,
20684 |cur_area|
, and |cur_ext|
; the latter two are
NULL (i.e.
,
20685 |
""|
), unless they were explicitly specified by the user.
20687 Actually the situation is slightly more complicated
, because \MP\ needs
20688 to know when the file name ends. The |more_name| routine is a function
20689 (with side effects
) that returns |true| on the calls |more_name|$
(c_1
)$
,
20690 \dots
, |more_name|$
(c_
{n-1
})$. The final call |more_name|$
(c_n
)$
20691 returns |false|
; or
, it returns |true| and $c_n$ is the last character
20692 on the current input line. In other words
,
20693 |more_name| is supposed to return |true| unless it is sure that the
20694 file name has been completely scanned
; and |end_name| is supposed to be able
20695 to finish the assembly of |cur_name|
, |cur_area|
, and |cur_ext| regardless of
20696 whether $|more_name|
(c_n
)$ returned |true| or |false|.
20699 char
*cur_name
; /* name of file just scanned
*/
20700 char
*cur_area
; /* file area just scanned
, or \.
{""} */
20701 char
*cur_ext
; /* file extension just scanned
, or \.
{""} */
20703 @ It is easier to maintain reference counts if we assign initial values.
20706 mp-
>cur_name
= xstrdup
("");
20707 mp-
>cur_area
= xstrdup
("");
20708 mp-
>cur_ext
= xstrdup
("");
20710 @ @
<Dealloc variables@
>=
20711 xfree
(mp-
>cur_area
);
20712 xfree
(mp-
>cur_name
);
20713 xfree
(mp-
>cur_ext
);
20715 @ The file names we shall deal with for illustrative purposes have the
20716 following structure
: If the name contains `\.
>' or `\.
:'
, the file area
20717 consists of all characters up to and including the final such character
;
20718 otherwise the file area is null. If the remaining file name contains
20719 `\..'
, the file extension consists of all such characters from the first
20720 remaining `\..' to the end
, otherwise the file extension is null.
20721 @^system dependencies@
>
20723 We can scan such file names easily by using two global variables that keep track
20724 of the occurrences of area and extension delimiters.
20727 integer area_delimiter
;
20728 /* most recent `\.
>' or `\.
:' relative to |str_start
[str_ptr
]|
*/
20729 integer ext_delimiter
; /* the relevant `\..'
, if any
*/
20730 boolean quoted_filename
; /* whether the filename is wrapped in
" markers */
20732 @ Here now is the first of the system-dependent routines for file name scanning.
20733 @^system dependencies@>
20736 static void mp_begin_name (MP mp);
20737 static boolean mp_more_name (MP mp, ASCII_code c);
20738 static void mp_end_name (MP mp);
20741 void mp_begin_name (MP mp) {
20742 xfree (mp->cur_name);
20743 xfree (mp->cur_area);
20744 xfree (mp->cur_ext);
20745 mp->area_delimiter = -1;
20746 mp->ext_delimiter = -1;
20747 mp->quoted_filename = false;
20751 @ And here's the second.
20752 @^system dependencies@>
20756 #define IS_DIR_SEP(c) (c=='/' || c=='\\')
20758 boolean mp_more_name (MP mp, ASCII_code c) {
20760 mp-
>quoted_filename
= !mp-
>quoted_filename
;
20761 } else if
((c
== ' ' || c
== '\t'
) && (mp->quoted_filename == false)) {
20764 if
(IS_DIR_SEP
(c
)) {
20765 mp-
>area_delimiter
= (integer
) mp-
>cur_length
;
20766 mp-
>ext_delimiter
= -1;
20767 } else if
(c
== '.'
) {
20768 mp-
>ext_delimiter
= (integer
) mp-
>cur_length
;
20770 append_char
(c
); /* contribute |c| to the current string
*/
20777 @^system dependencies@
>
20779 @d copy_pool_segment
(A
,B
,C
) {
20780 A
= xmalloc
(C
+1,sizeof
(char
));
20781 (void
)memcpy
(A
,(char
*)(mp-
>cur_string
+B
),C
);
20785 void mp_end_name
(MP mp
) {
20786 size_t s
= 0; /* length of area
, name
, and extension
*/
20789 if
(mp-
>area_delimiter
< 0) {
20790 mp-
>cur_area
= xstrdup
("");
20792 len
= (size_t
) mp-
>area_delimiter
- s
+ 1;
20793 copy_pool_segment
(mp-
>cur_area
, s
, len
);
20796 if
(mp-
>ext_delimiter
< 0) {
20797 mp-
>cur_ext
= xstrdup
("");
20798 len
= (unsigned
) (mp-
>cur_length
- s
);
20800 copy_pool_segment
(mp-
>cur_ext
, mp-
>ext_delimiter
,
20801 (mp-
>cur_length
- (size_t
) mp-
>ext_delimiter
));
20802 len
= (size_t
) mp-
>ext_delimiter
- s
;
20804 copy_pool_segment
(mp-
>cur_name
, s
, len
);
20805 mp_reset_cur_string
(mp
);
20809 @ Conversely
, here is a routine that takes three strings and prints a file
20810 name that might have produced them.
(The routine is system dependent
, because
20811 some operating systems put the file area last instead of first.
)
20812 @^system dependencies@
>
20814 @
<Basic printing...@
>=
20815 static void mp_print_file_name
(MP mp
, char
*n
, char
*a
, char
*e
) {
20816 boolean must_quote
= false
;
20817 if
(((a
!= NULL) && (strchr (a, ' ') != NULL)) ||
20818 ((n
!= NULL) && (strchr (n, ' ') != NULL)) ||
20819 ((e
!= NULL) && (strchr (e, ' ') != NULL)))
20822 mp_print_char
(mp
, (ASCII_code
) '
"');
20827 mp_print_char (mp, (ASCII_code) '"'
);
20831 @ Another system-dependent routine is needed to convert three internal
20833 to the |name_of_file| value that is used to open files. The present code
20834 allows both lowercase and uppercase letters in the file name.
20835 @^system dependencies@
>
20837 @d append_to_name
(A
) { mp-
>name_of_file
[k
++]=(char
)xchr
(xord
((ASCII_code
)(A
))); }
20840 void mp_pack_file_name
(MP mp
, const char
*n
, const char
*a
, const char
*e
) {
20841 integer k
; /* number of positions filled in |name_of_file|
*/
20842 const char
*j
; /* a character index
*/
20845 assert
(n
!= NULL);
20846 xfree
(mp-
>name_of_file
);
20847 slen
= strlen
(n
) + 1;
20849 slen
+= strlen
(a
);
20851 slen
+= strlen
(e
);
20852 mp-
>name_of_file
= xmalloc
(slen
, 1);
20854 for
(j
= a
; *j
!= '\
0'
; j
++) {
20855 append_to_name
(*j
);
20858 for
(j
= n
; *j
!= '\
0'
; j
++) {
20859 append_to_name
(*j
);
20862 for
(j
= e
; *j
!= '\
0'
; j
++) {
20863 append_to_name
(*j
);
20866 mp-
>name_of_file
[k
] = 0;
20870 @ @
<Internal library declarations@
>=
20871 void mp_pack_file_name
(MP mp
, const char
*n
, const char
*a
, const char
*e
);
20873 @ @
<Option variables@
>=
20874 char
*mem_name
; /* for commandline
*/
20876 @ Stripping a |.mem| extension here is for backward compatibility.
20878 @
<Find and load preload file
, if required@
>=
20879 if
(!opt-
>ini_version
) {
20880 mp-
>mem_name
= xstrdup
(opt-
>mem_name
);
20881 if
(mp-
>mem_name
) {
20882 size_t l
= strlen
(mp-
>mem_name
);
20884 char
*test
= strstr
(mp-
>mem_name
, ".mem");
20885 if
(test
== mp-
>mem_name
+ l
- 4) {
20890 if
(mp-
>mem_name
!= NULL) {
20891 if
(!mp_open_mem_file
(mp
)) {
20892 mp-
>history
= mp_fatal_error_stop
;
20900 @ @
<Dealloc variables@
>=
20901 xfree
(mp-
>mem_name
);
20903 @ This part of the program becomes active when a ``virgin'' \MP\ is
20904 trying to get going
, just after the preliminary initialization.
20905 The buffer contains the first line of input in |buffer
[loc..
(last-1
)]|
,
20906 where |loc
<last| and |buffer
[loc
]<>""|.
20909 static boolean mp_open_mem_name
(MP mp
);
20910 static boolean mp_open_mem_file
(MP mp
);
20913 boolean mp_open_mem_name
(MP mp
) {
20914 if
(mp-
>mem_name
!= NULL) {
20915 size_t l
= strlen
(mp-
>mem_name
);
20916 char
*s
= xstrdup
(mp-
>mem_name
);
20918 char
*test
= strstr
(s
, ".mp");
20919 if
(test
== NULL || test
!= s
+ l
- 4) {
20920 s
= xrealloc
(s
, l
+ 5, 1);
20924 s
= xrealloc
(s
, l
+ 5, 1);
20927 s
= (mp-
>find_file
) (mp
, s
, "r", mp_filetype_program
);
20928 xfree
(mp-
>name_of_file
);
20931 mp-
>name_of_file
= xstrdup
(s
);
20932 mp-
>mem_file
= (mp-
>open_file
) (mp
, s
, "r", mp_filetype_program
);
20939 boolean mp_open_mem_file
(MP mp
) {
20940 if
(mp-
>mem_file
!= NULL)
20942 if
(mp_open_mem_name
(mp
))
20944 if
(mp_xstrcmp
(mp-
>mem_name
, "plain")) {
20945 wake_up_terminal
();
20946 wterm
("Sorry, I can\'t find the '");
20947 wterm
(mp-
>mem_name
);
20948 wterm
("' preload file; will try 'plain'.");
20950 @.Sorry
, I can't find...@
>;
20952 /* now pull out all the stops
: try for the system \.
{plain
} file
*/
20953 xfree
(mp-
>mem_name
);
20954 mp-
>mem_name
= xstrdup
("plain");
20955 if
(mp_open_mem_name
(mp
))
20958 wake_up_terminal
();
20959 wterm_ln
("I can't find the 'plain' preload file!\n");
20960 @.I can't find PLAIN...@
>
20966 @ Operating systems often make it possible to determine the exact name
(and
20967 possible version number
) of a file that has been opened. The following routine
,
20968 which simply makes a \MP\ string from the value of |name_of_file|
, should
20969 ideally be changed to deduce the full name of file~|f|
, which is the file
20970 most recently opened
, if it is possible to do this.
20971 @^system dependencies@
>
20974 static mp_string mp_make_name_string
(MP mp
) {
20975 int k
; /* index into |name_of_file|
*/
20976 int name_length
= (int
) strlen
(mp-
>name_of_file
);
20977 str_room
(name_length
);
20978 for
(k
= 0; k
< name_length
; k
++) {
20979 append_char
(xord
((ASCII_code
) mp-
>name_of_file
[k
]));
20981 return mp_make_string
(mp
);
20985 @ Now let's consider the ``driver''
20986 routines by which \MP\ deals with file names
20987 in a system-independent manner. First comes a procedure that looks for a
20988 file name in the input by taking the information from the input buffer.
20989 (We can't use |get_next|
, because the conversion to tokens would
20990 destroy necessary information.
)
20992 This procedure doesn't allow semicolons or percent signs to be part of
20993 file names
, because of other conventions of \MP.
20994 {\sl The
{\logos METAFONT\
/}book
} doesn't
20995 use semicolons or percents immediately after file names
, but some users
20996 no doubt will find it natural to do so
; therefore system-dependent
20997 changes to allow such characters in file names should probably
20998 be made with reluctance
, and only when an entire file name that
20999 includes special characters is ``quoted'' somehow.
21000 @^system dependencies@
>
21003 static void mp_scan_file_name
(MP mp
) {
21004 mp_begin_name
(mp
);
21005 while
(mp-
>buffer
[loc
] == ' '
)
21008 if
((mp-
>buffer
[loc
] == '
;'
) ||
(mp-
>buffer
[loc
] == '
%'
))
21010 if
(!mp_more_name
(mp
, mp-
>buffer
[loc
]))
21018 @ Here is another version that takes its input from a string.
21020 @
<Declare subroutines for parsing file names@
>=
21021 void mp_str_scan_file
(MP mp
, mp_string s
);
21024 void mp_str_scan_file
(MP mp
, mp_string s
) {
21025 size_t p
, q
; /* current position and stopping point
*/
21026 mp_begin_name
(mp
);
21030 if
(!mp_more_name
(mp
, *(s-
>str
+ p
)))
21038 @ And one that reads from a |char
*|.
21040 @
<Declare subroutines for parsing file names@
>=
21041 extern void mp_ptr_scan_file
(MP mp
, char
*s
);
21044 void mp_ptr_scan_file
(MP mp
, char
*s
) {
21045 char
*p
, *q
; /* current position and stopping point
*/
21046 mp_begin_name
(mp
);
21048 q
= p
+ strlen
(s
);
21050 if
(!mp_more_name
(mp
, (ASCII_code
) (*p
)))
21058 @ The option variable |job_name| contains the file name that was first
21059 \
&{input} by the user. This name is used to initialize the |job_name| global
21060 as well as the |mp_job_name| internal
, and is extended by `\.
{.log
}' and
21061 `\.
{ps
}' and `\.
{.mem
}' and `\.
{.tfm
}' in order to make the names of \MP's
21065 boolean log_opened
; /* has the transcript file been opened?
*/
21066 char
*log_name
; /* full name of the log file
*/
21068 @ @
<Option variables@
>=
21069 char
*job_name
; /* principal file name
*/
21071 @ Initially |job_name
=NULL|
; it becomes nonzero as soon as the true name is known.
21072 We have |job_name
=NULL| if and only if the `\.
{log
}' file has not been opened
,
21073 except of course for a short time just after |job_name| has become nonzero.
21075 @
<Allocate or ...@
>=
21076 mp-
>job_name
= mp_xstrdup
(mp
, opt-
>job_name
);
21078 if
(mp-
>job_name
!= NULL) {
21079 char
*s
= mp-
>job_name
+ strlen
(mp-
>job_name
);
21080 while
(s
> mp-
>job_name
) {
21088 if
(opt-
>noninteractive
) {
21089 if
(mp-
>job_name
== NULL)
21090 mp-
>job_name
= mp_xstrdup
(mp
, mp-
>mem_name
);
21092 mp-
>log_opened
= false
;
21094 @ Cannot do this earlier because at the |
<Allocate or ...
>|
, the string
21095 pool is not yet initialized.
21097 @
<Fix up |mp-
>internal
[mp_job_name
]|@
>=
21098 if
(mp-
>job_name
!= NULL) {
21099 if
(internal_string
(mp_job_name
) != 0)
21100 delete_str_ref
(internal_string
(mp_job_name
));
21101 set_internal_string
(mp_job_name
, mp_rts
(mp
, mp-
>job_name
));
21104 @ @
<Dealloc variables@
>=
21105 xfree
(mp-
>job_name
);
21107 @ Here is a routine that manufactures the output file names
, assuming that
21108 |job_name
<>0|. It ignores and changes the current settings of |cur_area|
21111 @d pack_cur_name mp_pack_file_name
(mp
, mp-
>cur_name
,mp-
>cur_area
,mp-
>cur_ext
)
21113 @
<Internal library ...@
>=
21114 void mp_pack_job_name
(MP mp
, const char
*s
);
21117 void mp_pack_job_name
(MP mp
, const char
*s
) { /* |s
= ".log"|
, |
".mem"|
, |
".ps"|
, or .\\
{nnn
} */
21118 xfree
(mp-
>cur_name
);
21119 mp-
>cur_name
= xstrdup
(mp-
>job_name
);
21120 xfree
(mp-
>cur_area
);
21121 mp-
>cur_area
= xstrdup
("");
21122 xfree
(mp-
>cur_ext
);
21123 mp-
>cur_ext
= xstrdup
(s
);
21128 @ If some trouble arises when \MP\ tries to open a file
, the following
21129 routine calls upon the user to supply another file name. Parameter~|s|
21130 is used in the error message to identify the type of file
; parameter~|e|
21131 is the default extension if none is given. Upon exit from the routine
,
21132 variables |cur_name|
, |cur_area|
, |cur_ext|
, and |name_of_file| are
21133 ready for another attempt at file opening.
21135 @
<Internal library ...@
>=
21136 void mp_prompt_file_name
(MP mp
, const char
*s
, const char
*e
);
21139 void mp_prompt_file_name
(MP mp
, const char
*s
, const char
*e
) {
21140 size_t k
; /* index into |buffer|
*/
21141 char
*saved_cur_name
;
21142 if
(mp-
>interaction
== mp_scroll_mode
)
21143 wake_up_terminal
();
21144 if
(strcmp
(s
, "input file name") == 0) {
21145 mp_print_err
(mp
, "I can\'t open file `");
21146 @.I can't find file x@
>
21148 mp_print_err
(mp
, "I can\'t write on file `");
21149 @.I can't write on file x@
>
21151 if
(strcmp
(s
, "file name for output") == 0) {
21152 mp_print
(mp
, mp-
>name_of_file
);
21154 mp_print_file_name
(mp
, mp-
>cur_name
, mp-
>cur_area
, mp-
>cur_ext
);
21156 mp_print
(mp
, "'.");
21157 if
(strcmp
(e
, "") == 0)
21158 mp_show_context
(mp
);
21159 mp_print_nl
(mp
, "Please type another ");
21161 @.Please type...@
>;
21162 if
(mp-
>noninteractive || mp-
>interaction
< mp_scroll_mode
)
21163 mp_fatal_error
(mp
, "*** (job aborted, file error in nonstop mode)");
21164 @.job aborted
, file error...@
>;
21165 saved_cur_name
= xstrdup
(mp-
>cur_name
);
21167 prompt_input
(": ");
21168 @
<Scan file name in the buffer@
>;
21169 if
(strcmp
(mp-
>cur_ext
, "") == 0)
21170 mp-
>cur_ext
= xstrdup
(e
);
21171 if
(strlen
(mp-
>cur_name
) == 0) {
21172 mp-
>cur_name
= saved_cur_name
;
21174 xfree
(saved_cur_name
);
21180 @ @
<Scan file name in the buffer@
>=
21182 mp_begin_name
(mp
);
21184 while
((mp-
>buffer
[k
] == ' '
) && (k < mp->last))
21189 if
(!mp_more_name
(mp
, mp-
>buffer
[k
]))
21197 @ The |open_log_file| routine is used to open the transcript file and to help
21198 it catch up to what has previously been printed on the terminal.
21201 void mp_open_log_file
(MP mp
) {
21202 unsigned old_setting
; /* previous |selector| setting
*/
21203 int k
; /* index into |months| and |buffer|
*/
21204 int l
; /* end of first input line
*/
21205 integer m
; /* the current month
*/
21206 const char
*months
= "JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC";
21207 /* abbreviations of month names
*/
21208 if
(mp-
>log_opened
)
21210 old_setting
= mp-
>selector
;
21211 if
(mp-
>job_name
== NULL) {
21212 mp-
>job_name
= xstrdup
("mpout");
21213 @
<Fix up |mp-
>internal
[mp_job_name
]|@
>;
21215 mp_pack_job_name
(mp
, ".log");
21216 while
(!mp_open_out
(mp
, &mp->log_file, mp_filetype_log)) {
21217 @
<Try to get a different log file name@
>;
21219 mp-
>log_name
= xstrdup
(mp-
>name_of_file
);
21220 mp-
>selector
= log_only
;
21221 mp-
>log_opened
= true
;
21222 @
<Print the banner line
, including the date and time@
>;
21223 mp-
>input_stack
[mp-
>input_ptr
] = mp-
>cur_input
;
21224 /* make sure bottom level is in memory
*/
21225 if
(!mp-
>noninteractive
) {
21226 mp_print_nl
(mp
, "**");
21228 l
= mp-
>input_stack
[0].limit_field
- 1; /* last position of first line
*/
21229 for
(k
= 0; k
<= l
; k
++)
21230 mp_print_char
(mp
, mp-
>buffer
[k
]);
21231 mp_print_ln
(mp
); /* now the transcript file contains the first line of input
*/
21233 mp-
>selector
= old_setting
+ 2; /* |log_only| or |term_and_log|
*/
21237 @ @
<Dealloc variables@
>=
21238 xfree
(mp-
>log_name
);
21240 @ Sometimes |open_log_file| is called at awkward moments when \MP\ is
21241 unable to print error messages or even to |show_context|.
21242 The |prompt_file_name| routine can result in a |fatal_error|
, but the |error|
21243 routine will not be invoked because |log_opened| will be false.
21245 The normal idea of |mp_batch_mode| is that nothing at all should be written
21246 on the terminal. However
, in the unusual case that
21247 no log file could be opened
, we make an exception and allow
21248 an explanatory message to be seen.
21250 Incidentally
, the program always refers to the log file as a `\.
{transcript
21251 file
}'
, because some systems cannot use the extension `\.
{.log
}' for
21254 @
<Try to get a different log file name@
>=
21256 mp-
>selector
= term_only
;
21257 mp_prompt_file_name
(mp
, "transcript file name", ".log");
21261 @ @
<Print the banner...@
>=
21264 mp_print
(mp
, " ");
21265 mp_print_int
(mp
, round_unscaled
(internal_value
(mp_day
)));
21266 mp_print_char
(mp
, xord
(' '
));
21267 m
= round_unscaled
(internal_value
(mp_month
));
21268 for
(k
= 3 * m
- 3; k
< 3 * m
; k
++) {
21269 wlog_chr
((unsigned char
) months
[k
]);
21271 mp_print_char
(mp
, xord
(' '
));
21272 mp_print_int
(mp
, round_unscaled
(internal_value
(mp_year
)));
21273 mp_print_char
(mp
, xord
(' '
));
21274 mp_print_dd
(mp
, round_unscaled
(internal_value
(mp_hour
)));
21275 mp_print_char
(mp
, xord
('
:'
));
21276 mp_print_dd
(mp
, round_unscaled
(internal_value
(mp_minute
)));
21280 @ The |try_extension| function tries to open an input file determined by
21281 |cur_name|
, |cur_area|
, and the argument |ext|. It returns |false| if it
21282 can't find the file in |cur_area| or the appropriate system area.
21285 static boolean mp_try_extension
(MP mp
, const char
*ext
) {
21286 mp_pack_file_name
(mp
, mp-
>cur_name
, mp-
>cur_area
, ext
);
21287 in_name
= xstrdup
(mp-
>cur_name
);
21288 in_area
= xstrdup
(mp-
>cur_area
);
21289 in_ext
= xstrdup
(ext
);
21290 if
(mp_open_in
(mp
, &cur_file, mp_filetype_program)) {
21293 mp_pack_file_name
(mp
, mp-
>cur_name
, NULL, ext
);
21294 return mp_open_in
(mp
, &cur_file, mp_filetype_program);
21299 @ Let's turn now to the procedure that is used to initiate file reading
21300 when an `\.
{input
}' command is being processed.
21303 void mp_start_input
(MP mp
) { /* \MP\ will \.
{input
} something
*/
21304 char
*fname
= NULL;
21305 @
<Put the desired file name in |
(cur_name
,cur_ext
,cur_area
)|@
>;
21307 mp_begin_file_reading
(mp
); /* set up |cur_file| and new level of input
*/
21308 if
(strlen
(mp-
>cur_ext
) == 0) {
21309 if
(mp_try_extension
(mp
, ".mp"))
21311 else if
(mp_try_extension
(mp
, ""))
21313 else if
(mp_try_extension
(mp
, ".mf"))
21315 } else if
(mp_try_extension
(mp
, mp-
>cur_ext
)) {
21318 mp_end_file_reading
(mp
); /* remove the level that didn't work
*/
21319 mp_prompt_file_name
(mp
, "input file name", "");
21321 name
= mp_make_name_string
(mp
);
21322 fname
= xstrdup
(mp-
>name_of_file
);
21323 if
(mp-
>job_name
== NULL) {
21324 mp-
>job_name
= xstrdup
(mp-
>cur_name
);
21325 @
<Fix up |mp-
>internal
[mp_job_name
]|@
>;
21327 if
(!mp-
>log_opened
) {
21328 mp_open_log_file
(mp
);
21329 } /* |open_log_file| doesn't |show_context|
, so |limit|
21330 and |loc| needn't be set to meaningful values yet
*/
21331 if
(((int
) mp-
>term_offset
+ (int
) strlen
(fname
)) > (mp-
>max_print_line
- 2))
21333 else if
((mp-
>term_offset
> 0) ||
(mp-
>file_offset
> 0))
21334 mp_print_char
(mp
, xord
(' '
));
21335 mp_print_char
(mp
, xord
('
('
));
21336 incr
(mp-
>open_parens
);
21337 mp_print
(mp
, fname
);
21340 @
<Flush |name| and replace it with |cur_name| if it won't be needed@
>;
21341 @
<Read the first line of the new file@
>;
21345 @ This code should be omitted if |make_name_string| returns something other
21346 than just a copy of its argument and the full file name is needed for opening
21347 \.
{MPX
} files or implementing the switch-to-editor option.
21348 @^system dependencies@
>
21350 @
<Flush |name| and replace it with |cur_name| if it won't be needed@
>=
21351 mp_flush_string
(mp
, name
);
21352 name
= mp_rts
(mp
, mp-
>cur_name
);
21353 xfree
(mp-
>cur_name
)
21356 @ If the file is empty
, it is considered to contain a single blank line
,
21357 so there is no need to test the return value.
21359 @
<Read the first line...@
>=
21362 (void
) mp_input_ln
(mp
, cur_file
);
21363 mp_firm_up_the_line
(mp
);
21364 mp-
>buffer
[limit
] = xord
('
%'
);
21365 mp-
>first
= (size_t
) (limit
+ 1);
21370 @ @
<Put the desired file name in |
(cur_name
,cur_ext
,cur_area
)|@
>=
21371 while
(token_state
&& (nloc == NULL))
21372 mp_end_token_list
(mp
);
21374 const char
*hlp
[] = {
21375 "Sorry...I've converted what follows to tokens,",
21376 "possibly garbaging the name you gave.",
21377 "Please delete the tokens and insert the name again.",
21379 mp_error
(mp
, "File names can't appear within macros", hlp
, true
);
21380 @.File names can't...@
>;
21383 mp_scan_file_name
(mp
);
21385 xfree
(mp-
>cur_name
);
21386 mp-
>cur_name
= xstrdup
("");
21387 xfree
(mp-
>cur_ext
);
21388 mp-
>cur_ext
= xstrdup
("");
21389 xfree
(mp-
>cur_area
);
21390 mp-
>cur_area
= xstrdup
("");
21394 @ The following simple routine starts reading the \.
{MPX
} file associated
21395 with the current input file.
21398 void mp_start_mpx_input
(MP mp
) {
21399 char
*origname
= NULL; /* a copy of nameoffile
*/
21400 mp_pack_file_name
(mp
, in_name
, in_area
, in_ext
);
21401 origname
= xstrdup
(mp-
>name_of_file
);
21402 mp_pack_file_name
(mp
, in_name
, in_area
, ".mpx");
21403 if
(!(mp-
>run_make_mpx
) (mp
, origname
, mp-
>name_of_file
))
21405 mp_begin_file_reading
(mp
);
21406 if
(!mp_open_in
(mp
, &cur_file, mp_filetype_program)) {
21407 mp_end_file_reading
(mp
);
21410 name
= mp_make_name_string
(mp
);
21411 mp-
>mpx_name
[iindex
] = name
;
21412 add_str_ref
(name
);
21413 @
<Read the first line of the new file@
>;
21417 @
<Explain that the \.
{MPX
} file can't be read and |succumb|@
>;
21422 @ This should ideally be changed to do whatever is necessary to create the
21423 \.
{MPX
} file given by |name_of_file| if it does not exist or if it is out
21424 of date. This requires invoking \.
{MPtoTeX
} on the |origname| and passing
21425 the results through \TeX\ and \.
{DVItoMP
}.
(It is possible to use a
21426 completely different typesetting program if suitable postprocessor is
21427 available to perform the function of \.
{DVItoMP
}.
)
21428 @^system dependencies@
>
21430 @ @
<Exported types@
>=
21431 typedef int
(*mp_makempx_cmd
) (MP mp
, char
*origname
, char
*mtxname
);
21433 @ @
<Option variables@
>=
21434 mp_makempx_cmd run_make_mpx
;
21436 @ @
<Allocate or initialize ...@
>=
21437 set_callback_option
(run_make_mpx
);
21439 @ @
<Declarations@
>=
21440 static int mp_run_make_mpx
(MP mp
, char
*origname
, char
*mtxname
);
21442 @ The default does nothing.
21444 int mp_run_make_mpx
(MP mp
, char
*origname
, char
*mtxname
) {
21452 @ @
<Explain that the \.
{MPX
} file can't be read and |succumb|@
>=
21454 const char
*hlp
[] = {
21455 "The two files given above are one of your source files",
21456 "and an auxiliary file I need to read to find out what your",
21457 "btex..etex blocks mean. If you don't know why I had trouble,",
21458 "try running it manually through MPtoTeX, TeX, and DVItoMP",
21460 if
(mp-
>interaction
== mp_error_stop_mode
)
21461 wake_up_terminal
();
21462 mp_print_nl
(mp
, ">> ");
21463 mp_print
(mp
, origname
);
21464 mp_print_nl
(mp
, ">> ");
21465 mp_print
(mp
, mp-
>name_of_file
);
21467 if
( mp-
>interaction
==mp_error_stop_mode
)
21468 mp-
>interaction
=mp_scroll_mode
; /* no more interaction
*/
21469 if
( mp-
>log_opened
)
21470 mp_error
(mp
, "! Unable to read mpx file", hlp
, true
);
21471 mp-
>history
=mp_fatal_error_stop
;
21472 mp_jump_out
(mp
); /* irrecoverable error
*/
21475 @ The last file-opening commands are for files accessed via the \
&{readfrom}
21476 @
:read_from_
}{\
&{readfrom} primitive@>
21477 operator and the \
&{write} command. Such files are stored in separate arrays.
21478 @
:write_
}{\
&{write} primitive@>
21480 @
<Types in the outer block@
>=
21481 typedef unsigned int readf_index
; /* |
0..max_read_files|
*/
21482 typedef unsigned int write_index
; /* |
0..max_write_files|
*/
21485 readf_index max_read_files
; /* maximum number of simultaneously open \
&{readfrom} files */
21486 void
**rd_file
; /* \
&{readfrom} files */
21487 char
**rd_fname
; /* corresponding file name or
0 if file not open
*/
21488 readf_index read_files
; /* number of valid entries in the above arrays
*/
21489 write_index max_write_files
; /* maximum number of simultaneously open \
&{write} */
21490 void
**wr_file
; /* \
&{write} files */
21491 char
**wr_fname
; /* corresponding file name or
0 if file not open
*/
21492 write_index write_files
; /* number of valid entries in the above arrays
*/
21494 @ @
<Allocate or initialize ...@
>=
21495 mp-
>max_read_files
= 8;
21496 mp-
>rd_file
= xmalloc
((mp-
>max_read_files
+ 1), sizeof
(void
*));
21497 mp-
>rd_fname
= xmalloc
((mp-
>max_read_files
+ 1), sizeof
(char
*));
21498 memset
(mp-
>rd_fname
, 0, sizeof
(char
*) * (mp-
>max_read_files
+ 1));
21499 mp-
>max_write_files
= 8;
21500 mp-
>wr_file
= xmalloc
((mp-
>max_write_files
+ 1), sizeof
(void
*));
21501 mp-
>wr_fname
= xmalloc
((mp-
>max_write_files
+ 1), sizeof
(char
*));
21502 memset
(mp-
>wr_fname
, 0, sizeof
(char
*) * (mp-
>max_write_files
+ 1));
21505 @ This routine starts reading the file named by string~|s| without setting
21506 |loc|
, |limit|
, or |name|. It returns |false| if the file is empty or cannot
21507 be opened. Otherwise it updates |rd_file
[n
]| and |rd_fname
[n
]|.
21510 static boolean mp_start_read_input
(MP mp
, char
*s
, readf_index n
) {
21511 mp_ptr_scan_file
(mp
, s
);
21513 mp_begin_file_reading
(mp
);
21514 if
(!mp_open_in
(mp
, &mp->rd_file[n], (int) (mp_filetype_text + n)))
21516 if
(!mp_input_ln
(mp
, mp-
>rd_file
[n
])) {
21517 (mp-
>close_file
) (mp
, mp-
>rd_file
[n
]);
21520 mp-
>rd_fname
[n
] = xstrdup
(s
);
21523 mp_end_file_reading
(mp
);
21528 @ Open |wr_file
[n
]| using file name~|s| and update |wr_fname
[n
]|.
21531 static void mp_open_write_file
(MP mp
, char
*s
, readf_index n
);
21534 void mp_open_write_file
(MP mp
, char
*s
, readf_index n
) {
21535 mp_ptr_scan_file
(mp
, s
);
21537 while
(!mp_open_out
(mp
, &mp->wr_file[n], (int) (mp_filetype_text + n)))
21538 mp_prompt_file_name
(mp
, "file name for write output", "");
21539 mp-
>wr_fname
[n
] = xstrdup
(s
);
21543 @
* Introduction to the parsing routines.
21544 We come now to the central nervous system that sparks many of \MP's activities.
21545 By evaluating expressions
, from their primary constituents to ever larger
21546 subexpressions
, \MP\ builds the structures that ultimately define complete
21547 pictures or fonts of type.
21549 Four mutually recursive subroutines are involved in this process
: We call them
21550 $$\hbox
{|scan_primary|
, |scan_secondary|
, |scan_tertiary|
,
21551 and |scan_expression|.
}$$
21553 Each of them is parameterless and begins with the first token to be scanned
21554 already represented in |cur_cmd|
, |cur_mod|
, and |cur_sym|. After execution
,
21555 the value of the primary or secondary or tertiary or expression that was
21556 found will appear in the global variables |cur_type| and |cur_exp|. The
21557 token following the expression will be represented in |cur_cmd|
, |cur_mod|
,
21560 Technically speaking
, the parsing algorithms are ``LL
(1),'' more or less
;
21561 backup mechanisms have been added in order to provide reasonable error
21564 @d cur_exp_value_boolean
() number_to_int
(mp-
>cur_exp.data.n
)
21565 @d cur_exp_value_number
() mp-
>cur_exp.data.n
21566 @d cur_exp_node
() mp-
>cur_exp.data.node
21567 @d cur_exp_str
() mp-
>cur_exp.data.str
21568 @d cur_exp_knot
() mp-
>cur_exp.data.p
21570 @d set_cur_exp_value_scaled
(A
) do
{
21571 if
(cur_exp_str
()) {
21572 delete_str_ref
(cur_exp_str
());
21574 set_number_from_scaled
(mp-
>cur_exp.data.n
, (A
));
21575 cur_exp_node
() = NULL;
21576 cur_exp_str
() = NULL;
21577 cur_exp_knot
() = NULL;
21579 @d set_cur_exp_value_boolean
(A
) do
{
21580 if
(cur_exp_str
()) {
21581 delete_str_ref
(cur_exp_str
());
21583 set_number_from_int
(mp-
>cur_exp.data.n
, (A
));
21584 cur_exp_node
() = NULL;
21585 cur_exp_str
() = NULL;
21586 cur_exp_knot
() = NULL;
21588 @d set_cur_exp_value_number
(A
) do
{
21589 if
(cur_exp_str
()) {
21590 delete_str_ref
(cur_exp_str
());
21592 number_clone
(mp-
>cur_exp.data.n
, (A
));
21593 cur_exp_node
() = NULL;
21594 cur_exp_str
() = NULL;
21595 cur_exp_knot
() = NULL;
21597 @d set_cur_exp_node
(A
) do
{
21598 if
(cur_exp_str
()) {
21599 delete_str_ref
(cur_exp_str
());
21601 cur_exp_node
() = A
;
21602 cur_exp_str
() = NULL;
21603 cur_exp_knot
() = NULL;
21604 set_number_to_zero
(mp-
>cur_exp.data.n
);
21606 @d set_cur_exp_str
(A
) do
{
21607 if
(cur_exp_str
()) {
21608 delete_str_ref
(cur_exp_str
());
21611 add_str_ref
(cur_exp_str
());
21612 cur_exp_node
() = NULL;
21613 cur_exp_knot
() = NULL;
21614 set_number_to_zero
(mp-
>cur_exp.data.n
);
21616 @d set_cur_exp_knot
(A
) do
{
21617 if
(cur_exp_str
()) {
21618 delete_str_ref
(cur_exp_str
());
21620 cur_exp_knot
() = A
;
21621 cur_exp_node
() = NULL;
21622 cur_exp_str
() = NULL;
21623 set_number_to_zero
(mp-
>cur_exp.data.n
);
21628 mp_value cur_exp
; /* the value of the expression just found
*/
21631 memset
(&mp->cur_exp.data, 0, sizeof (mp_value));
21632 new_number
(mp-
>cur_exp.data.n
);
21634 @ @
<Free table ...@
>=
21635 free_number
(mp-
>cur_exp.data.n
);
21637 @ Many different kinds of expressions are possible
, so it is wise to have
21638 precise descriptions of what |cur_type| and |cur_exp| mean in all cases
:
21641 |cur_type
=mp_vacuous| means that this expression didn't turn out to have a
21642 value at all
, because it arose from a \
&{begingroup}$\,\ldots\,$\&{endgroup}
21643 construction in which there was no expression before the \
&{endgroup}.
21644 In this case |cur_exp| has some irrelevant value.
21647 |cur_type
=mp_boolean_type| means that |cur_exp| is either |true_code|
21651 |cur_type
=mp_unknown_boolean| means that |cur_exp| points to a capsule
21653 a ring of equivalent booleans whose value has not yet been defined.
21656 |cur_type
=mp_string_type| means that |cur_exp| is a string number
(i.e.
, an
21657 integer in the range |
0<=cur_exp
<str_ptr|
). That string's reference count
21658 includes this particular reference.
21661 |cur_type
=mp_unknown_string| means that |cur_exp| points to a capsule
21663 a ring of equivalent strings whose value has not yet been defined.
21666 |cur_type
=mp_pen_type| means that |cur_exp| points to a node in a pen. Nobody
21667 else points to any of the nodes in this pen. The pen may be polygonal or
21671 |cur_type
=mp_unknown_pen| means that |cur_exp| points to a capsule
21673 a ring of equivalent pens whose value has not yet been defined.
21676 |cur_type
=mp_path_type| means that |cur_exp| points to a the first node of
21677 a path
; nobody else points to this particular path. The control points of
21678 the path will have been chosen.
21681 |cur_type
=mp_unknown_path| means that |cur_exp| points to a capsule
21683 a ring of equivalent paths whose value has not yet been defined.
21686 |cur_type
=mp_picture_type| means that |cur_exp| points to an edge header node.
21687 There may be other pointers to this particular set of edges. The header node
21688 contains a reference count that includes this particular reference.
21691 |cur_type
=mp_unknown_picture| means that |cur_exp| points to a capsule
21693 a ring of equivalent pictures whose value has not yet been defined.
21696 |cur_type
=mp_transform_type| means that |cur_exp| points to a |mp_transform_type|
21697 capsule node. The |value| part of this capsule
21698 points to a transform node that contains six numeric values
,
21699 each of which is |independent|
, |dependent|
, |mp_proto_dependent|
, or |known|.
21702 |cur_type
=mp_color_type| means that |cur_exp| points to a |color_type|
21703 capsule node. The |value| part of this capsule
21704 points to a color node that contains three numeric values
,
21705 each of which is |independent|
, |dependent|
, |mp_proto_dependent|
, or |known|.
21708 |cur_type
=mp_cmykcolor_type| means that |cur_exp| points to a |mp_cmykcolor_type|
21709 capsule node. The |value| part of this capsule
21710 points to a color node that contains four numeric values
,
21711 each of which is |independent|
, |dependent|
, |mp_proto_dependent|
, or |known|.
21714 |cur_type
=mp_pair_type| means that |cur_exp| points to a capsule
21715 node whose type is |mp_pair_type|. The |value| part of this capsule
21716 points to a pair node that contains two numeric values
,
21717 each of which is |independent|
, |dependent|
, |mp_proto_dependent|
, or |known|.
21720 |cur_type
=mp_known| means that |cur_exp| is a |scaled| value.
21723 |cur_type
=mp_dependent| means that |cur_exp| points to a capsule node whose type
21724 is |dependent|. The |dep_list| field in this capsule points to the associated
21728 |cur_type
=mp_proto_dependent| means that |cur_exp| points to a |mp_proto_dependent|
21729 capsule node. The |dep_list| field in this capsule
21730 points to the associated dependency list.
21733 |cur_type
=independent| means that |cur_exp| points to a capsule node
21734 whose type is |independent|. This somewhat unusual case can arise
, for
21735 example
, in the expression
21736 `$x
+\
&{begingroup}\penalty0\,\&{string}\,x; 0\,\&{endgroup}$'.
21739 |cur_type
=mp_token_list| means that |cur_exp| points to a linked list of
21742 \smallskip\noindent
21743 The possible settings of |cur_type| have been listed here in increasing
21744 numerical order. Notice that |cur_type| will never be |mp_numeric_type| or
21745 |suffixed_macro| or |mp_unsuffixed_macro|
, although variables of those types
21746 are allowed. Conversely
, \MP\ has no variables of type |mp_vacuous| or
21749 @ Capsules are non-symbolic nodes that have a similar meaning
21750 to |cur_type| and |cur_exp|. Such nodes have |name_type
=capsule|
,
21751 and their |type| field is one of the possibilities for |cur_type| listed above.
21752 Also |link
<=void| in capsules that aren't part of a token list.
21754 The |value| field of a capsule is
, in most cases
, the value that
21755 corresponds to its |type|
, as |cur_exp| corresponds to |cur_type|.
21756 However
, when |cur_exp| would point to a capsule
,
21757 no extra layer of indirection is present
; the |value|
21758 field is what would have been called |value
(cur_exp
)| if it had not been
21759 encapsulated. Furthermore
, if the type is |dependent| or
21760 |mp_proto_dependent|
, the |value| field of a capsule is replaced by
21761 |dep_list| and |prev_dep| fields
, since dependency lists in capsules are
21762 always part of the general |dep_list| structure.
21764 The |get_x_next| routine is careful not to change the values of |cur_type|
21765 and |cur_exp| when it gets an expanded token. However
, |get_x_next| might
21766 call a macro
, which might parse an expression
, which might execute lots of
21767 commands in a group
; hence it's possible that |cur_type| might change
21768 from
, say
, |mp_unknown_boolean| to |mp_boolean_type|
, or from |dependent| to
21769 |known| or |independent|
, during the time |get_x_next| is called. The
21770 programs below are careful to stash sensitive intermediate results in
21771 capsules
, so that \MP's generality doesn't cause trouble.
21773 Here's a procedure that illustrates these conventions. It takes
21774 the contents of $
(|cur_type|\kern-
.3pt
,|cur_exp|\kern-
.3pt
)$
21775 and stashes them away in a
21776 capsule. It is not used when |cur_type
=mp_token_list|.
21777 After the operation
, |cur_type
=mp_vacuous|
; hence there is no need to
21778 copy path lists or to update reference counts
, etc.
21780 The special link |MP_VOID| is put on the capsule returned by
21781 |stash_cur_exp|
, because this procedure is used to store macro parameters
21782 that must be easily distinguishable from token lists.
21784 @
<Declare the stashing
/unstashing routines@
>=
21785 static mp_node mp_stash_cur_exp
(MP mp
) {
21786 mp_node p
; /* the capsule that will be returned
*/
21787 mp_variable_type exp_type
= mp-
>cur_exp.type
;
21788 switch
(exp_type
) {
21789 case unknown_types
:
21790 case mp_transform_type
:
21791 case mp_color_type
:
21794 case mp_proto_dependent
:
21795 case mp_independent
:
21796 case mp_cmykcolor_type
:
21797 p
= cur_exp_node
();
21799 /* |case mp_path_type
: case mp_pen_type
: case mp_string_type
:|
*/
21801 p
= mp_get_value_node
(mp
);
21802 mp_name_type
(p
) = mp_capsule
;
21803 mp_type
(p
) = mp-
>cur_exp.type
;
21804 set_value_number
(p
, cur_exp_value_number
()); /* this also resets the rest to
0/NULL */
21805 if
(cur_exp_str
()) {
21806 set_value_str
(p
, cur_exp_str
());
21807 } else if
(cur_exp_knot
()) {
21808 set_value_knot
(p
, cur_exp_knot
());
21809 } else if
(cur_exp_node
()) {
21810 set_value_node
(p
, cur_exp_node
());
21814 mp-
>cur_exp.type
= mp_vacuous
;
21815 mp_link
(p
) = MP_VOID
;
21820 @ The inverse of |stash_cur_exp| is the following procedure
, which
21821 deletes an unnecessary capsule and puts its contents into |cur_type|
21824 The program steps of \MP\ can be divided into two categories
: those in
21825 which |cur_type| and |cur_exp| are ``alive'' and those in which they are
21826 ``dead
,'' in the sense that |cur_type| and |cur_exp| contain relevant
21827 information or not. It's important not to ignore them when they're alive
,
21828 and it's important not to pay attention to them when they're dead.
21830 There's also an intermediate category
: If |cur_type
=mp_vacuous|
, then
21831 |cur_exp| is irrelevant
, hence we can proceed without caring if |cur_type|
21832 and |cur_exp| are alive or dead. In such cases we say that |cur_type|
21833 and |cur_exp| are
{\sl dormant
}. It is permissible to call |get_x_next|
21834 only when they are alive or dormant.
21836 The \\
{stash
} procedure above assumes that |cur_type| and |cur_exp|
21837 are alive or dormant. The \\
{unstash
} procedure assumes that they are
21838 dead or dormant
; it resuscitates them.
21840 @
<Declare the stashing
/unstashing...@
>=
21841 static void mp_unstash_cur_exp
(MP mp
, mp_node p
);
21844 void mp_unstash_cur_exp
(MP mp
, mp_node p
) {
21845 mp-
>cur_exp.type
= mp_type
(p
);
21846 switch
(mp-
>cur_exp.type
) {
21847 case unknown_types
:
21848 case mp_transform_type
:
21849 case mp_color_type
:
21852 case mp_proto_dependent
:
21853 case mp_independent
:
21854 case mp_cmykcolor_type
:
21855 set_cur_exp_node
(p
);
21857 case mp_token_list
: /* this is how symbols are stashed
*/
21858 set_cur_exp_node
(value_node
(p
));
21859 mp_free_value_node
(mp
, p
);
21863 set_cur_exp_knot
(value_knot
(p
));
21864 mp_free_value_node
(mp
, p
);
21866 case mp_string_type
:
21867 set_cur_exp_str
(value_str
(p
));
21868 mp_free_value_node
(mp
, p
);
21870 case mp_picture_type
:
21871 set_cur_exp_node
(value_node
(p
));
21872 mp_free_value_node
(mp
, p
);
21874 case mp_boolean_type
:
21876 set_cur_exp_value_number
(value_number
(p
));
21877 mp_free_value_node
(mp
, p
);
21880 set_cur_exp_value_number
(value_number
(p
));
21881 if
(value_knot
(p
)) {
21882 set_cur_exp_knot
(value_knot
(p
));
21883 } else if
(value_node
(p
)) {
21884 set_cur_exp_node
(value_node
(p
));
21885 } else if
(value_str
(p
)) {
21886 set_cur_exp_str
(value_str
(p
));
21888 mp_free_value_node
(mp
, p
);
21894 @ The following procedure prints the values of expressions in an
21895 abbreviated format. If its first parameter |p| is
NULL, the value of
21896 |
(cur_type
,cur_exp
)| is displayed
; otherwise |p| should be a capsule
21897 containing the desired value. The second parameter controls the amount of
21898 output. If it is~
0, dependency lists will be abbreviated to
21899 `\.
{linearform
}' unless they consist of a single term. If it is greater
21900 than~
1, complicated structures
(pens
, pictures
, and paths
) will be displayed
21905 @
<Declare the procedure called |print_dp|@
>;
21906 @
<Declare the stashing
/unstashing routines@
>;
21907 static void mp_print_exp
(MP mp
, mp_node p
, quarterword verbosity
);
21910 void mp_print_exp
(MP mp
, mp_node p
, quarterword verbosity
) {
21911 boolean restore_cur_exp
; /* should |cur_exp| be restored?
*/
21912 mp_variable_type t
; /* the type of the expression
*/
21913 mp_number vv
; /* the value of the expression
*/
21917 restore_cur_exp
= false
;
21919 p
= mp_stash_cur_exp
(mp
);
21920 restore_cur_exp
= true
;
21923 if
(t
< mp_dependent
) { /* no dep list
, could be a capsule
*/
21924 if
(t
!= mp_vacuous
&& t != mp_known && value_node (p) != NULL)
21925 v
= value_node
(p
);
21927 number_clone
(vv
, value_number
(p
));
21928 } else if
(t
< mp_independent
) {
21929 v
= (mp_node
) dep_list
((mp_value_node
) p
);
21931 @
<Print an abbreviated value of |v| or |vv| with format depending on |t|@
>;
21932 if
(restore_cur_exp
)
21933 mp_unstash_cur_exp
(mp
, p
);
21938 @ @
<Print an abbreviated value of |v| or |vv| with format depending on |t|@
>=
21941 mp_print
(mp
, "vacuous");
21943 case mp_boolean_type
:
21944 if
(number_to_boolean
(vv
) == mp_true_code
)
21945 mp_print
(mp
, "true");
21947 mp_print
(mp
, "false");
21949 case unknown_types
:
21950 case mp_numeric_type
:
21951 @
<Display a variable that's been declared but not defined@
>;
21953 case mp_string_type
:
21954 mp_print_char
(mp
, xord
('
"'));
21955 mp_print_str (mp, value_str (p));
21956 mp_print_char (mp, xord ('"'
));
21960 case mp_picture_type
:
21961 @
<Display a complex type@
>;
21963 case mp_transform_type
:
21964 if
(number_zero
(vv
) && v == NULL)
21965 mp_print_type
(mp
, t
);
21967 @
<Display a transform node@
>;
21969 case mp_color_type
:
21970 if
(number_zero
(vv
) && v == NULL)
21971 mp_print_type
(mp
, t
);
21973 @
<Display a color node@
>;
21976 if
(number_zero
(vv
) && v == NULL)
21977 mp_print_type
(mp
, t
);
21979 @
<Display a pair node@
>;
21981 case mp_cmykcolor_type
:
21982 if
(number_zero
(vv
) && v == NULL)
21983 mp_print_type
(mp
, t
);
21985 @
<Display a cmykcolor node@
>;
21991 case mp_proto_dependent
:
21992 mp_print_dp
(mp
, t
, (mp_value_node
) v
, verbosity
);
21994 case mp_independent
:
21995 mp_print_variable_name
(mp
, p
);
21998 mp_confusion
(mp
, "exp");
22000 @
:this can't happen exp
}{\quad exp@
>
22004 @ @
<Display big node item |v|@
>=
22006 if
(mp_type
(v
) == mp_known
)
22007 print_number
(value_number
(v
));
22008 else if
(mp_type
(v
) == mp_independent
)
22009 mp_print_variable_name
(mp
, v
);
22011 mp_print_dp
(mp
, mp_type
(v
), (mp_value_node
) dep_list
((mp_value_node
) v
),
22016 @ In these cases
, |v| starts as the big node.
22018 @
<Display a pair node@
>=
22021 mp_print_char
(mp
, xord
('
('
));
22022 /* clang
: dereference of null pointer
*/ assert
(vvv
);
22024 @
<Display big node item |v|@
>;
22025 mp_print_char
(mp
, xord
('
,'
));
22027 @
<Display big node item |v|@
>;
22028 mp_print_char
(mp
, xord
('
)'
));
22032 @ @
<Display a transform node@
>=
22035 mp_print_char
(mp
, xord
('
('
));
22036 /* clang
: dereference of null pointer
*/ assert
(vvv
);
22038 @
<Display big node item |v|@
>;
22039 mp_print_char
(mp
, xord
('
,'
));
22041 @
<Display big node item |v|@
>;
22042 mp_print_char
(mp
, xord
('
,'
));
22044 @
<Display big node item |v|@
>;
22045 mp_print_char
(mp
, xord
('
,'
));
22047 @
<Display big node item |v|@
>;
22048 mp_print_char
(mp
, xord
('
,'
));
22050 @
<Display big node item |v|@
>;
22051 mp_print_char
(mp
, xord
('
,'
));
22053 @
<Display big node item |v|@
>;
22054 mp_print_char
(mp
, xord
('
)'
));
22058 @ @
<Display a color node@
>=
22061 mp_print_char
(mp
, xord
('
('
));
22062 /* clang
: dereference of null pointer
*/ assert
(vvv
);
22063 v
= red_part
(vvv
);
22064 @
<Display big node item |v|@
>;
22065 mp_print_char
(mp
, xord
('
,'
));
22066 v
= green_part
(vvv
);
22067 @
<Display big node item |v|@
>;
22068 mp_print_char
(mp
, xord
('
,'
));
22069 v
= blue_part
(vvv
);
22070 @
<Display big node item |v|@
>;
22071 mp_print_char
(mp
, xord
('
)'
));
22075 @ @
<Display a cmykcolor node@
>=
22078 mp_print_char
(mp
, xord
('
('
));
22079 /* clang
: dereference of null pointer
*/ assert
(vvv
);
22080 v
= cyan_part
(vvv
);
22081 @
<Display big node item |v|@
>;
22082 mp_print_char
(mp
, xord
('
,'
));
22083 v
= magenta_part
(vvv
);
22084 @
<Display big node item |v|@
>;
22085 mp_print_char
(mp
, xord
('
,'
));
22086 v
= yellow_part
(vvv
);
22087 @
<Display big node item |v|@
>;
22088 mp_print_char
(mp
, xord
('
,'
));
22089 v
= black_part
(vvv
);
22090 @
<Display big node item |v|@
>;
22091 mp_print_char
(mp
, xord
('
)'
));
22095 @ Values of type \
&{picture}, \&{path}, and \&{pen} are displayed verbosely
22096 in the log file only
, unless the user has given a positive value to
22099 @
<Display a complex type@
>=
22100 if
(verbosity
<= 1) {
22101 mp_print_type
(mp
, t
);
22103 if
(mp-
>selector
== term_and_log
)
22104 if
(number_nonpositive
(internal_value
(mp_tracing_online
))) {
22105 mp-
>selector
= term_only
;
22106 mp_print_type
(mp
, t
);
22107 mp_print
(mp
, " (see the transcript file)");
22108 mp-
>selector
= term_and_log
;
22112 mp_print_pen
(mp
, value_knot
(p
), "", false
);
22115 mp_print_path
(mp
, value_knot
(p
), "", false
);
22117 case mp_picture_type
:
22118 mp_print_edges
(mp
, v
, "", false
);
22126 @ @
<Declare the procedure called |print_dp|@
>=
22127 static void mp_print_dp
(MP mp
, quarterword t
, mp_value_node p
,
22128 quarterword verbosity
) {
22129 mp_value_node q
; /* the node following |p|
*/
22130 q
= (mp_value_node
) mp_link
(p
);
22131 if
((dep_info
(q
) == NULL) ||
(verbosity
> 0))
22132 mp_print_dependency
(mp
, p
, t
);
22134 mp_print
(mp
, "linearform");
22138 @ The displayed name of a variable in a ring will not be a capsule unless
22139 the ring consists entirely of capsules.
22141 @
<Display a variable that's been declared but not defined@
>=
22143 mp_print_type
(mp
, t
);
22145 mp_print_char
(mp
, xord
(' '
));
22146 while
((mp_name_type
(v
) == mp_capsule
) && (v != p))
22147 v
= value_node
(v
);
22148 mp_print_variable_name
(mp
, v
);
22153 @ When errors are detected during parsing
, it is often helpful to
22154 display an expression just above the error message
, using |disp_err|
22155 just before |mp_error|.
22158 static void mp_disp_err
(MP mp
, mp_node p
);
22161 void mp_disp_err
(MP mp
, mp_node p
) {
22162 if
(mp-
>interaction
== mp_error_stop_mode
)
22163 wake_up_terminal
();
22164 mp_print_nl
(mp
, ">> ");
22166 mp_print_exp
(mp
, p
, 1); /* ``medium verbose'' printing of the expression
*/
22170 @ If |cur_type| and |cur_exp| contain relevant information that should
22171 be recycled
, we will use the following procedure
, which changes |cur_type|
22172 to |known| and stores a given value in |cur_exp|. We can think of |cur_type|
22173 and |cur_exp| as either alive or dormant after this has been done
,
22174 because |cur_exp| will not contain a pointer value.
22177 void mp_flush_cur_exp
(MP mp
, mp_value v
) {
22178 if
(is_number
(mp-
>cur_exp.data.n
)) {
22179 free_number
(mp-
>cur_exp.data.n
);
22181 switch
(mp-
>cur_exp.type
) {
22182 case unknown_types
:
22183 case mp_transform_type
:
22184 case mp_color_type
:
22187 case mp_proto_dependent
:
22188 case mp_independent
:
22189 case mp_cmykcolor_type
:
22190 mp_recycle_value
(mp
, cur_exp_node
());
22191 mp_free_value_node
(mp
, cur_exp_node
());
22193 case mp_string_type
:
22194 delete_str_ref
(cur_exp_str
());
22198 mp_toss_knot_list
(mp
, cur_exp_knot
());
22200 case mp_picture_type
:
22201 delete_edge_ref
(cur_exp_node
());
22207 mp-
>cur_exp.type
= mp_known
;
22211 @ There's a much more general procedure that is capable of releasing
22212 the storage associated with any non-symbolic value packet.
22215 static void mp_recycle_value
(MP mp
, mp_node p
);
22218 static void mp_recycle_value
(MP mp
, mp_node p
) {
22219 mp_variable_type t
; /* a type code
*/
22220 FUNCTION_TRACE2
("mp_recycle_value(%p)\n", p
);
22224 case mp_boolean_type
:
22226 case mp_numeric_type
:
22228 case unknown_types
:
22229 mp_ring_delete
(mp
, p
);
22231 case mp_string_type
:
22232 delete_str_ref
(value_str
(p
));
22236 mp_toss_knot_list
(mp
, value_knot
(p
));
22238 case mp_picture_type
:
22239 delete_edge_ref
(value_node
(p
));
22241 case mp_cmykcolor_type
:
22242 if
(value_node
(p
) != NULL) {
22243 mp_recycle_value
(mp
, cyan_part
(value_node
(p
)));
22244 mp_recycle_value
(mp
, magenta_part
(value_node
(p
)));
22245 mp_recycle_value
(mp
, yellow_part
(value_node
(p
)));
22246 mp_recycle_value
(mp
, black_part
(value_node
(p
)));
22247 mp_free_value_node
(mp
, cyan_part
(value_node
(p
)));
22248 mp_free_value_node
(mp
, magenta_part
(value_node
(p
)));
22249 mp_free_value_node
(mp
, black_part
(value_node
(p
)));
22250 mp_free_value_node
(mp
, yellow_part
(value_node
(p
)));
22251 mp_free_node
(mp
, value_node
(p
), cmykcolor_node_size
);
22255 if
(value_node
(p
) != NULL) {
22256 mp_recycle_value
(mp
, x_part
(value_node
(p
)));
22257 mp_recycle_value
(mp
, y_part
(value_node
(p
)));
22258 mp_free_value_node
(mp
, x_part
(value_node
(p
)));
22259 mp_free_value_node
(mp
, y_part
(value_node
(p
)));
22260 mp_free_pair_node
(mp
, value_node
(p
));
22263 case mp_color_type
:
22264 if
(value_node
(p
) != NULL) {
22265 mp_recycle_value
(mp
, red_part
(value_node
(p
)));
22266 mp_recycle_value
(mp
, green_part
(value_node
(p
)));
22267 mp_recycle_value
(mp
, blue_part
(value_node
(p
)));
22268 mp_free_value_node
(mp
, red_part
(value_node
(p
)));
22269 mp_free_value_node
(mp
, green_part
(value_node
(p
)));
22270 mp_free_value_node
(mp
, blue_part
(value_node
(p
)));
22271 mp_free_node
(mp
, value_node
(p
), color_node_size
);
22274 case mp_transform_type
:
22275 if
(value_node
(p
) != NULL) {
22276 mp_recycle_value
(mp
, tx_part
(value_node
(p
)));
22277 mp_recycle_value
(mp
, ty_part
(value_node
(p
)));
22278 mp_recycle_value
(mp
, xx_part
(value_node
(p
)));
22279 mp_recycle_value
(mp
, xy_part
(value_node
(p
)));
22280 mp_recycle_value
(mp
, yx_part
(value_node
(p
)));
22281 mp_recycle_value
(mp
, yy_part
(value_node
(p
)));
22282 mp_free_value_node
(mp
, tx_part
(value_node
(p
)));
22283 mp_free_value_node
(mp
, ty_part
(value_node
(p
)));
22284 mp_free_value_node
(mp
, xx_part
(value_node
(p
)));
22285 mp_free_value_node
(mp
, xy_part
(value_node
(p
)));
22286 mp_free_value_node
(mp
, yx_part
(value_node
(p
)));
22287 mp_free_value_node
(mp
, yy_part
(value_node
(p
)));
22288 mp_free_node
(mp
, value_node
(p
), transform_node_size
);
22292 case mp_proto_dependent
:
22293 /* Recycle a dependency list
*/
22295 mp_value_node qq
= (mp_value_node
) dep_list
((mp_value_node
) p
);
22296 while
(dep_info
(qq
) != NULL)
22297 qq
= (mp_value_node
) mp_link
(qq
);
22298 set_mp_link
(prev_dep
((mp_value_node
) p
), mp_link
(qq
));
22299 set_prev_dep
(mp_link
(qq
), prev_dep
((mp_value_node
) p
));
22300 set_mp_link
(qq
, NULL);
22301 mp_flush_node_list
(mp
, (mp_node
) dep_list
((mp_value_node
) p
));
22304 case mp_independent
:
22305 @
<Recycle an independent variable@
>;
22307 case mp_token_list
:
22308 case mp_structured
:
22309 mp_confusion
(mp
, "recycle");
22311 case mp_unsuffixed_macro
:
22312 case mp_suffixed_macro
:
22313 mp_delete_mac_ref
(mp
, value_node
(p
));
22315 default
: /* there are no other valid cases
, but please the compiler
*/
22318 mp_type
(p
) = mp_undefined
;
22321 @ When an independent variable disappears
, it simply fades away
, unless
22322 something depends on it. In the latter case
, a dependent variable whose
22323 coefficient of dependence is maximal will take its place.
22324 The relevant algorithm is due to Ignacio~A. Zabala
, who implemented it
22325 as part of his Ph.n-
>data. thesis
(Stanford University
, December
1982).
22326 @^Zabala Salelles
, Ignacio Andr\'es@
>
22328 For example
, suppose that variable $x$ is being recycled
, and that the
22329 only variables depending on~$x$ are $y
=2x
+a$ and $z
=x
+b$. In this case
22330 we want to make $y$ independent and $z
=.5y-
.5a
+b$
; no other variables
22331 will depend on~$y$. If $\\
{tracingequations
}>0$ in this situation
,
22332 we will print `\.
{\#\#\#
-2x
=-y
+a
}'.
22334 There's a slight complication
, however
: An independent variable $x$
22335 can occur both in dependency lists and in proto-dependency lists.
22336 This makes it necessary to be careful when deciding which coefficient
22339 Furthermore
, this complication is not so slight when
22340 a proto-dependent variable is chosen to become independent. For example
,
22341 suppose that $y
=2x
+100a$ is proto-dependent while $z
=x
+b$ is dependent
;
22342 then we must change $z
=.5y-50a
+b$ to a proto-dependency
, because of the
22343 large coefficient `
50'.
22345 In order to deal with these complications without wasting too much time
,
22346 we shall link together the occurrences of~$x$ among all the linear
22347 dependencies
, maintaining separate lists for the dependent and
22348 proto-dependent cases.
22350 @
<Recycle an independent variable@
>=
22352 mp_value_node q
, r
, s
;
22353 mp_node pp
; /* link manipulation register
*/
22354 mp_number v
; /* a value
*/
22355 mp_number test
; /* a temporary value
*/
22358 if
(t
< mp_dependent
)
22359 number_clone
(v
, value_number
(p
));
22360 set_number_to_zero
(mp-
>max_c
[mp_dependent
]);
22361 set_number_to_zero
(mp-
>max_c
[mp_proto_dependent
]);
22362 mp-
>max_link
[mp_dependent
] = NULL;
22363 mp-
>max_link
[mp_proto_dependent
] = NULL;
22364 q
= (mp_value_node
) mp_link
(mp-
>dep_head
);
22365 while
(q
!= mp-
>dep_head
) {
22366 s
= (mp_value_node
) mp-
>temp_head
;
22367 set_mp_link
(s
, dep_list
(q
));
22369 r
= (mp_value_node
) mp_link
(s
);
22370 if
(dep_info
(r
) == NULL)
22372 if
(dep_info
(r
) != p
) {
22376 if
(mp_link
(s
) == dep_list
(q
)) { /* reset the |dep_list|
*/
22377 set_dep_list
(q
, mp_link
(r
));
22379 set_mp_link
(s
, mp_link
(r
));
22380 set_dep_info
(r
, (mp_node
) q
);
22381 number_clone
(test
, dep_value
(r
));
22383 if
(number_greater
(test
, mp-
>max_c
[t
])) {
22384 /* Record a new maximum coefficient of type |t|
*/
22385 if
(number_positive
(mp-
>max_c
[t
])) {
22386 set_mp_link
(mp-
>max_ptr
[t
], (mp_node
) mp-
>max_link
[t
]);
22387 mp-
>max_link
[t
] = mp-
>max_ptr
[t
];
22389 number_clone
(mp-
>max_c
[t
], test
);
22390 mp-
>max_ptr
[t
] = r
;
22392 set_mp_link
(r
, (mp_node
) mp-
>max_link
[t
]);
22393 mp-
>max_link
[t
] = r
;
22397 q
= (mp_value_node
) mp_link
(r
);
22399 if
(number_positive
(mp-
>max_c
[mp_dependent
]) || number_positive
(mp-
>max_c
[mp_proto_dependent
])) {
22400 /* Choose a dependent variable to take the place of the disappearing
22401 independent variable
, and change all remaining dependencies
22403 mp_number test
, ret
; /* temporary use
*/
22406 number_clone
(test
, mp-
>max_c
[mp_dependent
]);
22407 number_divide_int
(test
, 4096);
22408 if
(number_greaterequal
(test
, mp-
>max_c
[mp_proto_dependent
]))
22411 t
= mp_proto_dependent
;
22413 /* Let |s
=max_ptr
[t
]|. At this point we have $|value|
(s
)=\pm|max_c|
[t
]$
,
22414 and |dep_info
(s
)| points to the dependent variable~|pp| of type~|t| from
22415 whose dependency list we have removed node~|s|. We must reinsert
22416 node~|s| into the dependency list
, with coefficient $
-1.0$
, and with
22417 |pp| as the new independent variable. Since |pp| will have a larger serial
22418 number than any other variable
, we can put node |s| at the head of the
22420 /* Determine the dependency list |s| to substitute for the independent
22423 s
= mp-
>max_ptr
[t
];
22424 pp
= (mp_node
) dep_info
(s
);
22425 number_clone
(v
, dep_value
(s
));
22426 if
(t
== mp_dependent
) {
22427 set_dep_value
(s
, fraction_one_t
);
22429 set_dep_value
(s
, unity_t
);
22431 number_negate
(dep_value
(s
));
22432 r
= (mp_value_node
) dep_list
((mp_value_node
) pp
);
22433 set_mp_link
(s
, (mp_node
) r
);
22434 while
(dep_info
(r
) != NULL)
22435 r
= (mp_value_node
) mp_link
(r
);
22436 q
= (mp_value_node
) mp_link
(r
);
22437 set_mp_link
(r
, NULL);
22438 set_prev_dep
(q
, prev_dep
((mp_value_node
) pp
));
22439 set_mp_link
(prev_dep
((mp_value_node
) pp
), (mp_node
) q
);
22440 mp_new_indep
(mp
, pp
);
22441 if
(cur_exp_node
() == pp
&& mp->cur_exp.type == t)
22442 mp-
>cur_exp.type
= mp_independent
;
22443 if
(number_positive
(internal_value
(mp_tracing_equations
))) {
22444 /* Show the transformed dependency
*/
22445 if
(mp_interesting
(mp
, p
)) {
22446 mp_begin_diagnostic
(mp
);
22447 mp_show_transformed_dependency
(mp
, v
, t
, p
);
22448 mp_print_dependency
(mp
, s
, t
);
22449 mp_end_diagnostic
(mp
, false
);
22453 t
= (quarterword
) (mp_dependent
+ mp_proto_dependent
- t
); /* complement |t|
*/
22454 if
(number_positive
(mp-
>max_c
[t
])) {
22455 /* we need to pick up an unchosen dependency
*/
22456 set_mp_link
(mp-
>max_ptr
[t
], (mp_node
) mp-
>max_link
[t
]);
22457 mp-
>max_link
[t
] = mp-
>max_ptr
[t
];
22459 /* Finally
, there are dependent and proto-dependent variables whose
22460 dependency lists must be brought up to date.
*/
22461 if
(t
!= mp_dependent
) {
22462 /* Substitute new dependencies in place of |p|
*/
22463 for
(t
= mp_dependent
; t
<= mp_proto_dependent
; t
=t
+1) {
22464 r
= mp-
>max_link
[t
];
22465 while
(r
!= NULL) {
22466 q
= (mp_value_node
) dep_info
(r
);
22467 number_clone
(test
, v
);
22468 number_negate
(test
);
22469 make_fraction
(ret
, dep_value
(r
), test
);
22470 set_dep_list
(q
, mp_p_plus_fq
(mp
, (mp_value_node
) dep_list
(q
), ret
, s
, t
, mp_dependent
));
22471 if
(dep_list
(q
) == (mp_node
) mp-
>dep_final
)
22472 mp_make_known
(mp
, q
, mp-
>dep_final
);
22474 r
= (mp_value_node
) mp_link
(r
);
22475 mp_free_dep_node
(mp
, q
);
22479 /* Substitute new proto-dependencies in place of |p|
*/
22480 for
(t
= mp_dependent
; t
<= mp_proto_dependent
; t
=t
+1) {
22481 r
= mp-
>max_link
[t
];
22482 while
(r
!= NULL) {
22483 q
= (mp_value_node
) dep_info
(r
);
22484 if
(t
== mp_dependent
) { /* for safety's sake
, we change |q| to |mp_proto_dependent|
*/
22485 if
(cur_exp_node
() == (mp_node
) q
&& mp->cur_exp.type == mp_dependent)
22486 mp-
>cur_exp.type
= mp_proto_dependent
;
22487 set_dep_list
(q
, mp_p_over_v
(mp
, (mp_value_node
) dep_list
(q
),
22488 unity_t
, mp_dependent
,
22489 mp_proto_dependent
));
22490 mp_type
(q
) = mp_proto_dependent
;
22491 fraction_to_round_scaled
(dep_value
(r
));
22493 number_clone
(test
, v
);
22494 number_negate
(test
);
22495 make_scaled
(ret
, dep_value
(r
), test
);
22496 set_dep_list
(q
, mp_p_plus_fq
(mp
, (mp_value_node
) dep_list
(q
),
22498 mp_proto_dependent
,
22499 mp_proto_dependent
));
22500 if
(dep_list
(q
) == (mp_node
) mp-
>dep_final
)
22501 mp_make_known
(mp
, q
, mp-
>dep_final
);
22503 r
= (mp_value_node
) mp_link
(r
);
22504 mp_free_dep_node
(mp
, q
);
22508 mp_flush_node_list
(mp
, (mp_node
) s
);
22509 if
(mp-
>fix_needed
)
22510 mp_fix_dependencies
(mp
);
22518 @ @
<Declarations@
>=
22519 static void mp_show_transformed_dependency
(MP mp
, mp_number v
, mp_variable_type t
, mp_node p
);
22522 static void mp_show_transformed_dependency
(MP mp
, mp_number v
, mp_variable_type t
, mp_node p
)
22524 mp_number vv
; /* for temp use
*/
22526 mp_print_nl
(mp
, "### ");
22527 if
(number_positive
(v
))
22528 mp_print_char
(mp
, xord
('
-'
));
22529 if
(t
== mp_dependent
) {
22530 number_clone
(vv
, mp-
>max_c
[mp_dependent
]);
22531 fraction_to_round_scaled
(vv
);
22533 number_clone
(vv
, mp-
>max_c
[mp_proto_dependent
]);
22535 if
(!number_equal
(vv
, unity_t
)) {
22538 mp_print_variable_name
(mp
, p
);
22539 while
(indep_scale
(p
) > 0) {
22540 mp_print
(mp
, "*4");
22541 set_indep_scale
(p
, indep_scale
(p
)-2);
22543 if
(t
== mp_dependent
)
22544 mp_print_char
(mp
, xord
('
='
));
22546 mp_print
(mp
, " = ");
22551 @ The code for independency removal makes use of three non-symbolic arrays.
22554 mp_number max_c
[mp_proto_dependent
+ 1]; /* max coefficient magnitude
*/
22555 mp_value_node max_ptr
[mp_proto_dependent
+ 1]; /* where |p| occurs with |max_c|
*/
22556 mp_value_node max_link
[mp_proto_dependent
+ 1]; /* other occurrences of |p|
*/
22559 @ @
<Initialize table ... @
>=
22562 for
(i
=0;i
<mp_proto_dependent
+ 1;i
++) {
22563 new_number
(mp-
>max_c
[i
]);
22570 for
(i
=0;i
<mp_proto_dependent
+ 1;i
++) {
22571 free_number
(mp-
>max_c
[i
]);
22575 @ A global variable |var_flag| is set to a special command code
22576 just before \MP\ calls |scan_expression|
, if the expression should be
22577 treated as a variable when this command code immediately follows. For
22578 example
, |var_flag| is set to |assignment| at the beginning of a
22579 statement
, because we want to know the
{\sl location\
/} of a variable at
22580 the left of `\.
{:=}'
, not the
{\sl value\
/} of that variable.
22582 The |scan_expression| subroutine calls |scan_tertiary|
,
22583 which calls |scan_secondary|
, which calls |scan_primary|
, which sets
22584 |var_flag
:=0|. In this way each of the scanning routines ``knows''
22585 when it has been called with a special |var_flag|
, but |var_flag| is
22588 A variable preceding a command that equals |var_flag| is converted to a
22589 token list rather than a value. Furthermore
, an `\.
{=}' sign following an
22590 expression with |var_flag
=assignment| is not considered to be a relation
22591 that produces boolean expressions.
22595 int var_flag
; /* command that wants a variable
*/
22600 @
* Parsing primary expressions.
22601 The first parsing routine
, |scan_primary|
, is also the most complicated one
,
22602 since it involves so many different cases. But each case---with one
22603 exception---is fairly simple by itself.
22605 When |scan_primary| begins
, the first token of the primary to be scanned
22606 should already appear in |cur_cmd|
, |cur_mod|
, and |cur_sym|. The values
22607 of |cur_type| and |cur_exp| should be either dead or dormant
, as explained
22608 earlier. If |cur_cmd| is not between |min_primary_command| and
22609 |max_primary_command|
, inclusive
, a syntax error will be signaled.
22611 Later we'll come to procedures that perform actual operations like
22612 addition
, square root
, and so on
; our purpose now is to do the parsing.
22613 But we might as well mention those future procedures now
, so that the
22614 suspense won't be too bad
:
22617 |do_nullary
(c
)| does primitive operations that have no operands
(e.g.
,
22618 `\
&{true}' or `\&{pencircle}');
22621 |do_unary
(c
)| applies a primitive operation to the current expression
;
22624 |do_binary
(p
,c
)| applies a primitive operation to the capsule~|p|
22625 and the current expression.
22627 @
<Declare the basic parsing subroutines@
>=
22628 static void check_for_mediation
(MP mp
);
22629 void mp_scan_primary
(MP mp
) {
22630 mp_command_code my_var_flag
; /* initial value of |my_var_flag|
*/
22631 my_var_flag
= mp-
>var_flag
;
22635 /* Supply diagnostic information
, if requested
*/
22636 if
(mp-
>interrupt
!= 0) {
22637 if
(mp-
>OK_to_interrupt
) {
22638 mp_back_input
(mp
);
22640 mp_get_x_next
(mp
);
22643 switch
(cur_cmd
()) {
22644 case mp_left_delimiter
:
22646 /* Scan a delimited primary
*/
22647 mp_node p
, q
, r
; /* for list manipulation
*/
22648 mp_sym l_delim
, r_delim
; /* hash addresses of a delimiter pair
*/
22649 l_delim
= cur_sym
();
22650 r_delim
= equiv_sym
(cur_sym
());
22651 mp_get_x_next
(mp
);
22652 mp_scan_expression
(mp
);
22653 if
((cur_cmd
() == mp_comma
) && (mp->cur_exp.type >= mp_known)) {
22654 /* Scan the rest of a delimited set of numerics
*/
22655 /* This code uses the fact that |red_part| and |green_part|
22656 are synonymous with |x_part| and |y_part|.
*/
22657 p
= mp_stash_cur_exp
(mp
);
22658 mp_get_x_next
(mp
);
22659 mp_scan_expression
(mp
);
22660 /* Make sure the second part of a pair or color has a numeric type
*/
22661 if
(mp-
>cur_exp.type
< mp_known
) {
22662 const char
*hlp
[] = {
22663 "I've started to scan a pair `(a,b)' or a color `(a,b,c)';",
22664 "but after finding a nice `a' I found a `b' that isn't",
22665 "of numeric type. So I've changed that part to zero.",
22666 "(The b that I didn't like appears above the error message.)",
22669 memset
(&new_expr,0,sizeof(mp_value));
22670 mp_disp_err
(mp
, NULL);
22671 new_number
(new_expr.data.n
);
22672 set_number_to_zero
(new_expr.data.n
);
22673 mp_back_error
(mp
,"Nonnumeric ypart has been replaced by 0", hlp
, true
);
22674 mp_get_x_next
(mp
);
22675 mp_flush_cur_exp
(mp
, new_expr
);
22678 q
= mp_get_value_node
(mp
);
22679 mp_name_type
(q
) = mp_capsule
;
22680 if
(cur_cmd
() == mp_comma
) {
22681 mp_init_color_node
(mp
, q
);
22682 r
= value_node
(q
);
22683 mp_stash_in
(mp
, y_part
(r
));
22684 mp_unstash_cur_exp
(mp
, p
);
22685 mp_stash_in
(mp
, x_part
(r
));
22686 /* Scan the last of a triplet of numerics
*/
22687 mp_get_x_next
(mp
);
22688 mp_scan_expression
(mp
);
22689 if
(mp-
>cur_exp.type
< mp_known
) {
22691 const char
*hlp
[] = {
22692 "I've just scanned a color `(a,b,c)' or cmykcolor(a,b,c,d); but the `c'",
22693 "isn't of numeric type. So I've changed that part to zero.",
22694 "(The c that I didn't like appears above the error message.)",
22696 memset
(&new_expr,0,sizeof(mp_value));
22697 mp_disp_err
(mp
, NULL);
22698 new_number
(new_expr.data.n
);
22699 set_number_to_zero
(new_expr.data.n
);
22700 mp_back_error
(mp
,"Nonnumeric third part has been replaced by 0", hlp
, true
);
22701 mp_get_x_next
(mp
);
22702 mp_flush_cur_exp
(mp
, new_expr
);
22704 mp_stash_in
(mp
, blue_part
(r
));
22706 if
(cur_cmd
() == mp_comma
) {
22707 mp_node t
; /* a token
*/
22708 mp_init_cmykcolor_node
(mp
, q
);
22709 t
= value_node
(q
);
22710 mp_type
(cyan_part
(t
)) = mp_type
(red_part
(r
));
22711 set_value_number
(cyan_part
(t
), value_number
(red_part
(r
)));
22712 mp_type
(magenta_part
(t
)) = mp_type
(green_part
(r
));
22713 set_value_number
(magenta_part
(t
), value_number
(green_part
(r
)));
22714 mp_type
(yellow_part
(t
)) = mp_type
(blue_part
(r
));
22715 set_value_number
(yellow_part
(t
), value_number
(blue_part
(r
)));
22716 mp_recycle_value
(mp
, r
);
22718 /* Scan the last of a quartet of numerics
*/
22719 mp_get_x_next
(mp
);
22720 mp_scan_expression
(mp
);
22721 if
(mp-
>cur_exp.type
< mp_known
) {
22722 const char
*hlp
[] = {
22723 "I've just scanned a cmykcolor `(c,m,y,k)'; but the `k' isn't",
22724 "of numeric type. So I've changed that part to zero.",
22725 "(The k that I didn't like appears above the error message.)",
22728 memset
(&new_expr,0,sizeof(mp_value));
22729 new_number
(new_expr.data.n
);
22730 mp_disp_err
(mp
, NULL);
22731 set_number_to_zero
(new_expr.data.n
);
22732 mp_back_error
(mp
,"Nonnumeric blackpart has been replaced by 0", hlp
, true
);
22733 mp_get_x_next
(mp
);
22734 mp_flush_cur_exp
(mp
, new_expr
);
22736 mp_stash_in
(mp
, black_part
(r
));
22740 mp_init_pair_node
(mp
, q
);
22741 r
= value_node
(q
);
22742 mp_stash_in
(mp
, y_part
(r
));
22743 mp_unstash_cur_exp
(mp
, p
);
22744 mp_stash_in
(mp
, x_part
(r
));
22746 mp_check_delimiter
(mp
, l_delim
, r_delim
);
22747 mp-
>cur_exp.type
= mp_type
(q
);
22748 set_cur_exp_node
(q
);
22751 mp_check_delimiter
(mp
, l_delim
, r_delim
);
22755 case mp_begin_group
:
22756 /* Scan a grouped primary
*/
22757 /* The local variable |group_line| keeps track of the line
22758 where a \
&{begingroup} command occurred; this will be useful
22759 in an error message if the group doesn't actually end.
*/
22761 integer group_line
; /* where a group began
*/
22762 group_line
= mp_true_line
(mp
);
22763 if
(number_positive
(internal_value
(mp_tracing_commands
)))
22765 mp_save_boundary
(mp
);
22767 mp_do_statement
(mp
); /* ends with |cur_cmd
>=semicolon|
*/
22768 } while
(cur_cmd
() == mp_semicolon
);
22769 if
(cur_cmd
() != mp_end_group
) {
22771 const char
*hlp
[] = {
22772 "I saw a `begingroup' back there that hasn't been matched",
22773 "by `endgroup'. So I've inserted `endgroup' now.",
22775 mp_snprintf
(msg
, 256, "A group begun on line %d never ended", (int
)group_line
);
22776 mp_back_error
(mp
, msg
, hlp
, true
);
22777 set_cur_cmd
((mp_variable_type
)mp_end_group
);
22780 /* this might change |cur_type|
, if independent variables are recycled
*/
22781 if
(number_positive
(internal_value
(mp_tracing_commands
)))
22785 case mp_string_token
:
22786 /* Scan a string constant
*/
22787 mp-
>cur_exp.type
= mp_string_type
;
22788 set_cur_exp_str
(cur_mod_str
());
22790 case mp_numeric_token
:
22792 /* Scan a primary that starts with a numeric token
*/
22793 /* A numeric token might be a primary by itself
, or it might be the
22794 numerator of a fraction composed solely of numeric tokens
, or it might
22795 multiply the primary that follows
(provided that the primary doesn't begin
22796 with a plus sign or a minus sign
). The code here uses the facts that
22797 |max_primary_command
=plus_or_minus| and
22798 |max_primary_command-1
=numeric_token|. If a fraction is found that is less
22799 than unity
, we try to retain higher precision when we use it in scalar
22801 mp_number num
, denom
; /* for primaries that are fractions
, like `
1/2'
*/
22803 new_number
(denom
);
22804 set_cur_exp_value_number
(cur_mod_number
());
22805 mp-
>cur_exp.type
= mp_known
;
22806 mp_get_x_next
(mp
);
22807 if
(cur_cmd
() != mp_slash
) {
22808 set_number_to_zero
(num
);
22809 set_number_to_zero
(denom
);
22811 mp_get_x_next
(mp
);
22812 if
(cur_cmd
() != mp_numeric_token
) {
22813 mp_back_input
(mp
);
22814 set_cur_cmd
((mp_variable_type
)mp_slash
);
22815 set_cur_mod
(mp_over
);
22816 set_cur_sym
(mp-
>frozen_slash
);
22818 free_number
(denom
);
22821 number_clone
(num
, cur_exp_value_number
());
22822 number_clone
(denom
, cur_mod_number
());
22823 if
(number_zero
(denom
)) {
22824 /* Protest division by zero
*/
22825 const char
*hlp
[] = { "I'll pretend that you meant to divide by 1.", NULL };
22826 mp_error
(mp
, "Division by zero", hlp
, true
);
22830 make_scaled
(ret
, num
, denom
);
22831 set_cur_exp_value_number
(ret
);
22835 mp_get_x_next
(mp
);
22837 if
(cur_cmd
() >= mp_min_primary_command
) {
22838 if
(cur_cmd
() < mp_numeric_token
) { /* in particular
, |cur_cmd
<>plus_or_minus|
*/
22839 mp_node p
; /* for list manipulation
*/
22840 mp_number absnum
, absdenom
;
22841 new_number
(absnum
);
22842 new_number
(absdenom
);
22843 p
= mp_stash_cur_exp
(mp
);
22844 mp_scan_primary
(mp
);
22845 number_clone
(absnum
, num
);
22846 number_abs
(absnum
);
22847 number_clone
(absdenom
, denom
);
22848 number_abs
(absdenom
);
22849 if
(number_greaterequal
(absnum
, absdenom
) ||
(mp-
>cur_exp.type
< mp_color_type
)) {
22850 mp_do_binary
(mp
, p
, mp_times
);
22852 mp_frac_mult
(mp
, num
, denom
);
22853 mp_free_value_node
(mp
, p
);
22855 free_number
(absnum
);
22856 free_number
(absdenom
);
22860 free_number
(denom
);
22865 /* Scan a nullary operation
*/
22866 mp_do_nullary
(mp
, (quarterword
) cur_mod
());
22871 case mp_plus_or_minus
:
22873 /* Scan a unary operation
*/
22874 quarterword c
; /* a primitive operation code
*/
22875 c
= (quarterword
) cur_mod
();
22876 mp_get_x_next
(mp
);
22877 mp_scan_primary
(mp
);
22878 mp_do_unary
(mp
, c
);
22882 case mp_primary_binary
:
22884 /* Scan a binary operation with `\
&{of}' between its operands */
22885 mp_node p
; /* for list manipulation
*/
22886 quarterword c
; /* a primitive operation code
*/
22887 c
= (quarterword
) cur_mod
();
22888 mp_get_x_next
(mp
);
22889 mp_scan_expression
(mp
);
22890 if
(cur_cmd
() != mp_of_token
) {
22893 const char
*hlp
[] = {
22894 "I've got the first argument; will look now for the other.",
22896 int old_setting
= mp-
>selector
;
22897 mp-
>selector
= new_string
;
22898 mp_print_cmd_mod
(mp
, mp_primary_binary
, c
);
22899 mp-
>selector
= old_setting
;
22900 sname
= mp_make_string
(mp
);
22901 mp_snprintf
(msg
, 256, "Missing `of' has been inserted for %s", mp_str
(mp
, sname
));
22902 delete_str_ref
(sname
);
22903 mp_back_error
(mp
, msg
, hlp
, true
);
22905 p
= mp_stash_cur_exp
(mp
);
22906 mp_get_x_next
(mp
);
22907 mp_scan_primary
(mp
);
22908 mp_do_binary
(mp
, p
, c
);
22913 /* Convert a suffix to a string
*/
22914 mp_get_x_next
(mp
);
22915 mp_scan_suffix
(mp
);
22916 mp-
>old_setting
= mp-
>selector
;
22917 mp-
>selector
= new_string
;
22918 mp_show_token_list
(mp
, cur_exp_node
(), NULL, 100000, 0);
22919 mp_flush_token_list
(mp
, cur_exp_node
());
22920 set_cur_exp_str
(mp_make_string
(mp
));
22921 mp-
>selector
= mp-
>old_setting
;
22922 mp-
>cur_exp.type
= mp_string_type
;
22925 case mp_internal_quantity
:
22926 /* Scan an internal numeric quantity
*/
22927 /* If an internal quantity appears all by itself on the left of an
22928 assignment
, we return a token list of length one
, containing the address
22929 of the internal quantity
, with |name_type| equal to |mp_internal_sym|.
22930 (This accords with the conventions of the save stack
, as described earlier.
) */
22932 halfword qq
= cur_mod
();
22933 if
(my_var_flag
== mp_assignment
) {
22934 mp_get_x_next
(mp
);
22935 if
(cur_cmd
() == mp_assignment
) {
22936 set_cur_exp_node
(mp_get_symbolic_node
(mp
));
22937 set_mp_sym_info
(cur_exp_node
(), qq
);
22938 mp_name_type
(cur_exp_node
()) = mp_internal_sym
;
22939 mp-
>cur_exp.type
= mp_token_list
;
22942 mp_back_input
(mp
);
22944 if
(internal_type
(qq
) == mp_string_type
) {
22945 set_cur_exp_str
(internal_string
(qq
));
22947 set_cur_exp_value_number
(internal_value
(qq
));
22949 mp-
>cur_exp.type
= internal_type
(qq
);
22952 case mp_capsule_token
:
22953 mp_make_exp_copy
(mp
, cur_mod_node
());
22956 @
<Scan a variable primary
; |goto restart| if it turns out to be a macro@
>;
22959 mp_bad_exp
(mp
, "A primary");
22963 mp_get_x_next
(mp
); /* the routines |goto done| if they don't want this
*/
22965 check_for_mediation
(mp
);
22968 @ Expressions of the form `\.
{a
[b
,c
]}' are converted into
22969 `\.
{b
+a
*(c-b
)}'
, without checking the types of \.b~or~\.c
,
22970 provided that \.a is numeric.
22972 @
<Declare the basic parsing subroutines@
>=
22973 static void check_for_mediation
(MP mp
) {
22974 mp_node p
, q
, r
; /* for list manipulation
*/
22975 if
(cur_cmd
() == mp_left_bracket
) {
22976 if
(mp-
>cur_exp.type
>= mp_known
) {
22977 /* Scan a mediation construction
*/
22978 p
= mp_stash_cur_exp
(mp
);
22979 mp_get_x_next
(mp
);
22980 mp_scan_expression
(mp
);
22981 if
(cur_cmd
() != mp_comma
) {
22982 /* Put the left bracket and the expression back to be rescanned
*/
22983 /* The left bracket that we thought was introducing a subscript might have
22984 actually been the left bracket in a mediation construction like `\.
{x
[a
,b
]}'.
22985 So we don't issue an error message at this point
; but we do want to back up
22986 so as to avoid any embarrassment about our incorrect assumption.
*/
22987 mp_back_input
(mp
); /* that was the token following the current expression
*/
22989 set_cur_cmd
((mp_variable_type
)mp_left_bracket
);
22990 set_cur_mod_number
(zero_t
);
22991 set_cur_sym
(mp-
>frozen_left_bracket
);
22992 mp_unstash_cur_exp
(mp
, p
);
22994 q
= mp_stash_cur_exp
(mp
);
22995 mp_get_x_next
(mp
);
22996 mp_scan_expression
(mp
);
22997 if
(cur_cmd
() != mp_right_bracket
) {
22998 const char
*hlp
[] = {
22999 "I've scanned an expression of the form `a[b,c',",
23000 "so a right bracket should have come next.",
23001 "I shall pretend that one was there.",
23003 mp_back_error
(mp
, "Missing `]' has been inserted", hlp
, true
);
23005 r
= mp_stash_cur_exp
(mp
);
23006 mp_make_exp_copy
(mp
, q
);
23007 mp_do_binary
(mp
, r
, mp_minus
);
23008 mp_do_binary
(mp
, p
, mp_times
);
23009 mp_do_binary
(mp
, q
, mp_plus
);
23010 mp_get_x_next
(mp
);
23017 @ Errors at the beginning of expressions are flagged by |bad_exp|.
23020 static void mp_bad_exp
(MP mp
, const char
*s
) {
23023 const char
*hlp
[] = {
23024 "I'm afraid I need some sort of value in order to continue,",
23025 "so I've tentatively inserted `0'. You may want to",
23026 "delete this zero and insert something else;",
23027 "see Chapter 27 of The METAFONTbook for an example.",
23029 @
:METAFONTbook
}{\sl The
{\logos METAFONT\
/}book@
>;
23032 int old_selector
= mp-
>selector
;
23033 mp-
>selector
= new_string
;
23034 mp_print_cmd_mod
(mp
, cur_cmd
(), cur_mod
());
23035 mp-
>selector
= old_selector
;
23036 cm
= mp_make_string
(mp
);
23037 mp_snprintf
(msg
, 256, "%s expression can't begin with `%s'", s
, mp_str
(mp
, cm
));
23038 delete_str_ref
(cm
);
23040 mp_back_input
(mp
);
23042 set_cur_cmd
((mp_variable_type
)mp_numeric_token
);
23043 set_cur_mod_number
(zero_t
);
23044 mp_ins_error
(mp
, msg
, hlp
, true
);
23045 save_flag
= mp-
>var_flag
;
23047 mp_get_x_next
(mp
);
23048 mp-
>var_flag
= save_flag
;
23052 @ The |stash_in| subroutine puts the current
(numeric
) expression into a field
23053 within a ``big node.''
23056 static void mp_stash_in
(MP mp
, mp_node p
) {
23057 mp_value_node q
; /* temporary register
*/
23058 mp_type
(p
) = mp-
>cur_exp.type
;
23059 if
(mp-
>cur_exp.type
== mp_known
) {
23060 set_value_number
(p
, cur_exp_value_number
());
23062 if
(mp-
>cur_exp.type
== mp_independent
) {
23063 /* Stash an independent |cur_exp| into a big node
*/
23064 /* In rare cases the current expression can become |independent|. There
23065 may be many dependency lists pointing to such an independent capsule
,
23066 so we can't simply move it into place within a big node. Instead
,
23067 we copy it
, then recycle it.
*/
23068 q
= mp_single_dependency
(mp
, cur_exp_node
());
23069 if
(q
== mp-
>dep_final
) {
23070 mp_type
(p
) = mp_known
;
23071 set_value_number
(p
, zero_t
);
23072 mp_free_dep_node
(mp
, q
);
23074 mp_new_dep
(mp
, p
, mp_dependent
, q
);
23076 mp_recycle_value
(mp
, cur_exp_node
());
23077 mp_free_value_node
(mp
, cur_exp_node
());
23079 set_dep_list
((mp_value_node
) p
,
23080 dep_list
((mp_value_node
) cur_exp_node
()));
23081 set_prev_dep
((mp_value_node
) p
,
23082 prev_dep
((mp_value_node
) cur_exp_node
()));
23083 set_mp_link
(prev_dep
((mp_value_node
) p
), p
);
23084 mp_free_dep_node
(mp
, (mp_value_node
) cur_exp_node
());
23087 mp-
>cur_exp.type
= mp_vacuous
;
23090 @ The most difficult part of |scan_primary| has been saved for last
, since
23091 it was necessary to build up some confidence first. We can now face the task
23092 of scanning a variable.
23094 As we scan a variable
, we build a token list containing the relevant
23095 names and subscript values
, simultaneously following along in the
23096 ``collective'' structure to see if we are actually dealing with a macro
23097 instead of a value.
23099 The local variables |pre_head| and |post_head| will point to the beginning
23100 of the prefix and suffix lists
; |tail| will point to the end of the list
23101 that is currently growing.
23103 Another local variable
, |tt|
, contains partial information about the
23104 declared type of the variable-so-far. If |tt
>=mp_unsuffixed_macro|
, the
23105 relation |tt
=mp_type
(q
)| will always hold. If |tt
=undefined|
, the routine
23106 doesn't bother to update its information about type. And if
23107 |undefined
<tt
<mp_unsuffixed_macro|
, the precise value of |tt| isn't critical.
23109 @ @
<Scan a variable primary...@
>=
23111 mp_node p
, q
; /* for list manipulation
*/
23112 mp_node t
; /* a token
*/
23113 mp_node pre_head
, post_head
, tail
; /* prefix and suffix list variables
*/
23114 quarterword tt
; /* approximation to the type of the variable-so-far
*/
23115 mp_node macro_ref
= 0; /* reference count for a suffixed macro
*/
23116 pre_head
= mp_get_symbolic_node
(mp
);
23121 t
= mp_cur_tok
(mp
);
23122 mp_link
(tail
) = t
;
23123 if
(tt
!= mp_undefined
) {
23124 /* Find the approximate type |tt| and corresponding~|q|
*/
23125 /* Every time we call |get_x_next|
, there's a chance that the variable we've
23126 been looking at will disappear. Thus
, we cannot safely keep |q| pointing
23127 into the variable structure
; we need to start searching from the root each
23130 p
= mp_link
(pre_head
);
23131 qq
= mp_sym_sym
(p
);
23133 if
(eq_type
(qq
) % mp_outer_tag
== mp_tag_token
) {
23134 q
= equiv_node
(qq
);
23143 if
(mp_type
(q
) != mp_structured
)
23145 q
= mp_link
(attr_head
(q
)); /* the |collective_subscript| attribute
*/
23146 if
(mp_type
(p
) == mp_symbol_node
) { /* it's not a subscript
*/
23149 } while
(!(hashloc
(q
) >= mp_sym_sym
(p
)));
23150 if
(hashloc
(q
) > mp_sym_sym
(p
))
23157 if
(tt
>= mp_unsuffixed_macro
) {
23158 /* Either begin an unsuffixed macro call or
23159 prepare for a suffixed one
*/
23160 mp_link
(tail
) = NULL;
23161 if
(tt
> mp_unsuffixed_macro
) { /* |tt
=mp_suffixed_macro|
*/
23162 post_head
= mp_get_symbolic_node
(mp
);
23164 mp_link
(tail
) = t
;
23166 macro_ref
= value_node
(q
);
23167 add_mac_ref
(macro_ref
);
23169 /* Set up unsuffixed macro call and |goto restart|
*/
23170 /* The only complication associated with macro calling is that the prefix
23171 and ``at'' parameters must be packaged in an appropriate list of lists.
*/
23172 p
= mp_get_symbolic_node
(mp
);
23173 set_mp_sym_sym
(pre_head
, mp_link
(pre_head
));
23174 mp_link
(pre_head
) = p
;
23175 set_mp_sym_sym
(p
, t
);
23176 mp_macro_call
(mp
, value_node
(q
), pre_head
, NULL);
23177 mp_get_x_next
(mp
);
23182 mp_get_x_next
(mp
);
23184 if
(cur_cmd
() == mp_left_bracket
) {
23185 /* Scan for a subscript
; replace |cur_cmd| by |numeric_token| if found
*/
23186 mp_get_x_next
(mp
);
23187 mp_scan_expression
(mp
);
23188 if
(cur_cmd
() != mp_right_bracket
) {
23189 /* Put the left bracket and the expression back to be rescanned
*/
23190 /* The left bracket that we thought was introducing a subscript might have
23191 actually been the left bracket in a mediation construction like `\.
{x
[a
,b
]}'.
23192 So we don't issue an error message at this point
; but we do want to back up
23193 so as to avoid any embarrassment about our incorrect assumption.
*/
23194 mp_back_input
(mp
); /* that was the token following the current expression
*/
23196 set_cur_cmd
((mp_variable_type
)mp_left_bracket
);
23197 set_cur_mod_number
(zero_t
);
23198 set_cur_sym
(mp-
>frozen_left_bracket
);
23201 if
(mp-
>cur_exp.type
!= mp_known
)
23202 mp_bad_subscript
(mp
);
23203 set_cur_cmd
((mp_variable_type
)mp_numeric_token
);
23204 set_cur_mod_number
(cur_exp_value_number
());
23208 if
(cur_cmd
() > mp_max_suffix_token
)
23210 if
(cur_cmd
() < mp_min_suffix_token
)
23212 } /* now |cur_cmd| is |internal_quantity|
, |tag_token|
, or |numeric_token|
*/
23213 /* Handle unusual cases that masquerade as variables
, and |goto restart| or
23214 |goto done| if appropriate
; otherwise make a copy of the variable and |goto done|
*/
23215 /* If the variable does exist
, we also need to check
23216 for a few other special cases before deciding that a plain old ordinary
23217 variable has
, indeed
, been scanned.
*/
23218 if
(post_head
!= NULL) {
23219 /* Set up suffixed macro call and |goto restart|
*/
23220 /* If the ``variable'' that turned out to be a suffixed macro no longer exists
,
23221 we don't care
, because we have reserved a pointer
(|macro_ref|
) to its
23223 mp_back_input
(mp
);
23224 p
= mp_get_symbolic_node
(mp
);
23225 q
= mp_link
(post_head
);
23226 set_mp_sym_sym
(pre_head
, mp_link
(pre_head
));
23227 mp_link
(pre_head
) = post_head
;
23228 set_mp_sym_sym
(post_head
, q
);
23229 mp_link
(post_head
) = p
;
23230 set_mp_sym_sym
(p
, mp_link
(q
));
23231 mp_link
(q
) = NULL;
23232 mp_macro_call
(mp
, macro_ref
, pre_head
, NULL);
23233 decr_mac_ref
(macro_ref
);
23234 mp_get_x_next
(mp
);
23237 q
= mp_link
(pre_head
);
23238 mp_free_symbolic_node
(mp
, pre_head
);
23239 if
(cur_cmd
() == my_var_flag
) {
23240 mp-
>cur_exp.type
= mp_token_list
;
23241 set_cur_exp_node
(q
);
23244 p
= mp_find_variable
(mp
, q
);
23246 mp_make_exp_copy
(mp
, p
);
23249 const char
*hlp
[] = {
23250 "While I was evaluating the suffix of this variable,",
23251 "something was redefined, and it's no longer a variable!",
23252 "In order to get back on my feet, I've inserted `0' instead.",
23254 char
*msg
= mp_obliterated
(mp
, q
);
23255 memset
(&new_expr,0,sizeof(mp_value));
23256 new_number
(new_expr.data.n
);
23257 set_number_to_zero
(new_expr.data.n
);
23258 mp_back_error
(mp
, msg
, hlp
, true
);
23260 mp_get_x_next
(mp
);
23261 mp_flush_cur_exp
(mp
, new_expr
);
23263 mp_flush_node_list
(mp
, q
);
23268 @ Here's a routine that puts the current expression back to be read again.
23271 static void mp_back_expr
(MP mp
) {
23272 mp_node p
; /* capsule token
*/
23273 p
= mp_stash_cur_exp
(mp
);
23274 mp_link
(p
) = NULL;
23279 @ Unknown subscripts lead to the following error message.
23282 static void mp_bad_subscript
(MP mp
) {
23284 const char
*hlp
[] = {
23285 "A bracketed subscript must have a known numeric value;",
23286 "unfortunately, what I found was the value that appears just",
23287 "above this error message. So I'll try a zero subscript.",
23289 memset
(&new_expr,0,sizeof(mp_value));
23290 new_number
(new_expr.data.n
);
23291 mp_disp_err
(mp
, NULL);
23292 mp_error
(mp
, "Improper subscript has been replaced by zero", hlp
, true
);
23293 @.Improper subscript...@
>;
23294 mp_flush_cur_exp
(mp
, new_expr
);
23298 @ How do things stand now? Well
, we have scanned an entire variable name
,
23299 including possible subscripts and
/or attributes
; |cur_cmd|
, |cur_mod|
, and
23300 |cur_sym| represent the token that follows. If |post_head
=NULL|
, a
23301 token list for this variable name starts at |mp_link
(pre_head
)|
, with all
23302 subscripts evaluated. But if |post_head
<>NULL|
, the variable turned out
23303 to be a suffixed macro
; |pre_head| is the head of the prefix list
, while
23304 |post_head| is the head of a token list containing both `\.
{\
AT!}' and
23307 Our immediate problem is to see if this variable still exists.
(Variable
23308 structures can change drastically whenever we call |get_x_next|
; users
23309 aren't supposed to do this
, but the fact that it is possible means that
23310 we must be cautious.
)
23312 The following procedure creates an error message for when a variable
23313 unexpectedly disappears.
23316 static char
*mp_obliterated
(MP mp
, mp_node q
) {
23319 int old_setting
= mp-
>selector
;
23320 mp-
>selector
= new_string
;
23321 mp_show_token_list
(mp
, q
, NULL, 1000, 0);
23322 sname
= mp_make_string
(mp
);
23323 mp-
>selector
= old_setting
;
23324 mp_snprintf
(msg
, 256, "Variable %s has been obliterated", mp_str
(mp
, sname
));
23325 @.Variable...obliterated@
>;
23326 delete_str_ref
(sname
);
23327 return xstrdup
(msg
);
23331 @ Our remaining job is simply to make a copy of the value that has been
23332 found. Some cases are harder than others
, but complexity arises solely
23333 because of the multiplicity of possible cases.
23335 @
<Declare the procedure called |make_exp_copy|@
>=
23336 @
<Declare subroutines needed by |make_exp_copy|@
>;
23337 static void mp_make_exp_copy
(MP mp
, mp_node p
) {
23338 mp_node t
; /* register
(s
) for list manipulation
*/
23341 mp-
>cur_exp.type
= mp_type
(p
);
23342 switch
(mp-
>cur_exp.type
) {
23344 case mp_boolean_type
:
23346 set_cur_exp_value_number
(value_number
(p
));
23348 case unknown_types
:
23349 t
= mp_new_ring_entry
(mp
, p
);
23350 set_cur_exp_node
(t
);
23352 case mp_string_type
:
23353 set_cur_exp_str
(value_str
(p
));
23355 case mp_picture_type
:
23356 set_cur_exp_node
(value_node
(p
));
23357 add_edge_ref
(cur_exp_node
());
23360 set_cur_exp_knot
(copy_pen
(value_knot
(p
)));
23363 set_cur_exp_knot
(mp_copy_path
(mp
, value_knot
(p
)));
23365 case mp_transform_type
:
23366 case mp_color_type
:
23367 case mp_cmykcolor_type
:
23369 /* Copy the big node |p|
*/
23370 /* The most tedious case arises when the user refers to a
23371 \
&{pair}, \&{color}, or \&{transform} variable; we must copy several fields,
23372 each of which can be |independent|
, |dependent|
, |mp_proto_dependent|
,
23374 if
(value_node
(p
) == NULL) {
23375 switch
(mp_type
(p
)) {
23377 mp_init_pair_node
(mp
, p
);
23379 case mp_color_type
:
23380 mp_init_color_node
(mp
, p
);
23382 case mp_cmykcolor_type
:
23383 mp_init_cmykcolor_node
(mp
, p
);
23385 case mp_transform_type
:
23386 mp_init_transform_node
(mp
, p
);
23388 default
: /* there are no other valid cases
, but please the compiler
*/
23392 t
= mp_get_value_node
(mp
);
23393 mp_name_type
(t
) = mp_capsule
;
23394 q
= (mp_value_node
)value_node
(p
);
23395 switch
(mp-
>cur_exp.type
) {
23397 mp_init_pair_node
(mp
, t
);
23398 mp_install
(mp
, y_part
(value_node
(t
)), y_part
(q
));
23399 mp_install
(mp
, x_part
(value_node
(t
)), x_part
(q
));
23401 case mp_color_type
:
23402 mp_init_color_node
(mp
, t
);
23403 mp_install
(mp
, blue_part
(value_node
(t
)), blue_part
(q
));
23404 mp_install
(mp
, green_part
(value_node
(t
)), green_part
(q
));
23405 mp_install
(mp
, red_part
(value_node
(t
)), red_part
(q
));
23407 case mp_cmykcolor_type
:
23408 mp_init_cmykcolor_node
(mp
, t
);
23409 mp_install
(mp
, black_part
(value_node
(t
)), black_part
(q
));
23410 mp_install
(mp
, yellow_part
(value_node
(t
)), yellow_part
(q
));
23411 mp_install
(mp
, magenta_part
(value_node
(t
)), magenta_part
(q
));
23412 mp_install
(mp
, cyan_part
(value_node
(t
)), cyan_part
(q
));
23414 case mp_transform_type
:
23415 mp_init_transform_node
(mp
, t
);
23416 mp_install
(mp
, yy_part
(value_node
(t
)), yy_part
(q
));
23417 mp_install
(mp
, yx_part
(value_node
(t
)), yx_part
(q
));
23418 mp_install
(mp
, xy_part
(value_node
(t
)), xy_part
(q
));
23419 mp_install
(mp
, xx_part
(value_node
(t
)), xx_part
(q
));
23420 mp_install
(mp
, ty_part
(value_node
(t
)), ty_part
(q
));
23421 mp_install
(mp
, tx_part
(value_node
(t
)), tx_part
(q
));
23423 default
: /* there are no other valid cases
, but please the compiler
*/
23426 set_cur_exp_node
(t
);
23429 case mp_proto_dependent
:
23430 mp_encapsulate
(mp
,
23431 mp_copy_dep_list
(mp
,
23432 (mp_value_node
) dep_list
((mp_value_node
)
23435 case mp_numeric_type
:
23436 mp_new_indep
(mp
, p
);
23439 case mp_independent
:
23440 q
= mp_single_dependency
(mp
, p
);
23441 if
(q
== mp-
>dep_final
) {
23442 mp-
>cur_exp.type
= mp_known
;
23443 set_cur_exp_value_number
(zero_t
);
23444 mp_free_dep_node
(mp
, q
);
23446 mp-
>cur_exp.type
= mp_dependent
;
23447 mp_encapsulate
(mp
, q
);
23451 mp_confusion
(mp
, "copy");
23452 @
:this can't happen copy
}{\quad copy@
>;
23458 @ The |encapsulate| subroutine assumes that |dep_final| is the
23459 tail of dependency list~|p|.
23461 @
<Declare subroutines needed by |make_exp_copy|@
>=
23462 static void mp_encapsulate
(MP mp
, mp_value_node p
) {
23463 mp_node q
= mp_get_value_node
(mp
);
23464 FUNCTION_TRACE2
("mp_encapsulate(%p)\n", p
);
23465 mp_name_type
(q
) = mp_capsule
;
23466 mp_new_dep
(mp
, q
, mp-
>cur_exp.type
, p
);
23467 set_cur_exp_node
(q
);
23470 @ The |install| procedure copies a numeric field~|q| into field~|r| of
23471 a big node that will be part of a capsule.
23473 @
<Declare subroutines needed by |make_exp_copy|@
>=
23474 static void mp_install
(MP mp
, mp_node r
, mp_node q
) {
23475 mp_value_node p
; /* temporary register
*/
23476 if
(mp_type
(q
) == mp_known
) {
23477 mp_type
(r
) = mp_known
;
23478 set_value_number
(r
, value_number
(q
));
23479 } else if
(mp_type
(q
) == mp_independent
) {
23480 p
= mp_single_dependency
(mp
, q
);
23481 if
(p
== mp-
>dep_final
) {
23482 mp_type
(r
) = mp_known
;
23483 set_value_number
(r
, zero_t
);
23484 mp_free_dep_node
(mp
, p
);
23486 mp_new_dep
(mp
, r
, mp_dependent
, p
);
23489 mp_new_dep
(mp
, r
, mp_type
(q
),
23490 mp_copy_dep_list
(mp
, (mp_value_node
) dep_list
((mp_value_node
)
23496 @ Here is a comparatively simple routine that is used to scan the
23497 \
&{suffix} parameters of a macro.
23499 @
<Declare the basic parsing subroutines@
>=
23500 static void mp_scan_suffix
(MP mp
) {
23501 mp_node h
, t
; /* head and tail of the list being built
*/
23502 mp_node p
; /* temporary register
*/
23503 h
= mp_get_symbolic_node
(mp
);
23506 if
(cur_cmd
() == mp_left_bracket
) {
23507 /* Scan a bracketed subscript and set |cur_cmd
:=numeric_token|
*/
23508 mp_get_x_next
(mp
);
23509 mp_scan_expression
(mp
);
23510 if
(mp-
>cur_exp.type
!= mp_known
)
23511 mp_bad_subscript
(mp
);
23512 if
(cur_cmd
() != mp_right_bracket
) {
23513 const char
*hlp
[] = {
23514 "I've seen a `[' and a subscript value, in a suffix,",
23515 "so a right bracket should have come next.",
23516 "I shall pretend that one was there.",
23518 mp_back_error
(mp
, "Missing `]' has been inserted", hlp
, true
);
23520 set_cur_cmd
((mp_variable_type
)mp_numeric_token
);
23521 set_cur_mod_number
(cur_exp_value_number
());
23524 if
(cur_cmd
() == mp_numeric_token
) {
23527 number_clone
(arg1
, cur_mod_number
());
23528 p
= mp_new_num_tok
(mp
, arg1
);
23529 free_number
(arg1
);
23530 } else if
((cur_cmd
() == mp_tag_token
) ||
(cur_cmd
() == mp_internal_quantity
)) {
23531 p
= mp_get_symbolic_node
(mp
);
23532 set_mp_sym_sym
(p
, cur_sym
());
23533 mp_name_type
(p
) = cur_sym_mod
();
23539 mp_get_x_next
(mp
);
23541 set_cur_exp_node
(mp_link
(h
));
23542 mp_free_symbolic_node
(mp
, h
);
23543 mp-
>cur_exp.type
= mp_token_list
;
23546 @
* Parsing secondary and higher expressions.
23548 After the intricacies of |scan_primary|\kern-1pt
,
23549 the |scan_secondary| routine is
23550 refreshingly simple. It's not trivial
, but the operations are relatively
23551 straightforward
; the main difficulty is
, again
, that expressions and data
23552 structures might change drastically every time we call |get_x_next|
, so a
23553 cautious approach is mandatory. For example
, a macro defined by
23554 \
&{primarydef} might have disappeared by the time its second argument has
23555 been scanned
; we solve this by increasing the reference count of its token
23556 list
, so that the macro can be called even after it has been clobbered.
23558 @
<Declare the basic parsing subroutines@
>=
23559 static void mp_scan_secondary
(MP mp
) {
23560 mp_node p
; /* for list manipulation
*/
23561 halfword c
, d
; /* operation codes or modifiers
*/
23563 mp_sym mac_name
= NULL; /* token defined with \
&{primarydef} */
23565 if
((cur_cmd
() < mp_min_primary_command
) ||
23566 (cur_cmd
() > mp_max_primary_command
))
23567 mp_bad_exp
(mp
, "A secondary");
23568 @.A secondary expression...@
>;
23569 mp_scan_primary
(mp
);
23571 if
(cur_cmd
() <= mp_max_secondary_command
&&
23572 cur_cmd
() >= mp_min_secondary_command
) {
23573 p
= mp_stash_cur_exp
(mp
);
23576 if
(d
== mp_secondary_primary_macro
) {
23577 cc
= cur_mod_node
();
23578 mac_name
= cur_sym
();
23581 mp_get_x_next
(mp
);
23582 mp_scan_primary
(mp
);
23583 if
(d
!= mp_secondary_primary_macro
) {
23584 mp_do_binary
(mp
, p
, c
);
23586 mp_back_input
(mp
);
23587 mp_binary_mac
(mp
, p
, cc
, mac_name
);
23589 mp_get_x_next
(mp
);
23597 @ The following procedure calls a macro that has two parameters
,
23601 static void mp_binary_mac
(MP mp
, mp_node p
, mp_node c
, mp_sym n
) {
23602 mp_node q
, r
; /* nodes in the parameter list
*/
23603 q
= mp_get_symbolic_node
(mp
);
23604 r
= mp_get_symbolic_node
(mp
);
23606 set_mp_sym_sym
(q
, p
);
23607 set_mp_sym_sym
(r
, mp_stash_cur_exp
(mp
));
23608 mp_macro_call
(mp
, c
, q
, n
);
23612 @ The next procedure
, |scan_tertiary|
, is pretty much the same deal.
23614 @
<Declare the basic parsing subroutines@
>=
23615 static void mp_scan_tertiary
(MP mp
) {
23616 mp_node p
; /* for list manipulation
*/
23617 halfword c
, d
; /* operation codes or modifiers
*/
23619 mp_sym mac_name
= NULL; /* token defined with \
&{secondarydef} */
23621 if
((cur_cmd
() < mp_min_primary_command
) ||
23622 (cur_cmd
() > mp_max_primary_command
))
23623 mp_bad_exp
(mp
, "A tertiary");
23624 @.A tertiary expression...@
>;
23625 mp_scan_secondary
(mp
);
23627 if
(cur_cmd
() <= mp_max_tertiary_command
) {
23628 if
(cur_cmd
() >= mp_min_tertiary_command
) {
23629 p
= mp_stash_cur_exp
(mp
);
23632 if
(d
== mp_tertiary_secondary_macro
) {
23633 cc
= cur_mod_node
();
23634 mac_name
= cur_sym
();
23637 mp_get_x_next
(mp
);
23638 mp_scan_secondary
(mp
);
23639 if
(d
!= mp_tertiary_secondary_macro
) {
23640 mp_do_binary
(mp
, p
, c
);
23642 mp_back_input
(mp
);
23643 mp_binary_mac
(mp
, p
, cc
, mac_name
);
23645 mp_get_x_next
(mp
);
23654 @ Finally we reach the deepest level in our quartet of parsing routines.
23655 This one is much like the others
; but it has an extra complication from
23656 paths
, which materialize here.
23658 @
<Declare the basic parsing subroutines@
>=
23659 static int mp_scan_path
(MP mp
);
23660 static void mp_scan_expression
(MP mp
) {
23661 int my_var_flag
; /* initial value of |var_flag|
*/
23662 my_var_flag
= mp-
>var_flag
;
23663 check_expansion_depth
();
23665 if
((cur_cmd
() < mp_min_primary_command
) ||
23666 (cur_cmd
() > mp_max_primary_command
))
23667 mp_bad_exp
(mp
, "An");
23668 @.An expression...@
>;
23669 mp_scan_tertiary
(mp
);
23671 if
(cur_cmd
() <= mp_max_expression_command
) {
23672 if
(cur_cmd
() >= mp_min_expression_command
) {
23673 if
((cur_cmd
() != mp_equals
) ||
(my_var_flag
!= mp_assignment
)) {
23674 mp_node p
; /* for list manipulation
*/
23677 halfword d
; /* operation codes or modifiers
*/
23678 mp_sym mac_name
; /* token defined with \
&{tertiarydef} */
23680 p
= mp_stash_cur_exp
(mp
);
23683 if
(d
== mp_expression_tertiary_macro
) {
23684 cc
= cur_mod_node
();
23685 mac_name
= cur_sym
();
23688 if
((d
< mp_ampersand
) ||
((d
== mp_ampersand
) &&
23689 ((mp_type
(p
) == mp_pair_type
)
23690 ||
(mp_type
(p
) == mp_path_type
)))) {
23691 /* Scan a path construction operation
; but |return| if |p| has the wrong type
*/
23693 mp_unstash_cur_exp
(mp
, p
);
23694 if
(!mp_scan_path
(mp
)) {
23695 mp-
>expand_depth_count--
;
23699 mp_get_x_next
(mp
);
23700 mp_scan_tertiary
(mp
);
23701 if
(d
!= mp_expression_tertiary_macro
) {
23702 mp_do_binary
(mp
, p
, c
);
23704 mp_back_input
(mp
);
23705 mp_binary_mac
(mp
, p
, cc
, mac_name
);
23707 mp_get_x_next
(mp
);
23715 mp-
>expand_depth_count--
;
23719 @ The reader should review the data structure conventions for paths before
23720 hoping to understand the next part of this code.
23722 @d min_tension three_quarter_unit_t
23724 @
<Declare the basic parsing subroutines@
>=
23725 static void force_valid_tension_setting
(MP mp
) {
23726 if
((mp-
>cur_exp.type
!= mp_known
) || number_less
(cur_exp_value_number
(), min_tension
)) {
23728 const char
*hlp
[] = {
23729 "The expression above should have been a number >=3/4.",
23731 memset
(&new_expr,0,sizeof(mp_value));
23732 new_number
(new_expr.data.n
);
23733 mp_disp_err
(mp
, NULL);
23734 number_clone
(new_expr.data.n
, unity_t
);
23735 mp_back_error
(mp
, "Improper tension has been set to 1", hlp
, true
);
23736 mp_get_x_next
(mp
);
23737 mp_flush_cur_exp
(mp
, new_expr
);
23740 static int mp_scan_path
(MP mp
) {
23741 mp_knot path_p
, path_q
, r
;
23743 halfword d
; /* operation code or modifier
*/
23744 boolean cycle_hit
; /* did a path expression just end with `\
&{cycle}'? */
23745 mp_number x
, y
; /* explicit coordinates or tension at a path join
*/
23746 int t
; /* knot type following a path join
*/
23749 /* Convert the left operand
, |p|
, into a partial path ending at~|q|
;
23750 but |return| if |p| doesn't have a suitable type
*/
23751 if
(mp-
>cur_exp.type
== mp_pair_type
)
23752 path_p
= mp_pair_to_knot
(mp
);
23753 else if
(mp-
>cur_exp.type
== mp_path_type
)
23754 path_p
= cur_exp_knot
();
23758 while
(mp_next_knot
(path_q
) != path_p
)
23759 path_q
= mp_next_knot
(path_q
);
23760 if
(mp_left_type
(path_p
) != mp_endpoint
) { /* open up a cycle
*/
23761 r
= mp_copy_knot
(mp
, path_p
);
23762 mp_next_knot
(path_q
) = r
;
23765 mp_left_type
(path_p
) = mp_open
;
23766 mp_right_type
(path_q
) = mp_open
;
23772 /* Determine the path join parameters
;
23773 but |goto finish_path| if there's only a direction specifier
*/
23774 /* At this point |cur_cmd| is either |ampersand|
, |left_brace|
, or |path_join|.
*/
23776 if
(cur_cmd
() == mp_left_brace
) {
23777 /* Put the pre-join direction information into node |q|
*/
23778 /* At this point |mp_right_type
(q
)| is usually |open|
, but it may have been
23779 set to some other value by a previous operation. We must maintain
23780 the value of |mp_right_type
(q
)| in cases such as
23781 `\.
{..\
{curl2\
}z\
{0,0\
}..
}'.
*/
23782 t
= mp_scan_direction
(mp
);
23783 if
(t
!= mp_open
) {
23784 mp_right_type
(path_q
) = (unsigned short
) t
;
23785 number_clone
(path_q-
>right_given
, cur_exp_value_number
());
23786 if
(mp_left_type
(path_q
) == mp_open
) {
23787 mp_left_type
(path_q
) = (unsigned short
) t
;
23788 number_clone
(path_q-
>left_given
, cur_exp_value_number
());
23789 } /* note that |left_given
(q
)=left_curl
(q
)|
*/
23793 if
(d
== mp_path_join
) {
23794 /* Determine the tension and
/or control points
*/
23795 mp_get_x_next
(mp
);
23796 if
(cur_cmd
() == mp_tension
) {
23797 /* Set explicit tensions
*/
23798 mp_get_x_next
(mp
);
23799 set_number_from_scaled
(y
, cur_cmd
());
23800 if
(cur_cmd
() == mp_at_least
)
23801 mp_get_x_next
(mp
);
23802 mp_scan_primary
(mp
);
23803 force_valid_tension_setting
(mp
);
23804 if
(number_to_scaled
(y
) == mp_at_least
) {
23805 if
(is_number
(cur_exp_value_number
()))
23806 number_negate
(cur_exp_value_number
());
23808 number_clone
(path_q-
>right_tension
, cur_exp_value_number
());
23809 if
(cur_cmd
() == mp_and_command
) {
23810 mp_get_x_next
(mp
);
23811 set_number_from_scaled
(y
, cur_cmd
());
23812 if
(cur_cmd
() == mp_at_least
)
23813 mp_get_x_next
(mp
);
23814 mp_scan_primary
(mp
);
23815 force_valid_tension_setting
(mp
);
23816 if
(number_to_scaled
(y
) == mp_at_least
) {
23817 if
(is_number
(cur_exp_value_number
()))
23818 number_negate
(cur_exp_value_number
());
23821 number_clone
(y
, cur_exp_value_number
());
23823 } else if
(cur_cmd
() == mp_controls
) {
23824 /* Set explicit control points
*/
23825 mp_right_type
(path_q
) = mp_explicit
;
23827 mp_get_x_next
(mp
);
23828 mp_scan_primary
(mp
);
23829 mp_known_pair
(mp
);
23830 number_clone
(path_q-
>right_x
, mp-
>cur_x
);
23831 number_clone
(path_q-
>right_y
, mp-
>cur_y
);
23832 if
(cur_cmd
() != mp_and_command
) {
23833 number_clone
(x
, path_q-
>right_x
);
23834 number_clone
(y
, path_q-
>right_y
);
23836 mp_get_x_next
(mp
);
23837 mp_scan_primary
(mp
);
23838 mp_known_pair
(mp
);
23839 number_clone
(x
, mp-
>cur_x
);
23840 number_clone
(y
, mp-
>cur_y
);
23844 set_number_to_unity
(path_q-
>right_tension
);
23845 set_number_to_unity
(y
);
23846 mp_back_input
(mp
); /* default tension
*/
23849 if
(cur_cmd
() != mp_path_join
) {
23850 const char
*hlp
[] = { "A path join command should end with two dots.", NULL};
23851 mp_back_error
(mp
, "Missing `..' has been inserted", hlp
, true
);
23855 } else if
(d
!= mp_ampersand
) {
23858 mp_get_x_next
(mp
);
23859 if
(cur_cmd
() == mp_left_brace
) {
23860 /* Put the post-join direction information into |x| and |t|
*/
23861 /* Since |left_tension| and |mp_left_y| share the same position in knot nodes
,
23862 and since |left_given| is similarly equivalent to |left_x|
, we use
23863 |x| and |y| to hold the given direction and tension information when
23864 there are no explicit control points.
*/
23865 t
= mp_scan_direction
(mp
);
23866 if
(mp_right_type
(path_q
) != mp_explicit
)
23867 number_clone
(x
, cur_exp_value_number
());
23869 t
= mp_explicit
; /* the direction information is superfluous
*/
23871 } else if
(mp_right_type
(path_q
) != mp_explicit
) {
23873 set_number_to_zero
(x
);
23876 if
(cur_cmd
() == mp_cycle
) {
23877 /* Get ready to close a cycle
*/
23878 /* If a person tries to define an entire path by saying `\.
{(x
,y
)\
&cycle}',
23879 we silently change the specification to `\.
{(x
,y
)..cycle
}'
, since a cycle
23880 shouldn't have length zero.
*/
23882 mp_get_x_next
(mp
);
23885 if
(d
== mp_ampersand
) {
23886 if
(path_p
== path_q
) {
23888 set_number_to_unity
(path_q-
>right_tension
);
23889 set_number_to_unity
(y
);
23893 mp_scan_tertiary
(mp
);
23894 /* Convert the right operand
, |cur_exp|
,
23895 into a partial path from |pp| to~|qq|
*/
23896 if
(mp-
>cur_exp.type
!= mp_path_type
)
23897 pp
= mp_pair_to_knot
(mp
);
23899 pp
= cur_exp_knot
();
23901 while
(mp_next_knot
(qq
) != pp
)
23902 qq
= mp_next_knot
(qq
);
23903 if
(mp_left_type
(pp
) != mp_endpoint
) { /* open up a cycle
*/
23904 r
= mp_copy_knot
(mp
, pp
);
23905 mp_next_knot
(qq
) = r
;
23908 mp_left_type
(pp
) = mp_open
;
23909 mp_right_type
(qq
) = mp_open
;
23911 /* Join the partial paths and reset |p| and |q| to the head and tail
23913 if
(d
== mp_ampersand
) {
23914 if
(!(number_equal
(path_q-
>x_coord
, pp-
>x_coord
)) ||
23915 !(number_equal
(path_q-
>y_coord
, pp-
>y_coord
))) {
23916 const char
*hlp
[] = {
23917 "When you join paths `p&q', the ending point of p",
23918 "must be exactly equal to the starting point of q.",
23919 "So I'm going to pretend that you said `p..q' instead.",
23921 mp_back_error
(mp
, "Paths don't touch; `&' will be changed to `..'", hlp
, true
);
23922 @.Paths don't touch@
>;
23923 mp_get_x_next
(mp
);
23925 set_number_to_unity
(path_q-
>right_tension
);
23926 set_number_to_unity
(y
);
23929 /* Plug an opening in |mp_right_type
(pp
)|
, if possible
*/
23930 if
(mp_right_type
(pp
) == mp_open
) {
23931 if
((t
== mp_curl
) ||
(t
== mp_given
)) {
23932 mp_right_type
(pp
) = (unsigned short
) t
;
23933 number_clone
(pp-
>right_given
, x
);
23936 if
(d
== mp_ampersand
) {
23937 /* Splice independent paths together
*/
23938 if
(mp_left_type
(path_q
) == mp_open
)
23939 if
(mp_right_type
(path_q
) == mp_open
) {
23940 mp_left_type
(path_q
) = mp_curl
;
23941 set_number_to_unity
(path_q-
>left_curl
);
23943 if
(mp_right_type
(pp
) == mp_open
)
23944 if
(t
== mp_open
) {
23945 mp_right_type
(pp
) = mp_curl
;
23946 set_number_to_unity
(pp-
>right_curl
);
23948 mp_right_type
(path_q
) = mp_right_type
(pp
);
23949 mp_next_knot
(path_q
) = mp_next_knot
(pp
);
23950 number_clone
(path_q-
>right_x
, pp-
>right_x
);
23951 number_clone
(path_q-
>right_y
, pp-
>right_y
);
23957 /* Plug an opening in |mp_right_type
(q
)|
, if possible
*/
23958 if
(mp_right_type
(path_q
) == mp_open
) {
23959 if
((mp_left_type
(path_q
) == mp_curl
) ||
(mp_left_type
(path_q
) == mp_given
)) {
23960 mp_right_type
(path_q
) = mp_left_type
(path_q
);
23961 number_clone
(path_q-
>right_given
, path_q-
>left_given
);
23965 mp_next_knot
(path_q
) = pp
;
23966 number_clone
(pp-
>left_y
, y
);
23967 if
(t
!= mp_open
) {
23968 number_clone
(pp-
>left_x
, x
);
23969 mp_left_type
(pp
) = (unsigned short
) t
;
23974 if
(cur_cmd
() >= mp_min_expression_command
)
23975 if
(cur_cmd
() <= mp_ampersand
)
23977 goto CONTINUE_PATH
;
23979 /* Choose control points for the path and put the result into |cur_exp|
*/
23981 if
(d
== mp_ampersand
)
23984 mp_left_type
(path_p
) = mp_endpoint
;
23985 if
(mp_right_type
(path_p
) == mp_open
) {
23986 mp_right_type
(path_p
) = mp_curl
;
23987 set_number_to_unity
(path_p-
>right_curl
);
23989 mp_right_type
(path_q
) = mp_endpoint
;
23990 if
(mp_left_type
(path_q
) == mp_open
) {
23991 mp_left_type
(path_q
) = mp_curl
;
23992 set_number_to_unity
(path_q-
>left_curl
);
23994 mp_next_knot
(path_q
) = path_p
;
23996 mp_make_choices
(mp
, path_p
);
23997 mp-
>cur_exp.type
= mp_path_type
;
23998 set_cur_exp_knot
(path_p
);
24006 @ A pair of numeric values is changed into a knot node for a one-point path
24007 when \MP\ discovers that the pair is part of a path.
24010 static mp_knot mp_pair_to_knot
(MP mp
) { /* convert a pair to a knot with two endpoints
*/
24011 mp_knot q
; /* the new node
*/
24012 q
= mp_new_knot
(mp
);
24013 mp_left_type
(q
) = mp_endpoint
;
24014 mp_right_type
(q
) = mp_endpoint
;
24015 mp_originator
(q
) = mp_metapost_user
;
24016 mp_next_knot
(q
) = q
;
24017 mp_known_pair
(mp
);
24018 number_clone
(q-
>x_coord
, mp-
>cur_x
);
24019 number_clone
(q-
>y_coord
, mp-
>cur_y
);
24024 @ The |known_pair| subroutine sets |cur_x| and |cur_y| to the components
24025 of the current expression
, assuming that the current expression is a
24026 pair of known numerics. Unknown components are zeroed
, and the
24027 current expression is flushed.
24030 static void mp_known_pair
(MP mp
);
24033 void mp_known_pair
(MP mp
) {
24035 mp_node p
; /* the pair node
*/
24036 memset
(&new_expr,0,sizeof(mp_value));
24037 new_number
(new_expr.data.n
);
24038 if
(mp-
>cur_exp.type
!= mp_pair_type
) {
24039 const char
*hlp
[] = {
24040 "I need x and y numbers for this part of the path.",
24041 "The value I found (see above) was no good;",
24042 "so I'll try to keep going by using zero instead.",
24043 "(Chapter 27 of The METAFONTbook explains that",
24044 "you might want to type `I ??" "?' now.)",
24046 mp_disp_err
(mp
, NULL);
24047 mp_back_error
(mp
, "Undefined coordinates have been replaced by (0,0)", hlp
, true
);
24048 mp_get_x_next
(mp
);
24049 mp_flush_cur_exp
(mp
, new_expr
);
24050 set_number_to_zero
(mp-
>cur_x
);
24051 set_number_to_zero
(mp-
>cur_y
);
24053 p
= value_node
(cur_exp_node
());
24054 /* Make sure that both |x| and |y| parts of |p| are known
;
24055 copy them into |cur_x| and |cur_y|
*/
24056 if
(mp_type
(x_part
(p
)) == mp_known
) {
24057 number_clone
(mp-
>cur_x
, value_number
(x_part
(p
)));
24059 const char
*hlp
[] = {
24060 "I need a `known' x value for this part of the path.",
24061 "The value I found (see above) was no good;",
24062 "so I'll try to keep going by using zero instead.",
24063 "(Chapter 27 of The METAFONTbook explains that",
24064 "you might want to type `I ??" "?' now.)",
24066 mp_disp_err
(mp
, x_part
(p
));
24067 mp_back_error
(mp
, "Undefined x coordinate has been replaced by 0", hlp
, true
);
24068 mp_get_x_next
(mp
);
24069 mp_recycle_value
(mp
, x_part
(p
));
24070 set_number_to_zero
(mp-
>cur_x
);
24072 if
(mp_type
(y_part
(p
)) == mp_known
) {
24073 number_clone
(mp-
>cur_y
, value_number
(y_part
(p
)));
24075 const char
*hlp
[] = {
24076 "I need a `known' y value for this part of the path.",
24077 "The value I found (see above) was no good;",
24078 "so I'll try to keep going by using zero instead.",
24079 "(Chapter 27 of The METAFONTbook explains that",
24080 "you might want to type `I ??" "?' now.)",
24082 mp_disp_err
(mp
, y_part
(p
));
24083 mp_back_error
(mp
, "Undefined y coordinate has been replaced by 0", hlp
, true
);
24084 mp_get_x_next
(mp
);
24085 mp_recycle_value
(mp
, y_part
(p
));
24086 set_number_to_zero
(mp-
>cur_y
);
24088 mp_flush_cur_exp
(mp
, new_expr
);
24092 @ The |scan_direction| subroutine looks at the directional information
24093 that is enclosed in braces
, and also scans ahead to the following character.
24094 A type code is returned
, either |open|
(if the direction was $
(0,0)$
),
24095 or |curl|
(if the direction was a curl of known value |cur_exp|
), or
24096 |given|
(if the direction is given by the |angle| value that now
24097 appears in |cur_exp|
).
24099 There's nothing difficult about this subroutine
, but the program is rather
24100 lengthy because a variety of potential errors need to be nipped in the bud.
24103 static quarterword mp_scan_direction
(MP mp
) {
24104 int t
; /* the type of information found
*/
24105 mp_get_x_next
(mp
);
24106 if
(cur_cmd
() == mp_curl_command
) {
24107 /* Scan a curl specification
*/
24108 mp_get_x_next
(mp
);
24109 mp_scan_expression
(mp
);
24110 if
((mp-
>cur_exp.type
!= mp_known
) ||
(number_negative
(cur_exp_value_number
()))) {
24112 const char
*hlp
[] = { "A curl must be a known, nonnegative number.", NULL };
24113 memset
(&new_expr,0,sizeof(mp_value));
24114 new_number
(new_expr.data.n
);
24115 set_number_to_unity
(new_expr.data.n
);
24116 mp_disp_err
(mp
, NULL);
24117 mp_back_error
(mp
, "Improper curl has been replaced by 1", hlp
, true
);
24118 mp_get_x_next
(mp
);
24119 mp_flush_cur_exp
(mp
, new_expr
);
24124 /* Scan a given direction
*/
24125 mp_scan_expression
(mp
);
24126 if
(mp-
>cur_exp.type
> mp_pair_type
) {
24127 /* Get given directions separated by commas
*/
24130 if
(mp-
>cur_exp.type
!= mp_known
) {
24132 const char
*hlp
[] = {
24133 "I need a `known' x value for this part of the path.",
24134 "The value I found (see above) was no good;",
24135 "so I'll try to keep going by using zero instead.",
24136 "(Chapter 27 of The METAFONTbook explains that",
24137 "you might want to type `I ??" "?' now.)",
24139 memset
(&new_expr,0,sizeof(mp_value));
24140 new_number
(new_expr.data.n
);
24141 set_number_to_zero
(new_expr.data.n
);
24142 mp_disp_err
(mp
, NULL);
24143 mp_back_error
(mp
, "Undefined x coordinate has been replaced by 0", hlp
, true
);
24144 mp_get_x_next
(mp
);
24145 mp_flush_cur_exp
(mp
, new_expr
);
24147 number_clone
(xx
, cur_exp_value_number
());
24148 if
(cur_cmd
() != mp_comma
) {
24149 const char
*hlp
[] = {
24150 "I've got the x coordinate of a path direction;",
24151 "will look for the y coordinate next.",
24153 mp_back_error
(mp
, "Missing `,' has been inserted", hlp
, true
);
24155 mp_get_x_next
(mp
);
24156 mp_scan_expression
(mp
);
24157 if
(mp-
>cur_exp.type
!= mp_known
) {
24159 const char
*hlp
[] = {
24160 "I need a `known' y value for this part of the path.",
24161 "The value I found (see above) was no good;",
24162 "so I'll try to keep going by using zero instead.",
24163 "(Chapter 27 of The METAFONTbook explains that",
24164 "you might want to type `I ??" "?' now.)",
24166 memset
(&new_expr,0,sizeof(mp_value));
24167 new_number
(new_expr.data.n
);
24168 set_number_to_zero
(new_expr.data.n
);
24169 mp_disp_err
(mp
, NULL);
24170 mp_back_error
(mp
, "Undefined y coordinate has been replaced by 0", hlp
, true
);
24171 mp_get_x_next
(mp
);
24172 mp_flush_cur_exp
(mp
, new_expr
);
24174 number_clone
(mp-
>cur_y
, cur_exp_value_number
());
24175 number_clone
(mp-
>cur_x
, xx
);
24179 mp_known_pair
(mp
);
24181 if
(number_zero
(mp-
>cur_x
) && number_zero(mp->cur_y))
24186 n_arg
(narg
, mp-
>cur_x
, mp-
>cur_y
);
24188 set_cur_exp_value_number
(narg
);
24189 free_number
(narg
);
24192 if
(cur_cmd
() != mp_right_brace
) {
24193 const char
*hlp
[] = {
24194 "I've scanned a direction spec for part of a path,",
24195 "so a right brace should have come next.",
24196 "I shall pretend that one was there.",
24198 mp_back_error
(mp
, "Missing `}' has been inserted", hlp
, true
);
24200 mp_get_x_next
(mp
);
24201 return
(quarterword
) t
;
24205 @ Finally
, we sometimes need to scan an expression whose value is
24206 supposed to be either |true_code| or |false_code|.
24208 @d mp_get_boolean
(mp
) do
{
24209 mp_get_x_next
(mp
);
24210 mp_scan_expression
(mp
);
24211 if
(mp-
>cur_exp.type
!= mp_boolean_type
) {
24212 do_boolean_error
(mp
);
24216 @
<Declare the basic parsing subroutines@
>=
24217 static void do_boolean_error
(MP mp
) {
24219 const char
*hlp
[] = {
24220 "The expression shown above should have had a definite",
24221 "true-or-false value. I'm changing it to `false'.",
24223 memset
(&new_expr,0,sizeof(mp_value));
24224 new_number
(new_expr.data.n
);
24225 mp_disp_err
(mp
, NULL);
24226 set_number_from_boolean
(new_expr.data.n
, mp_false_code
);
24227 mp_back_error
(mp
, "Undefined condition will be treated as `false'", hlp
, true
);
24228 mp_get_x_next
(mp
);
24229 mp_flush_cur_exp
(mp
, new_expr
);
24230 mp-
>cur_exp.type
= mp_boolean_type
;
24233 @ @
<Declarations@
>=
24234 static void do_boolean_error
(MP mp
);
24236 @
* Doing the operations.
24237 The purpose of parsing is primarily to permit people to avoid piles of
24238 parentheses. But the real work is done after the structure of an expression
24239 has been recognized
; that's when new expressions are generated. We
24240 turn now to the guts of \MP
, which handles individual operators that
24241 have come through the parsing mechanism.
24243 We'll start with the easy ones that take no operands
, then work our way
24244 up to operators with one and ultimately two arguments. In other words
,
24245 we will write the three procedures |do_nullary|
, |do_unary|
, and |do_binary|
24246 that are invoked periodically by the expression scanners.
24248 First let's make sure that all of the primitive operators are in the
24249 hash table. Although |scan_primary| and its relatives made use of the
24250 \\
{cmd
} code for these operators
, the \\
{do
} routines base everything
24251 on the \\
{mod
} code. For example
, |do_binary| doesn't care whether the
24252 operation it performs is a |primary_binary| or |secondary_binary|
, etc.
24255 mp_primitive
(mp
, "true", mp_nullary
, mp_true_code
);
24256 @
:true_
}{\
&{true} primitive@>;
24257 mp_primitive
(mp
, "false", mp_nullary
, mp_false_code
);
24258 @
:false_
}{\
&{false} primitive@>;
24259 mp_primitive
(mp
, "nullpicture", mp_nullary
, mp_null_picture_code
);
24260 @
:null_picture_
}{\
&{nullpicture} primitive@>;
24261 mp_primitive
(mp
, "nullpen", mp_nullary
, mp_null_pen_code
);
24262 @
:null_pen_
}{\
&{nullpen} primitive@>;
24263 mp_primitive
(mp
, "readstring", mp_nullary
, mp_read_string_op
);
24264 @
:read_string_
}{\
&{readstring} primitive@>;
24265 mp_primitive
(mp
, "pencircle", mp_nullary
, mp_pen_circle
);
24266 @
:pen_circle_
}{\
&{pencircle} primitive@>;
24267 mp_primitive
(mp
, "normaldeviate", mp_nullary
, mp_normal_deviate
);
24268 @
:normal_deviate_
}{\
&{normaldeviate} primitive@>;
24269 mp_primitive
(mp
, "readfrom", mp_unary
, mp_read_from_op
);
24270 @
:read_from_
}{\
&{readfrom} primitive@>;
24271 mp_primitive
(mp
, "closefrom", mp_unary
, mp_close_from_op
);
24272 @
:close_from_
}{\
&{closefrom} primitive@>;
24273 mp_primitive
(mp
, "odd", mp_unary
, mp_odd_op
);
24274 @
:odd_
}{\
&{odd} primitive@>;
24275 mp_primitive
(mp
, "known", mp_unary
, mp_known_op
);
24276 @
:known_
}{\
&{known} primitive@>;
24277 mp_primitive
(mp
, "unknown", mp_unary
, mp_unknown_op
);
24278 @
:unknown_
}{\
&{unknown} primitive@>;
24279 mp_primitive
(mp
, "not", mp_unary
, mp_not_op
);
24280 @
:not_
}{\
&{not} primitive@>;
24281 mp_primitive
(mp
, "decimal", mp_unary
, mp_decimal
);
24282 @
:decimal_
}{\
&{decimal} primitive@>;
24283 mp_primitive
(mp
, "reverse", mp_unary
, mp_reverse
);
24284 @
:reverse_
}{\
&{reverse} primitive@>;
24285 mp_primitive
(mp
, "makepath", mp_unary
, mp_make_path_op
);
24286 @
:make_path_
}{\
&{makepath} primitive@>;
24287 mp_primitive
(mp
, "makepen", mp_unary
, mp_make_pen_op
);
24288 @
:make_pen_
}{\
&{makepen} primitive@>;
24289 mp_primitive
(mp
, "oct", mp_unary
, mp_oct_op
);
24290 @
:oct_
}{\
&{oct} primitive@>;
24291 mp_primitive
(mp
, "hex", mp_unary
, mp_hex_op
);
24292 @
:hex_
}{\
&{hex} primitive@>;
24293 mp_primitive
(mp
, "ASCII", mp_unary
, mp_ASCII_op
);
24294 @
:ASCII_
}{\
&{ASCII} primitive@>;
24295 mp_primitive
(mp
, "char", mp_unary
, mp_char_op
);
24296 @
:char_
}{\
&{char} primitive@>;
24297 mp_primitive
(mp
, "length", mp_unary
, mp_length_op
);
24298 @
:length_
}{\
&{length} primitive@>;
24299 mp_primitive
(mp
, "turningnumber", mp_unary
, mp_turning_op
);
24300 @
:turning_number_
}{\
&{turningnumber} primitive@>;
24301 mp_primitive
(mp
, "xpart", mp_unary
, mp_x_part
);
24302 @
:x_part_
}{\
&{xpart} primitive@>;
24303 mp_primitive
(mp
, "ypart", mp_unary
, mp_y_part
);
24304 @
:y_part_
}{\
&{ypart} primitive@>;
24305 mp_primitive
(mp
, "xxpart", mp_unary
, mp_xx_part
);
24306 @
:xx_part_
}{\
&{xxpart} primitive@>;
24307 mp_primitive
(mp
, "xypart", mp_unary
, mp_xy_part
);
24308 @
:xy_part_
}{\
&{xypart} primitive@>;
24309 mp_primitive
(mp
, "yxpart", mp_unary
, mp_yx_part
);
24310 @
:yx_part_
}{\
&{yxpart} primitive@>;
24311 mp_primitive
(mp
, "yypart", mp_unary
, mp_yy_part
);
24312 @
:yy_part_
}{\
&{yypart} primitive@>;
24313 mp_primitive
(mp
, "redpart", mp_unary
, mp_red_part
);
24314 @
:red_part_
}{\
&{redpart} primitive@>;
24315 mp_primitive
(mp
, "greenpart", mp_unary
, mp_green_part
);
24316 @
:green_part_
}{\
&{greenpart} primitive@>;
24317 mp_primitive
(mp
, "bluepart", mp_unary
, mp_blue_part
);
24318 @
:blue_part_
}{\
&{bluepart} primitive@>;
24319 mp_primitive
(mp
, "cyanpart", mp_unary
, mp_cyan_part
);
24320 @
:cyan_part_
}{\
&{cyanpart} primitive@>;
24321 mp_primitive
(mp
, "magentapart", mp_unary
, mp_magenta_part
);
24322 @
:magenta_part_
}{\
&{magentapart} primitive@>;
24323 mp_primitive
(mp
, "yellowpart", mp_unary
, mp_yellow_part
);
24324 @
:yellow_part_
}{\
&{yellowpart} primitive@>;
24325 mp_primitive
(mp
, "blackpart", mp_unary
, mp_black_part
);
24326 @
:black_part_
}{\
&{blackpart} primitive@>;
24327 mp_primitive
(mp
, "greypart", mp_unary
, mp_grey_part
);
24328 @
:grey_part_
}{\
&{greypart} primitive@>;
24329 mp_primitive
(mp
, "colormodel", mp_unary
, mp_color_model_part
);
24330 @
:color_model_part_
}{\
&{colormodel} primitive@>;
24331 mp_primitive
(mp
, "fontpart", mp_unary
, mp_font_part
);
24332 @
:font_part_
}{\
&{fontpart} primitive@>;
24333 mp_primitive
(mp
, "textpart", mp_unary
, mp_text_part
);
24334 @
:text_part_
}{\
&{textpart} primitive@>;
24335 mp_primitive
(mp
, "prescriptpart", mp_unary
, mp_prescript_part
);
24336 @
:prescript_part_
}{\
&{prescriptpart} primitive@>;
24337 mp_primitive
(mp
, "postscriptpart", mp_unary
, mp_postscript_part
);
24338 @
:postscript_part_
}{\
&{postscriptpart} primitive@>;
24339 mp_primitive
(mp
, "pathpart", mp_unary
, mp_path_part
);
24340 @
:path_part_
}{\
&{pathpart} primitive@>;
24341 mp_primitive
(mp
, "penpart", mp_unary
, mp_pen_part
);
24342 @
:pen_part_
}{\
&{penpart} primitive@>;
24343 mp_primitive
(mp
, "dashpart", mp_unary
, mp_dash_part
);
24344 @
:dash_part_
}{\
&{dashpart} primitive@>;
24345 mp_primitive
(mp
, "sqrt", mp_unary
, mp_sqrt_op
);
24346 @
:sqrt_
}{\
&{sqrt} primitive@>;
24347 mp_primitive
(mp
, "mexp", mp_unary
, mp_m_exp_op
);
24348 @
:m_exp_
}{\
&{mexp} primitive@>;
24349 mp_primitive
(mp
, "mlog", mp_unary
, mp_m_log_op
);
24350 @
:m_log_
}{\
&{mlog} primitive@>;
24351 mp_primitive
(mp
, "sind", mp_unary
, mp_sin_d_op
);
24352 @
:sin_d_
}{\
&{sind} primitive@>;
24353 mp_primitive
(mp
, "cosd", mp_unary
, mp_cos_d_op
);
24354 @
:cos_d_
}{\
&{cosd} primitive@>;
24355 mp_primitive
(mp
, "floor", mp_unary
, mp_floor_op
);
24356 @
:floor_
}{\
&{floor} primitive@>;
24357 mp_primitive
(mp
, "uniformdeviate", mp_unary
, mp_uniform_deviate
);
24358 @
:uniform_deviate_
}{\
&{uniformdeviate} primitive@>;
24359 mp_primitive
(mp
, "charexists", mp_unary
, mp_char_exists_op
);
24360 @
:char_exists_
}{\
&{charexists} primitive@>;
24361 mp_primitive
(mp
, "fontsize", mp_unary
, mp_font_size
);
24362 @
:font_size_
}{\
&{fontsize} primitive@>;
24363 mp_primitive
(mp
, "llcorner", mp_unary
, mp_ll_corner_op
);
24364 @
:ll_corner_
}{\
&{llcorner} primitive@>;
24365 mp_primitive
(mp
, "lrcorner", mp_unary
, mp_lr_corner_op
);
24366 @
:lr_corner_
}{\
&{lrcorner} primitive@>;
24367 mp_primitive
(mp
, "ulcorner", mp_unary
, mp_ul_corner_op
);
24368 @
:ul_corner_
}{\
&{ulcorner} primitive@>;
24369 mp_primitive
(mp
, "urcorner", mp_unary
, mp_ur_corner_op
);
24370 @
:ur_corner_
}{\
&{urcorner} primitive@>;
24371 mp_primitive
(mp
, "arclength", mp_unary
, mp_arc_length
);
24372 @
:arc_length_
}{\
&{arclength} primitive@>;
24373 mp_primitive
(mp
, "angle", mp_unary
, mp_angle_op
);
24374 @
:angle_
}{\
&{angle} primitive@>;
24375 mp_primitive
(mp
, "cycle", mp_cycle
, mp_cycle_op
);
24376 @
:cycle_
}{\
&{cycle} primitive@>;
24377 mp_primitive
(mp
, "stroked", mp_unary
, mp_stroked_op
);
24378 @
:stroked_
}{\
&{stroked} primitive@>;
24379 mp_primitive
(mp
, "filled", mp_unary
, mp_filled_op
);
24380 @
:filled_
}{\
&{filled} primitive@>;
24381 mp_primitive
(mp
, "textual", mp_unary
, mp_textual_op
);
24382 @
:textual_
}{\
&{textual} primitive@>;
24383 mp_primitive
(mp
, "clipped", mp_unary
, mp_clipped_op
);
24384 @
:clipped_
}{\
&{clipped} primitive@>;
24385 mp_primitive
(mp
, "bounded", mp_unary
, mp_bounded_op
);
24386 @
:bounded_
}{\
&{bounded} primitive@>;
24387 mp_primitive
(mp
, "+", mp_plus_or_minus
, mp_plus
);
24388 @
:+ }{\.
{+} primitive@
>;
24389 mp_primitive
(mp
, "-", mp_plus_or_minus
, mp_minus
);
24390 @
:- }{\.
{-} primitive@
>;
24391 mp_primitive
(mp
, "*", mp_secondary_binary
, mp_times
);
24392 @
:* }{\.
{*} primitive@
>;
24393 mp_primitive
(mp
, "/", mp_slash
, mp_over
);
24394 mp-
>frozen_slash
= mp_frozen_primitive
(mp
, "/", mp_slash
, mp_over
);
24395 @
:/ }{\.
{/} primitive@
>;
24396 mp_primitive
(mp
, "++", mp_tertiary_binary
, mp_pythag_add
);
24397 @
:++_
}{\.
{++} primitive@
>;
24398 mp_primitive
(mp
, "+-+", mp_tertiary_binary
, mp_pythag_sub
);
24399 @
:+-+_
}{\.
{+-+} primitive@
>;
24400 mp_primitive
(mp
, "or", mp_tertiary_binary
, mp_or_op
);
24401 @
:or_
}{\
&{or} primitive@>;
24402 mp_primitive
(mp
, "and", mp_and_command
, mp_and_op
);
24403 @
:and_
}{\
&{and} primitive@>;
24404 mp_primitive
(mp
, "<", mp_expression_binary
, mp_less_than
);
24405 @
:< }{\.
{<} primitive@
>;
24406 mp_primitive
(mp
, "<=", mp_expression_binary
, mp_less_or_equal
);
24407 @
:<=_
}{\.
{<=} primitive@
>;
24408 mp_primitive
(mp
, ">", mp_expression_binary
, mp_greater_than
);
24409 @
:> }{\.
{>} primitive@
>;
24410 mp_primitive
(mp
, ">=", mp_expression_binary
, mp_greater_or_equal
);
24411 @
:>=_
}{\.
{>=} primitive@
>;
24412 mp_primitive
(mp
, "=", mp_equals
, mp_equal_to
);
24413 @
:= }{\.
{=} primitive@
>;
24414 mp_primitive
(mp
, "<>", mp_expression_binary
, mp_unequal_to
);
24415 @
:<>_
}{\.
{<>} primitive@
>;
24416 mp_primitive
(mp
, "substring", mp_primary_binary
, mp_substring_of
);
24417 @
:substring_
}{\
&{substring} primitive@>;
24418 mp_primitive
(mp
, "subpath", mp_primary_binary
, mp_subpath_of
);
24419 @
:subpath_
}{\
&{subpath} primitive@>;
24420 mp_primitive
(mp
, "directiontime", mp_primary_binary
, mp_direction_time_of
);
24421 @
:direction_time_
}{\
&{directiontime} primitive@>;
24422 mp_primitive
(mp
, "point", mp_primary_binary
, mp_point_of
);
24423 @
:point_
}{\
&{point} primitive@>;
24424 mp_primitive
(mp
, "precontrol", mp_primary_binary
, mp_precontrol_of
);
24425 @
:precontrol_
}{\
&{precontrol} primitive@>;
24426 mp_primitive
(mp
, "postcontrol", mp_primary_binary
, mp_postcontrol_of
);
24427 @
:postcontrol_
}{\
&{postcontrol} primitive@>;
24428 mp_primitive
(mp
, "penoffset", mp_primary_binary
, mp_pen_offset_of
);
24429 @
:pen_offset_
}{\
&{penoffset} primitive@>;
24430 mp_primitive
(mp
, "arctime", mp_primary_binary
, mp_arc_time_of
);
24431 @
:arc_time_of_
}{\
&{arctime} primitive@>;
24432 mp_primitive
(mp
, "mpversion", mp_nullary
, mp_version
);
24433 @
:mp_verison_
}{\
&{mpversion} primitive@>;
24434 mp_primitive
(mp
, "&", mp_ampersand
, mp_concatenate
);
24435 @
:!!!}{\.
{\
&} primitive@>;
24436 mp_primitive
(mp
, "rotated", mp_secondary_binary
, mp_rotated_by
);
24437 @
:rotated_
}{\
&{rotated} primitive@>;
24438 mp_primitive
(mp
, "slanted", mp_secondary_binary
, mp_slanted_by
);
24439 @
:slanted_
}{\
&{slanted} primitive@>;
24440 mp_primitive
(mp
, "scaled", mp_secondary_binary
, mp_scaled_by
);
24441 @
:scaled_
}{\
&{scaled} primitive@>;
24442 mp_primitive
(mp
, "shifted", mp_secondary_binary
, mp_shifted_by
);
24443 @
:shifted_
}{\
&{shifted} primitive@>;
24444 mp_primitive
(mp
, "transformed", mp_secondary_binary
, mp_transformed_by
);
24445 @
:transformed_
}{\
&{transformed} primitive@>;
24446 mp_primitive
(mp
, "xscaled", mp_secondary_binary
, mp_x_scaled
);
24447 @
:x_scaled_
}{\
&{xscaled} primitive@>;
24448 mp_primitive
(mp
, "yscaled", mp_secondary_binary
, mp_y_scaled
);
24449 @
:y_scaled_
}{\
&{yscaled} primitive@>;
24450 mp_primitive
(mp
, "zscaled", mp_secondary_binary
, mp_z_scaled
);
24451 @
:z_scaled_
}{\
&{zscaled} primitive@>;
24452 mp_primitive
(mp
, "infont", mp_secondary_binary
, mp_in_font
);
24453 @
:in_font_
}{\
&{infont} primitive@>;
24454 mp_primitive
(mp
, "intersectiontimes", mp_tertiary_binary
, mp_intersect
);
24455 @
:intersection_times_
}{\
&{intersectiontimes} primitive@>;
24456 mp_primitive
(mp
, "envelope", mp_primary_binary
, mp_envelope_of
);
24457 @
:envelope_
}{\
&{envelope} primitive@>;
24458 mp_primitive
(mp
, "glyph", mp_primary_binary
, mp_glyph_infont
);
24459 @
:glyph_infont_
}{\
&{envelope} primitive@>
24462 @ @
<Cases of |print_cmd...@
>=
24465 case mp_primary_binary
:
24466 case mp_secondary_binary
:
24467 case mp_tertiary_binary
:
24468 case mp_expression_binary
:
24470 case mp_plus_or_minus
:
24474 case mp_and_command
:
24475 mp_print_op
(mp
, (quarterword
) m
);
24478 @
OK, let's look at the simplest \\
{do
} procedure first.
24481 @
<Declare nullary action procedure@
>;
24482 static void mp_do_nullary
(MP mp
, quarterword c
) {
24484 if
(number_greater
(internal_value
(mp_tracing_commands
), two_t
))
24485 mp_show_cmd_mod
(mp
, mp_nullary
, c
);
24488 case mp_false_code
:
24489 mp-
>cur_exp.type
= mp_boolean_type
;
24490 set_cur_exp_value_boolean
(c
);
24492 case mp_null_picture_code
:
24493 mp-
>cur_exp.type
= mp_picture_type
;
24494 set_cur_exp_node
((mp_node
)mp_get_edge_header_node
(mp
));
24495 mp_init_edges
(mp
, (mp_edge_header_node
)cur_exp_node
());
24497 case mp_null_pen_code
:
24498 mp-
>cur_exp.type
= mp_pen_type
;
24499 set_cur_exp_knot
(mp_get_pen_circle
(mp
, zero_t
));
24501 case mp_normal_deviate
:
24505 mp_norm_rand
(mp
, &r);
24506 mp-
>cur_exp.type
= mp_known
;
24507 set_cur_exp_value_number
(r
);
24511 case mp_pen_circle
:
24512 mp-
>cur_exp.type
= mp_pen_type
;
24513 set_cur_exp_knot
(mp_get_pen_circle
(mp
, unity_t
));
24516 mp-
>cur_exp.type
= mp_string_type
;
24517 set_cur_exp_str
(mp_intern
(mp
, metapost_version
));
24519 case mp_read_string_op
:
24520 /* Read a string from the terminal
*/
24521 if
(mp-
>noninteractive || mp-
>interaction
<= mp_nonstop_mode
)
24522 mp_fatal_error
(mp
, "*** (cannot readstring in nonstop modes)");
24523 mp_begin_file_reading
(mp
);
24527 mp_finish_read
(mp
);
24529 } /* there are no other cases
*/
24534 @ @
<Declare nullary action procedure@
>=
24535 static void mp_finish_read
(MP mp
) { /* copy |buffer| line to |cur_exp|
*/
24537 str_room
(((int
) mp-
>last
- (int
) start
));
24538 for
(k
= (size_t
) start
; k
< mp-
>last
; k
++) {
24539 append_char
(mp-
>buffer
[k
]);
24541 mp_end_file_reading
(mp
);
24542 mp-
>cur_exp.type
= mp_string_type
;
24543 set_cur_exp_str
(mp_make_string
(mp
));
24547 @ Things get a bit more interesting when there's an operand. The
24548 operand to |do_unary| appears in |cur_type| and |cur_exp|.
24550 This complicated if test makes sure that any |bounds| or |clip|
24551 picture objects that get passed into \
&{within} do not raise an
24552 error when queried using the color part primitives
(this is needed
24553 for backward compatibility
) .
24555 @d cur_pic_item mp_link
(edge_list
(cur_exp_node
()))
24556 @d pict_color_type
(A
) ((cur_pic_item
!=NULL) &&
24557 ((!has_color
(cur_pic_item
))
24559 (((mp_color_model
(cur_pic_item
)==A
)
24561 ((mp_color_model
(cur_pic_item
)==mp_uninitialized_model
) &&
24562 (number_to_scaled
(internal_value
(mp_default_color_model
))/number_to_scaled
(unity_t
))==(A
))))))
24564 @d boolean_reset
(A
) if
( (A
) ) set_cur_exp_value_boolean
(mp_true_code
); else set_cur_exp_value_boolean
(mp_false_code
)
24566 @d type_range
(A
,B
) {
24567 if
( (mp-
>cur_exp.type
>=(A
)) && (mp->cur_exp.type<=(B)) )
24568 set_number_from_boolean
(new_expr.data.n
, mp_true_code
);
24570 set_number_from_boolean
(new_expr.data.n
, mp_false_code
);
24571 mp_flush_cur_exp
(mp
, new_expr
);
24572 mp-
>cur_exp.type
=mp_boolean_type
;
24575 if
( mp-
>cur_exp.type
==(mp_variable_type
)(A
) )
24576 set_number_from_boolean
(new_expr.data.n
, mp_true_code
);
24578 set_number_from_boolean
(new_expr.data.n
, mp_false_code
);
24579 mp_flush_cur_exp
(mp
, new_expr
);
24580 mp-
>cur_exp.type
=mp_boolean_type
;
24585 @
<Declare unary action procedures@
>;
24586 static void mp_do_unary
(MP mp
, quarterword c
) {
24587 mp_node p
; /* for list manipulation
*/
24590 if
(number_greater
(internal_value
(mp_tracing_commands
), two_t
)) {
24591 /* Trace the current unary operation
*/
24592 mp_begin_diagnostic
(mp
);
24593 mp_print_nl
(mp
, "{");
24594 mp_print_op
(mp
, c
);
24595 mp_print_char
(mp
, xord
('
('
));
24596 mp_print_exp
(mp
, NULL, 0); /* show the operand
, but not verbosely
*/
24597 mp_print
(mp
, ")}");
24598 mp_end_diagnostic
(mp
, false
);
24602 if
(mp-
>cur_exp.type
< mp_color_type
)
24603 mp_bad_unary
(mp
, mp_plus
);
24606 negate_cur_expr
(mp
);
24609 if
(mp-
>cur_exp.type
!= mp_boolean_type
) {
24610 mp_bad_unary
(mp
, mp_not_op
);
24613 if
(cur_exp_value_boolean
() == mp_true_code
)
24614 bb
= mp_false_code
;
24617 set_cur_exp_value_boolean
(bb
);
24626 case mp_uniform_deviate
:
24628 case mp_char_exists_op
:
24629 if
(mp-
>cur_exp.type
!= mp_known
) {
24630 mp_bad_unary
(mp
, c
);
24637 square_rt
(r1
, cur_exp_value_number
());
24638 set_cur_exp_value_number
(r1
);
24646 m_exp
(r1
, cur_exp_value_number
());
24647 set_cur_exp_value_number
(r1
);
24655 m_log
(r1
, cur_exp_value_number
());
24656 set_cur_exp_value_number
(r1
);
24663 mp_number n_sin
, n_cos
, arg1
, arg2
;
24666 new_fraction
(n_sin
);
24667 new_fraction
(n_cos
); /* results computed by |n_sin_cos|
*/
24668 number_clone
(arg1
, cur_exp_value_number
());
24669 number_clone
(arg2
, unity_t
);
24670 number_multiply_int
(arg2
, 360);
24671 number_modulo
(arg1
, arg2
);
24672 convert_scaled_to_angle
(arg1
);
24673 n_sin_cos
(arg1
, n_cos
, n_sin
);
24674 if
(c
== mp_sin_d_op
) {
24675 fraction_to_round_scaled
(n_sin
);
24676 set_cur_exp_value_number
(n_sin
);
24678 fraction_to_round_scaled
(n_cos
);
24679 set_cur_exp_value_number
(n_cos
);
24681 free_number
(arg1
);
24682 free_number
(arg2
);
24683 free_number
(n_sin
);
24684 free_number
(n_cos
);
24691 number_clone
(vvx
, cur_exp_value_number
());
24692 floor_scaled
(vvx
);
24693 set_cur_exp_value_number
(vvx
);
24697 case mp_uniform_deviate
:
24701 mp_unif_rand
(mp
, &vvx, cur_exp_value_number ());
24702 set_cur_exp_value_number
(vvx
);
24708 integer vvx
= odd
(round_unscaled
(cur_exp_value_number
()));
24709 boolean_reset
(vvx
);
24710 mp-
>cur_exp.type
= mp_boolean_type
;
24713 case mp_char_exists_op
:
24714 /* Determine if a character has been shipped out
*/
24715 set_cur_exp_value_scaled
(round_unscaled
(cur_exp_value_number
()) % 256);
24716 if
(number_negative
(cur_exp_value_number
())) {
24717 halfword vv
= number_to_scaled
(cur_exp_value_number
());
24718 set_cur_exp_value_scaled
(vv
+ 256);
24720 boolean_reset
(mp-
>char_exists
[number_to_scaled
(cur_exp_value_number
())]);
24721 mp-
>cur_exp.type
= mp_boolean_type
;
24723 } /* there are no other cases
*/
24727 if
(mp_nice_pair
(mp
, cur_exp_node
(), mp-
>cur_exp.type
)) {
24729 memset
(&new_expr,0,sizeof(mp_value));
24730 new_number
(new_expr.data.n
);
24732 p
= value_node
(cur_exp_node
());
24733 n_arg
(narg
, value_number
(x_part
(p
)), value_number
(y_part
(p
)));
24734 number_clone
(new_expr.data.n
, narg
);
24735 convert_angle_to_scaled
(new_expr.data.n
);
24736 free_number
(narg
);
24737 mp_flush_cur_exp
(mp
, new_expr
);
24739 mp_bad_unary
(mp
, mp_angle_op
);
24744 if
((mp-
>cur_exp.type
== mp_pair_type
)
24745 ||
(mp-
>cur_exp.type
== mp_transform_type
))
24746 mp_take_part
(mp
, c
);
24747 else if
(mp-
>cur_exp.type
== mp_picture_type
)
24748 mp_take_pict_part
(mp
, c
);
24750 mp_bad_unary
(mp
, c
);
24756 if
(mp-
>cur_exp.type
== mp_transform_type
)
24757 mp_take_part
(mp
, c
);
24758 else if
(mp-
>cur_exp.type
== mp_picture_type
)
24759 mp_take_pict_part
(mp
, c
);
24761 mp_bad_unary
(mp
, c
);
24764 case mp_green_part
:
24766 if
(mp-
>cur_exp.type
== mp_color_type
)
24767 mp_take_part
(mp
, c
);
24768 else if
(mp-
>cur_exp.type
== mp_picture_type
) {
24770 (mp_rgb_model
) mp_take_pict_part
(mp
, c
);
24772 mp_bad_color_part
(mp
, c
);
24774 mp_bad_unary
(mp
, c
);
24777 case mp_magenta_part
:
24778 case mp_yellow_part
:
24779 case mp_black_part
:
24780 if
(mp-
>cur_exp.type
== mp_cmykcolor_type
)
24781 mp_take_part
(mp
, c
);
24782 else if
(mp-
>cur_exp.type
== mp_picture_type
) {
24784 (mp_cmyk_model
) mp_take_pict_part
(mp
, c
);
24786 mp_bad_color_part
(mp
, c
);
24788 mp_bad_unary
(mp
, c
);
24791 if
(mp-
>cur_exp.type
== mp_known
);
24792 else if
(mp-
>cur_exp.type
== mp_picture_type
) {
24794 (mp_grey_model
) mp_take_pict_part
(mp
, c
);
24796 mp_bad_color_part
(mp
, c
);
24798 mp_bad_unary
(mp
, c
);
24800 case mp_color_model_part
:
24801 if
(mp-
>cur_exp.type
== mp_picture_type
)
24802 mp_take_pict_part
(mp
, c
);
24804 mp_bad_unary
(mp
, c
);
24811 case mp_prescript_part
:
24812 case mp_postscript_part
:
24813 if
(mp-
>cur_exp.type
== mp_picture_type
)
24814 mp_take_pict_part
(mp
, c
);
24816 mp_bad_unary
(mp
, c
);
24819 if
(mp-
>cur_exp.type
!= mp_known
) {
24820 mp_bad_unary
(mp
, mp_char_op
);
24822 int vv
= round_unscaled
(cur_exp_value_number
()) % 256;
24823 set_cur_exp_value_scaled
(vv
);
24824 mp-
>cur_exp.type
= mp_string_type
;
24825 if
(number_negative
(cur_exp_value_number
())) {
24826 vv
= number_to_scaled
(cur_exp_value_number
()) + 256;
24827 set_cur_exp_value_scaled
(vv
);
24830 unsigned char ss
[2];
24831 ss
[0] = (unsigned char
) number_to_scaled
(cur_exp_value_number
());
24833 set_cur_exp_str
(mp_rtsl
(mp
, (char
*) ss
, 1));
24838 if
(mp-
>cur_exp.type
!= mp_known
) {
24839 mp_bad_unary
(mp
, mp_decimal
);
24841 mp-
>old_setting
= mp-
>selector
;
24842 mp-
>selector
= new_string
;
24843 print_number
(cur_exp_value_number
());
24844 set_cur_exp_str
(mp_make_string
(mp
));
24845 mp-
>selector
= mp-
>old_setting
;
24846 mp-
>cur_exp.type
= mp_string_type
;
24852 if
(mp-
>cur_exp.type
!= mp_string_type
)
24853 mp_bad_unary
(mp
, c
);
24855 mp_str_to_num
(mp
, c
);
24858 if
(mp-
>cur_exp.type
!= mp_string_type
) {
24859 mp_bad_unary
(mp
, mp_font_size
);
24861 /* Find the design size of the font whose name is |cur_exp|
*/
24862 /* One simple application of |find_font| is the implementation of the |font_size|
24863 operator that gets the design size for a given font name.
*/
24864 memset
(&new_expr,0,sizeof(mp_value));
24865 new_number
(new_expr.data.n
);
24866 set_number_from_scaled
(new_expr.data.n
,
24867 (mp-
>font_dsize
[mp_find_font
(mp
, mp_str
(mp
, cur_exp_str
()))] + 8) / 16);
24868 mp_flush_cur_exp
(mp
, new_expr
);
24872 /* The length operation is somewhat unusual in that it applies to a variety
24873 of different types of operands.
*/
24874 switch
(mp-
>cur_exp.type
) {
24875 case mp_string_type
:
24876 memset
(&new_expr,0,sizeof(mp_value));
24877 new_number
(new_expr.data.n
);
24878 number_clone
(new_expr.data.n
, unity_t
);
24879 number_multiply_int
(new_expr.data.n
, cur_exp_str
()->len
);
24880 mp_flush_cur_exp
(mp
, new_expr
);
24883 memset
(&new_expr,0,sizeof(mp_value));
24884 new_number
(new_expr.data.n
);
24885 mp_path_length
(mp
, &new_expr.data.n);
24886 mp_flush_cur_exp
(mp
, new_expr
);
24889 set_cur_exp_value_number
(cur_exp_value_number
());
24890 number_abs
(cur_exp_value_number
());
24892 case mp_picture_type
:
24893 memset
(&new_expr,0,sizeof(mp_value));
24894 new_number
(new_expr.data.n
);
24895 mp_pict_length
(mp
, &new_expr.data.n);
24896 mp_flush_cur_exp
(mp
, new_expr
);
24899 if
(mp_nice_pair
(mp
, cur_exp_node
(), mp-
>cur_exp.type
)) {
24900 memset
(&new_expr,0,sizeof(mp_value));
24901 new_number
(new_expr.data.n
);
24902 pyth_add
(new_expr.data.n
, value_number
(x_part
(value_node
(cur_exp_node
()))),
24903 value_number
(y_part
(value_node
(cur_exp_node
()))));
24904 mp_flush_cur_exp
(mp
, new_expr
);
24906 mp_bad_unary
(mp
, c
);
24910 case mp_turning_op
:
24911 if
(mp-
>cur_exp.type
== mp_pair_type
) {
24912 memset
(&new_expr,0,sizeof(mp_value));
24913 new_number
(new_expr.data.n
);
24914 set_number_to_zero
(new_expr.data.n
);
24915 mp_flush_cur_exp
(mp
, new_expr
);
24916 } else if
(mp-
>cur_exp.type
!= mp_path_type
) {
24917 mp_bad_unary
(mp
, mp_turning_op
);
24918 } else if
(mp_left_type
(cur_exp_knot
()) == mp_endpoint
) {
24919 memset
(&new_expr,0,sizeof(mp_value));
24920 new_number
(new_expr.data.n
);
24921 new_expr.data.p
= NULL;
24922 mp_flush_cur_exp
(mp
, new_expr
); /* not a cyclic path
*/
24924 memset
(&new_expr,0,sizeof(mp_value));
24925 new_number
(new_expr.data.n
);
24926 mp_turn_cycles_wrapper
(mp
, &new_expr.data.n, cur_exp_knot ());
24927 mp_flush_cur_exp
(mp
, new_expr
);
24930 case mp_boolean_type
:
24931 memset
(&new_expr,0,sizeof(mp_value));
24932 new_number
(new_expr.data.n
);
24933 type_range
(mp_boolean_type
, mp_unknown_boolean
);
24935 case mp_string_type
:
24936 memset
(&new_expr,0,sizeof(mp_value));
24937 new_number
(new_expr.data.n
);
24938 type_range
(mp_string_type
, mp_unknown_string
);
24941 memset
(&new_expr,0,sizeof(mp_value));
24942 new_number
(new_expr.data.n
);
24943 type_range
(mp_pen_type
, mp_unknown_pen
);
24946 memset
(&new_expr,0,sizeof(mp_value));
24947 new_number
(new_expr.data.n
);
24948 type_range
(mp_path_type
, mp_unknown_path
);
24950 case mp_picture_type
:
24951 memset
(&new_expr,0,sizeof(mp_value));
24952 new_number
(new_expr.data.n
);
24953 type_range
(mp_picture_type
, mp_unknown_picture
);
24955 case mp_transform_type
:
24956 case mp_color_type
:
24957 case mp_cmykcolor_type
:
24959 memset
(&new_expr,0,sizeof(mp_value));
24960 new_number
(new_expr.data.n
);
24963 case mp_numeric_type
:
24964 memset
(&new_expr,0,sizeof(mp_value));
24965 new_number
(new_expr.data.n
);
24966 type_range
(mp_known
, mp_independent
);
24969 case mp_unknown_op
:
24970 mp_test_known
(mp
, c
);
24973 memset
(&new_expr,0,sizeof(mp_value));
24974 new_number
(new_expr.data.n
);
24975 if
(mp-
>cur_exp.type
!= mp_path_type
)
24976 set_number_from_boolean
(new_expr.data.n
, mp_false_code
);
24977 else if
(mp_left_type
(cur_exp_knot
()) != mp_endpoint
)
24978 set_number_from_boolean
(new_expr.data.n
, mp_true_code
);
24980 set_number_from_boolean
(new_expr.data.n
, mp_false_code
);
24981 mp_flush_cur_exp
(mp
, new_expr
);
24982 mp-
>cur_exp.type
= mp_boolean_type
;
24984 case mp_arc_length
:
24985 if
(mp-
>cur_exp.type
== mp_pair_type
)
24986 mp_pair_to_path
(mp
);
24987 if
(mp-
>cur_exp.type
!= mp_path_type
) {
24988 mp_bad_unary
(mp
, mp_arc_length
);
24990 memset
(&new_expr,0,sizeof(mp_value));
24991 new_number
(new_expr.data.n
);
24992 mp_get_arc_length
(mp
, &new_expr.data.n, cur_exp_knot ());
24993 mp_flush_cur_exp
(mp
, new_expr
);
24997 case mp_stroked_op
:
24998 case mp_textual_op
:
24999 case mp_clipped_op
:
25000 case mp_bounded_op
:
25001 /* Here we use the fact that |c-filled_op
+fill_code| is the desired graphical
25003 @^data structure assumptions@
>
25004 memset
(&new_expr,0,sizeof(mp_value));
25005 new_number
(new_expr.data.n
);
25006 if
(mp-
>cur_exp.type
!= mp_picture_type
) {
25007 set_number_from_boolean
(new_expr.data.n
, mp_false_code
);
25008 } else if
(mp_link
(edge_list
(cur_exp_node
())) == NULL) {
25009 set_number_from_boolean
(new_expr.data.n
, mp_false_code
);
25010 } else if
(mp_type
(mp_link
(edge_list
(cur_exp_node
()))) ==
25011 (mp_variable_type
) (c
+ mp_fill_node_type
- mp_filled_op
)) {
25012 set_number_from_boolean
(new_expr.data.n
, mp_true_code
);
25014 set_number_from_boolean
(new_expr.data.n
, mp_false_code
);
25016 mp_flush_cur_exp
(mp
, new_expr
);
25017 mp-
>cur_exp.type
= mp_boolean_type
;
25019 case mp_make_pen_op
:
25020 if
(mp-
>cur_exp.type
== mp_pair_type
)
25021 mp_pair_to_path
(mp
);
25022 if
(mp-
>cur_exp.type
!= mp_path_type
)
25023 mp_bad_unary
(mp
, mp_make_pen_op
);
25025 mp-
>cur_exp.type
= mp_pen_type
;
25026 set_cur_exp_knot
(mp_make_pen
(mp
, cur_exp_knot
(), true
));
25029 case mp_make_path_op
:
25030 if
(mp-
>cur_exp.type
!= mp_pen_type
) {
25031 mp_bad_unary
(mp
, mp_make_path_op
);
25033 mp-
>cur_exp.type
= mp_path_type
;
25034 mp_make_path
(mp
, cur_exp_knot
());
25038 if
(mp-
>cur_exp.type
== mp_path_type
) {
25039 mp_knot pk
= mp_htap_ypoc
(mp
, cur_exp_knot
());
25040 if
(mp_right_type
(pk
) == mp_endpoint
)
25041 pk
= mp_next_knot
(pk
);
25042 mp_toss_knot_list
(mp
, cur_exp_knot
());
25043 set_cur_exp_knot
(pk
);
25044 } else if
(mp-
>cur_exp.type
== mp_pair_type
) {
25045 mp_pair_to_path
(mp
);
25047 mp_bad_unary
(mp
, mp_reverse
);
25050 case mp_ll_corner_op
:
25051 if
(!mp_get_cur_bbox
(mp
))
25052 mp_bad_unary
(mp
, mp_ll_corner_op
);
25054 mp_pair_value
(mp
, mp_minx
, mp_miny
);
25056 case mp_lr_corner_op
:
25057 if
(!mp_get_cur_bbox
(mp
))
25058 mp_bad_unary
(mp
, mp_lr_corner_op
);
25060 mp_pair_value
(mp
, mp_maxx
, mp_miny
);
25062 case mp_ul_corner_op
:
25063 if
(!mp_get_cur_bbox
(mp
))
25064 mp_bad_unary
(mp
, mp_ul_corner_op
);
25066 mp_pair_value
(mp
, mp_minx
, mp_maxy
);
25068 case mp_ur_corner_op
:
25069 if
(!mp_get_cur_bbox
(mp
))
25070 mp_bad_unary
(mp
, mp_ur_corner_op
);
25072 mp_pair_value
(mp
, mp_maxx
, mp_maxy
);
25074 case mp_read_from_op
:
25075 case mp_close_from_op
:
25076 if
(mp-
>cur_exp.type
!= mp_string_type
)
25077 mp_bad_unary
(mp
, c
);
25079 mp_do_read_or_close
(mp
, c
);
25082 } /* there are no other cases
*/
25087 @ The |nice_pair| function returns |true| if both components of a pair
25090 @
<Declare unary action procedures@
>=
25091 static boolean mp_nice_pair
(MP mp
, mp_node p
, quarterword t
) {
25093 if
(t
== mp_pair_type
) {
25094 p
= value_node
(p
);
25095 if
(mp_type
(x_part
(p
)) == mp_known
)
25096 if
(mp_type
(y_part
(p
)) == mp_known
)
25103 @ The |nice_color_or_pair| function is analogous except that it also accepts
25104 fully known colors.
25106 @
<Declare unary action procedures@
>=
25107 static boolean mp_nice_color_or_pair
(MP mp
, mp_node p
, quarterword t
) {
25112 q
= value_node
(p
);
25113 if
(mp_type
(x_part
(q
)) == mp_known
)
25114 if
(mp_type
(y_part
(q
)) == mp_known
)
25117 case mp_color_type
:
25118 q
= value_node
(p
);
25119 if
(mp_type
(red_part
(q
)) == mp_known
)
25120 if
(mp_type
(green_part
(q
)) == mp_known
)
25121 if
(mp_type
(blue_part
(q
)) == mp_known
)
25124 case mp_cmykcolor_type
:
25125 q
= value_node
(p
);
25126 if
(mp_type
(cyan_part
(q
)) == mp_known
)
25127 if
(mp_type
(magenta_part
(q
)) == mp_known
)
25128 if
(mp_type
(yellow_part
(q
)) == mp_known
)
25129 if
(mp_type
(black_part
(q
)) == mp_known
)
25137 @ @
<Declare unary action...@
>=
25138 static void mp_print_known_or_unknown_type
(MP mp
, quarterword t
, mp_node v
) {
25139 mp_print_char
(mp
, xord
('
('
));
25141 mp_print
(mp
, "unknown numeric");
25143 if
((t
== mp_pair_type
) ||
(t
== mp_color_type
) ||
(t
== mp_cmykcolor_type
))
25144 if
(!mp_nice_color_or_pair
(mp
, v
, t
))
25145 mp_print
(mp
, "unknown ");
25146 mp_print_type
(mp
, t
);
25148 mp_print_char
(mp
, xord
('
)'
));
25152 @ @
<Declare unary action...@
>=
25153 static void mp_bad_unary
(MP mp
, quarterword c
) {
25156 int old_setting
= mp-
>selector
;
25157 const char
*hlp
[] = {
25158 "I'm afraid I don't know how to apply that operation to that",
25159 "particular type. Continue, and I'll simply return the",
25160 "argument (shown above) as the result of the operation.",
25162 mp-
>selector
= new_string
;
25163 mp_print_op
(mp
, c
);
25164 mp_print_known_or_unknown_type
(mp
, mp-
>cur_exp.type
, cur_exp_node
());
25165 sname
= mp_make_string
(mp
);
25166 mp-
>selector
= old_setting
;
25167 mp_snprintf
(msg
, 256, "Not implemented: %s", mp_str
(mp
, sname
));
25168 delete_str_ref
(sname
);
25169 mp_disp_err
(mp
, NULL);
25170 mp_back_error
(mp
, msg
, hlp
, true
);
25171 @.Not implemented...@
>;
25172 mp_get_x_next
(mp
);
25177 @ Negation is easy except when the current expression
25178 is of type |independent|
, or when it is a pair with one or more
25179 |independent| components.
25181 @
<Declare unary action...@
>=
25182 static void mp_negate_dep_list
(MP mp
, mp_value_node p
) {
25185 number_negate
(dep_value
(p
));
25186 if
(dep_info
(p
) == NULL)
25188 p
= (mp_value_node
) mp_link
(p
);
25193 @ It is tempting to argue that the negative of an independent variable
25194 is an independent variable
, hence we don't have to do anything when
25195 negating it. The fallacy is that other dependent variables pointing
25196 to the current expression must change the sign of their
25197 coefficients if we make no change to the current expression.
25199 Instead
, we work around the problem by copying the current expression
25200 and recycling it afterwards
(cf.~the |stash_in| routine
).
25202 @d negate_value
(A
) if
(mp_type
(A
) == mp_known
) {
25203 set_value_number
(A
, (value_number
(A
))); /* to clear the rest
*/
25204 number_negate
(value_number
(A
));
25206 mp_negate_dep_list
(mp
, (mp_value_node
) dep_list
((mp_value_node
) A
));
25209 @
<Declare unary action...@
>=
25210 static void negate_cur_expr
(MP mp
) {
25211 mp_node p
, q
, r
; /* for list manipulation
*/
25212 switch
(mp-
>cur_exp.type
) {
25213 case mp_color_type
:
25214 case mp_cmykcolor_type
:
25216 case mp_independent
:
25217 q
= cur_exp_node
();
25218 mp_make_exp_copy
(mp
, q
);
25219 if
(mp-
>cur_exp.type
== mp_dependent
) {
25220 mp_negate_dep_list
(mp
, (mp_value_node
) dep_list
((mp_value_node
)
25222 } else if
(mp-
>cur_exp.type
<= mp_pair_type
) {
25223 /* |mp_color_type| |mp_cmykcolor_type|
, or |mp_pair_type|
*/
25224 p
= value_node
(cur_exp_node
());
25225 switch
(mp-
>cur_exp.type
) {
25232 case mp_color_type
:
25235 r
= green_part
(p
);
25240 case mp_cmykcolor_type
:
25243 r
= magenta_part
(p
);
25245 r
= yellow_part
(p
);
25247 r
= black_part
(p
);
25250 default
: /* there are no other valid cases
, but please the compiler
*/
25253 } /* if |cur_type
=mp_known| then |cur_exp
=0|
*/
25254 mp_recycle_value
(mp
, q
);
25255 mp_free_value_node
(mp
, q
);
25258 case mp_proto_dependent
:
25259 mp_negate_dep_list
(mp
, (mp_value_node
) dep_list
((mp_value_node
)
25263 if
(is_number
(cur_exp_value_number
()))
25264 number_negate
(cur_exp_value_number
());
25267 mp_bad_unary
(mp
, mp_minus
);
25272 @ If the current expression is a pair
, but the context wants it to
25273 be a path
, we call |pair_to_path|.
25275 @
<Declare unary action...@
>=
25276 static void mp_pair_to_path
(MP mp
) {
25277 set_cur_exp_knot
(mp_pair_to_knot
(mp
));
25278 mp-
>cur_exp.type
= mp_path_type
;
25283 @ @
<Declarations@
>=
25284 static void mp_bad_color_part
(MP mp
, quarterword c
);
25287 static void mp_bad_color_part
(MP mp
, quarterword c
) {
25288 mp_node p
; /* the big node
*/
25293 const char
*hlp
[] = {
25294 "You can only ask for the redpart, greenpart, bluepart of a rgb object,",
25295 "the cyanpart, magentapart, yellowpart or blackpart of a cmyk object, ",
25296 "or the greypart of a grey object. No mixing and matching, please.",
25298 memset
(&new_expr,0,sizeof(mp_value));
25299 new_number
(new_expr.data.n
);
25300 p
= mp_link
(edge_list
(cur_exp_node
()));
25301 mp_disp_err
(mp
, NULL);
25302 old_setting
= mp-
>selector
;
25303 mp-
>selector
= new_string
;
25304 mp_print_op
(mp
, c
);
25305 sname
= mp_make_string
(mp
);
25306 mp-
>selector
= old_setting
;
25307 @.Wrong picture color model...@
>;
25308 if
(mp_color_model
(p
) == mp_grey_model
)
25309 mp_snprintf
(msg
, 256, "Wrong picture color model: %s of grey object", mp_str
(mp
, sname
));
25310 else if
(mp_color_model
(p
) == mp_cmyk_model
)
25311 mp_snprintf
(msg
, 256, "Wrong picture color model: %s of cmyk object", mp_str
(mp
, sname
));
25312 else if
(mp_color_model
(p
) == mp_rgb_model
)
25313 mp_snprintf
(msg
, 256, "Wrong picture color model: %s of rgb object", mp_str
(mp
, sname
));
25314 else if
(mp_color_model
(p
) == mp_no_model
)
25315 mp_snprintf
(msg
, 256, "Wrong picture color model: %s of marking object", mp_str
(mp
, sname
));
25317 mp_snprintf
(msg
, 256, "Wrong picture color model: %s of defaulted object", mp_str
(mp
, sname
));
25318 delete_str_ref
(sname
);
25319 mp_error
(mp
, msg
, hlp
, true
);
25320 if
(c
== mp_black_part
)
25321 number_clone
(new_expr.data.n
, unity_t
);
25323 set_number_to_zero
(new_expr.data.n
);
25324 mp_flush_cur_exp
(mp
, new_expr
);
25328 @ In the following procedure
, |cur_exp| points to a capsule
, which points to
25329 a big node. We want to delete all but one part of the big node.
25331 @
<Declare unary action...@
>=
25332 static void mp_take_part
(MP mp
, quarterword c
) {
25333 mp_node p
; /* the big node
*/
25334 p
= value_node
(cur_exp_node
());
25335 set_value_node
(mp-
>temp_val
, p
);
25336 mp_type
(mp-
>temp_val
) = mp-
>cur_exp.type
;
25337 mp_link
(p
) = mp-
>temp_val
;
25338 mp_free_value_node
(mp
, cur_exp_node
());
25341 if
(mp-
>cur_exp.type
== mp_pair_type
)
25342 mp_make_exp_copy
(mp
, x_part
(p
));
25344 mp_make_exp_copy
(mp
, tx_part
(p
));
25347 if
(mp-
>cur_exp.type
== mp_pair_type
)
25348 mp_make_exp_copy
(mp
, y_part
(p
));
25350 mp_make_exp_copy
(mp
, ty_part
(p
));
25353 mp_make_exp_copy
(mp
, xx_part
(p
));
25356 mp_make_exp_copy
(mp
, xy_part
(p
));
25359 mp_make_exp_copy
(mp
, yx_part
(p
));
25362 mp_make_exp_copy
(mp
, yy_part
(p
));
25365 mp_make_exp_copy
(mp
, red_part
(p
));
25367 case mp_green_part
:
25368 mp_make_exp_copy
(mp
, green_part
(p
));
25371 mp_make_exp_copy
(mp
, blue_part
(p
));
25374 mp_make_exp_copy
(mp
, cyan_part
(p
));
25376 case mp_magenta_part
:
25377 mp_make_exp_copy
(mp
, magenta_part
(p
));
25379 case mp_yellow_part
:
25380 mp_make_exp_copy
(mp
, yellow_part
(p
));
25382 case mp_black_part
:
25383 mp_make_exp_copy
(mp
, black_part
(p
));
25386 mp_recycle_value
(mp
, mp-
>temp_val
);
25390 @ @
<Initialize table entries@
>=
25391 mp-
>temp_val
= mp_get_value_node
(mp
);
25392 mp_name_type
(mp-
>temp_val
) = mp_capsule
;
25394 @ @
<Free table entries@
>=
25395 mp_free_value_node
(mp
, mp-
>temp_val
);
25398 @ @
<Declarations@
>=
25399 static mp_edge_header_node mp_scale_edges
(MP mp
, mp_number se_sf
, mp_edge_header_node se_pic
);
25401 @ @
<Declare unary action...@
>=
25402 static void mp_take_pict_part
(MP mp
, quarterword c
) {
25403 mp_node p
; /* first graphical object in |cur_exp|
*/
25405 memset
(&new_expr,0,sizeof(mp_value));
25406 new_number
(new_expr.data.n
);
25407 p
= mp_link
(edge_list
(cur_exp_node
()));
25416 if
(mp_type
(p
) == mp_text_node_type
) {
25417 mp_text_node p0
= (mp_text_node
)p
;
25420 number_clone
(new_expr.data.n
, p0-
>tx
);
25423 number_clone
(new_expr.data.n
, p0-
>ty
);
25426 number_clone
(new_expr.data.n
, p0-
>txx
);
25429 number_clone
(new_expr.data.n
, p0-
>txy
);
25432 number_clone
(new_expr.data.n
, p0-
>tyx
);
25435 number_clone
(new_expr.data.n
, p0-
>tyy
);
25438 mp_flush_cur_exp
(mp
, new_expr
);
25443 case mp_green_part
:
25445 if
(has_color
(p
)) {
25448 number_clone
(new_expr.data.n
,((mp_stroked_node
)p
)->red
);
25450 case mp_green_part
:
25451 number_clone
(new_expr.data.n
,((mp_stroked_node
)p
)->green
);
25454 number_clone
(new_expr.data.n
,((mp_stroked_node
)p
)->blue
);
25457 mp_flush_cur_exp
(mp
, new_expr
);
25462 case mp_magenta_part
:
25463 case mp_yellow_part
:
25464 case mp_black_part
:
25465 if
(has_color
(p
)) {
25466 if
(mp_color_model
(p
) == mp_uninitialized_model
&& c == mp_black_part) {
25467 set_number_to_unity
(new_expr.data.n
);
25471 number_clone
(new_expr.data.n
,((mp_stroked_node
)p
)->cyan
);
25473 case mp_magenta_part
:
25474 number_clone
(new_expr.data.n
,((mp_stroked_node
)p
)->magenta
);
25476 case mp_yellow_part
:
25477 number_clone
(new_expr.data.n
,((mp_stroked_node
)p
)->yellow
);
25479 case mp_black_part
:
25480 number_clone
(new_expr.data.n
,((mp_stroked_node
)p
)->black
);
25484 mp_flush_cur_exp
(mp
, new_expr
);
25489 if
(has_color
(p
)) {
25490 number_clone
(new_expr.data.n
,((mp_stroked_node
)p
)->grey
);
25491 mp_flush_cur_exp
(mp
, new_expr
);
25495 case mp_color_model_part
:
25496 if
(has_color
(p
)) {
25497 if
(mp_color_model
(p
) == mp_uninitialized_model
) {
25498 number_clone
(new_expr.data.n
, internal_value
(mp_default_color_model
));
25500 number_clone
(new_expr.data.n
, unity_t
);
25501 number_multiply_int
(new_expr.data.n
, mp_color_model
(p
));
25503 mp_flush_cur_exp
(mp
, new_expr
);
25508 if
(mp_type
(p
) != mp_text_node_type
)
25511 new_expr.data.str
= mp_text_p
(p
);
25512 add_str_ref
(new_expr.data.str
);
25513 mp_flush_cur_exp
(mp
, new_expr
);
25514 mp-
>cur_exp.type
= mp_string_type
;
25517 case mp_prescript_part
:
25518 if
(!has_color
(p
)) {
25521 if
(mp_pre_script
(p
)) {
25522 new_expr.data.str
= mp_pre_script
(p
);
25523 add_str_ref
(new_expr.data.str
);
25525 new_expr.data.str
= mp_rts
(mp
,"");
25527 mp_flush_cur_exp
(mp
, new_expr
);
25528 mp-
>cur_exp.type
= mp_string_type
;
25531 case mp_postscript_part
:
25532 if
(!has_color
(p
)) {
25535 if
(mp_post_script
(p
)) {
25536 new_expr.data.str
= mp_post_script
(p
);
25537 add_str_ref
(new_expr.data.str
);
25539 new_expr.data.str
= mp_rts
(mp
,"");
25541 mp_flush_cur_exp
(mp
, new_expr
);
25542 mp-
>cur_exp.type
= mp_string_type
;
25546 if
(mp_type
(p
) != mp_text_node_type
)
25549 new_expr.data.str
= mp_rts
(mp
, mp-
>font_name
[mp_font_n
(p
)]);
25550 add_str_ref
(new_expr.data.str
);
25551 mp_flush_cur_exp
(mp
, new_expr
);
25552 mp-
>cur_exp.type
= mp_string_type
;
25556 if
(mp_type
(p
) == mp_text_node_type
) {
25558 } else if
(is_stop
(p
)) {
25559 mp_confusion
(mp
, "pict");
25561 new_expr.data.node
= NULL;
25562 switch
(mp_type
(p
)) {
25563 case mp_fill_node_type
:
25564 new_expr.data.p
= mp_copy_path
(mp
, mp_path_p
((mp_fill_node
) p
));
25566 case mp_stroked_node_type
:
25567 new_expr.data.p
= mp_copy_path
(mp
, mp_path_p
((mp_stroked_node
) p
));
25569 case mp_start_bounds_node_type
:
25570 new_expr.data.p
= mp_copy_path
(mp
, mp_path_p
((mp_start_bounds_node
) p
));
25572 case mp_start_clip_node_type
:
25573 new_expr.data.p
= mp_copy_path
(mp
, mp_path_p
((mp_start_clip_node
) p
));
25579 mp_flush_cur_exp
(mp
, new_expr
);
25580 mp-
>cur_exp.type
= mp_path_type
;
25584 if
(!has_pen
(p
)) {
25587 switch
(mp_type
(p
)) {
25588 case mp_fill_node_type
:
25589 if
(mp_pen_p
((mp_fill_node
) p
) == NULL)
25592 new_expr.data.p
= copy_pen
(mp_pen_p
((mp_fill_node
) p
));
25593 mp_flush_cur_exp
(mp
, new_expr
);
25594 mp-
>cur_exp.type
= mp_pen_type
;
25597 case mp_stroked_node_type
:
25598 if
(mp_pen_p
((mp_stroked_node
) p
) == NULL)
25601 new_expr.data.p
= copy_pen
(mp_pen_p
((mp_stroked_node
) p
));
25602 mp_flush_cur_exp
(mp
, new_expr
);
25603 mp-
>cur_exp.type
= mp_pen_type
;
25613 if
(mp_type
(p
) != mp_stroked_node_type
) {
25616 if
(mp_dash_p
(p
) == NULL) {
25619 add_edge_ref
(mp_dash_p
(p
));
25620 new_expr.data.node
= (mp_node
)mp_scale_edges
(mp
, ((mp_stroked_node
)p
)->dash_scale
,
25621 (mp_edge_header_node
)mp_dash_p
(p
));
25622 mp_flush_cur_exp
(mp
, new_expr
);
25623 mp-
>cur_exp.type
= mp_picture_type
;
25627 } /* all cases have been enumerated
*/
25631 /* Convert the current expression to a
NULL value appropriate for |c|
*/
25635 case mp_prescript_part
:
25636 case mp_postscript_part
:
25637 new_expr.data.str
= mp_rts
(mp
,"");
25638 mp_flush_cur_exp
(mp
, new_expr
);
25639 mp-
>cur_exp.type
= mp_string_type
;
25642 new_expr.data.p
= mp_new_knot
(mp
);
25643 mp_flush_cur_exp
(mp
, new_expr
);
25644 mp_left_type
(cur_exp_knot
()) = mp_endpoint
;
25645 mp_right_type
(cur_exp_knot
()) = mp_endpoint
;
25646 mp_next_knot
(cur_exp_knot
()) = cur_exp_knot
();
25647 set_number_to_zero
(cur_exp_knot
()->x_coord
);
25648 set_number_to_zero
(cur_exp_knot
()->y_coord
);
25649 mp_originator
(cur_exp_knot
()) = mp_metapost_user
;
25650 mp-
>cur_exp.type
= mp_path_type
;
25653 new_expr.data.p
= mp_get_pen_circle
(mp
, zero_t
);
25654 mp_flush_cur_exp
(mp
, new_expr
);
25655 mp-
>cur_exp.type
= mp_pen_type
;
25658 new_expr.data.node
= (mp_node
)mp_get_edge_header_node
(mp
);
25659 mp_flush_cur_exp
(mp
, new_expr
);
25660 mp_init_edges
(mp
, (mp_edge_header_node
)cur_exp_node
());
25661 mp-
>cur_exp.type
= mp_picture_type
;
25664 set_number_to_zero
(new_expr.data.n
);
25665 mp_flush_cur_exp
(mp
, new_expr
);
25670 @ @
<Declare unary action...@
>=
25671 static void mp_str_to_num
(MP mp
, quarterword c
) { /* converts a string to a number
*/
25672 integer n
; /* accumulator
*/
25673 ASCII_code m
; /* current character
*/
25674 unsigned k
; /* index into |str_pool|
*/
25675 int b
; /* radix of conversion
*/
25676 boolean bad_char
; /* did the string contain an invalid digit?
*/
25678 memset
(&new_expr,0,sizeof(mp_value));
25679 new_number
(new_expr.data.n
);
25680 if
(c
== mp_ASCII_op
) {
25681 if
(cur_exp_str
()->len
== 0)
25684 n
= cur_exp_str
()->str
[0];
25686 if
(c
== mp_oct_op
)
25692 for
(k
= 0; k
< cur_exp_str
()->len
; k
++) {
25693 m
= (ASCII_code
) (*(cur_exp_str
()->str
+ k
));
25694 if
((m
>= '
0'
) && (m <= '9'))
25695 m
= (ASCII_code
) (m
- '
0'
);
25696 else if
((m
>= 'A'
) && (m <= 'F'))
25697 m
= (ASCII_code
) (m
- 'A'
+ 10);
25698 else if
((m
>= 'a'
) && (m <= 'f'))
25699 m
= (ASCII_code
) (m
- 'a'
+ 10);
25704 if
((int
) m
>= b
) {
25713 /* Give error messages if |bad_char| or |n
>=4096|
*/
25715 const char
*hlp
[] = {"I zeroed out characters that weren't hex digits.", NULL};
25716 if
(c
== mp_oct_op
) {
25717 hlp
[0] = "I zeroed out characters that weren't in the range 0..7.";
25719 mp_disp_err
(mp
, NULL);
25720 mp_back_error
(mp
, "String contains illegal digits", hlp
, true
);
25721 mp_get_x_next
(mp
);
25723 if
((n
> 4095)) { /* todo
, this is scaled specific
*/
25724 if
(number_positive
(internal_value
(mp_warning_check
))) {
25726 const char
*hlp
[] = {
25727 "I have trouble with numbers greater than 4095; watch out.",
25728 "(Set warningcheck:=0 to suppress this message.)",
25730 mp_snprintf
(msg
, 256,"Number too large (%d)", (int
)n
);
25731 mp_back_error
(mp
, msg
, hlp
, true
);
25732 mp_get_x_next
(mp
);
25736 number_clone
(new_expr.data.n
, unity_t
);
25737 number_multiply_int
(new_expr.data.n
, n
);
25738 mp_flush_cur_exp
(mp
, new_expr
);
25741 @ @
<Declare unary action...@
>=
25742 static void mp_path_length
(MP mp
, mp_number
*n
) { /* computes the length of the current path
*/
25743 mp_knot p
; /* traverser
*/
25744 set_number_to_zero
(*n
);
25745 p
= cur_exp_knot
();
25746 if
(mp_left_type
(p
) == mp_endpoint
) {
25747 number_substract
(*n
, unity_t
); /* -unity
*/
25750 p
= mp_next_knot
(p
);
25751 number_add
(*n
, unity_t
);
25752 } while
(p
!= cur_exp_knot
());
25756 @ @
<Declare unary action...@
>=
25757 static void mp_pict_length
(MP mp
, mp_number
*n
) {
25758 /* counts interior components in picture |cur_exp|
*/
25759 mp_node p
; /* traverser
*/
25760 set_number_to_zero
(*n
);
25761 p
= mp_link
(edge_list
(cur_exp_node
()));
25763 if
(is_start_or_stop
(p
))
25764 if
(mp_skip_1component
(mp
, p
) == NULL)
25766 while
(p
!= NULL) {
25767 if
( ! is_start_or_stop
(p
) )
25769 else if
( ! is_stop
(p
))
25770 p
= mp_skip_1component
(mp
, p
);
25773 number_add
(*n
, unity_t
);
25779 @ The function |an_angle| returns the value of the |angle| primitive
, or $
0$ if the
25780 argument is |origin|.
25782 @
<Declare unary action...@
>=
25783 static void mp_an_angle
(MP mp
, mp_number
*ret
, mp_number xpar
, mp_number ypar
) {
25784 set_number_to_zero
(*ret
);
25785 if
((!(number_zero
(xpar
) && number_zero(ypar)))) {
25786 n_arg
(*ret
, xpar
, ypar
);
25791 @ The actual turning number is
(for the moment
) computed in a C function
25792 that receives eight integers corresponding to the four controlling points
,
25793 and returns a single angle. Besides those
, we have to account for discrete
25794 moves at the actual points.
25796 @d mp_floor
(a
) ((a
)>=0 ?
(int
)(a
) : -(int
)(-(a
)))
25797 @d bezier_error
(720*(256*256*16))+1
25798 @d mp_sign
(v
) ((v
)>0 ?
1 : ((v
)<0 ?
-1 : 0 ))
25799 @d mp_out
(A
) (double
)((A
)/16)
25801 @
<Declare unary action...@
>=
25802 static void mp_bezier_slope
(MP mp
, mp_number
*ret
, mp_number AX
, mp_number AY
, mp_number BX
,
25803 mp_number
BY, mp_number CX
, mp_number CY
, mp_number DX
,
25807 static void mp_bezier_slope
(MP mp
, mp_number
*ret
, mp_number AX
, mp_number AY
, mp_number BX
,
25808 mp_number
BY, mp_number CX
, mp_number CY
, mp_number DX
,
25811 mp_number deltax
, deltay
;
25812 double ax
, ay
, bx
, by
, cx
, cy
, dx
, dy
;
25813 mp_number xi
, xo
, xm
;
25815 ax
= number_to_double
(AX
);
25816 ay
= number_to_double
(AY
);
25817 bx
= number_to_double
(BX
);
25818 by
= number_to_double
(BY);
25819 cx
= number_to_double
(CX
);
25820 cy
= number_to_double
(CY
);
25821 dx
= number_to_double
(DX
);
25822 dy
= number_to_double
(DY
);
25823 new_number
(deltax
);
25824 new_number
(deltay
);
25825 set_number_from_substraction
(deltax
, BX
, AX
);
25826 set_number_from_substraction
(deltay
, BY, AY
);
25827 if
(number_zero
(deltax
) && number_zero(deltay)) {
25828 set_number_from_substraction
(deltax
, CX
, AX
);
25829 set_number_from_substraction
(deltay
, CY
, AY
);
25831 if
(number_zero
(deltax
) && number_zero(deltay)) {
25832 set_number_from_substraction
(deltax
, DX
, AX
);
25833 set_number_from_substraction
(deltay
, DY
, AY
);
25838 mp_an_angle
(mp
, &xi, deltax, deltay);
25839 set_number_from_substraction
(deltax
, CX
, BX
);
25840 set_number_from_substraction
(deltay
, CY
, BY);
25841 mp_an_angle
(mp
, &xm, deltax, deltay); /* !!! never used? */
25842 set_number_from_substraction
(deltax
, DX
, CX
);
25843 set_number_from_substraction
(deltay
, DY
, CY
);
25844 if
(number_zero
(deltax
) && number_zero(deltay)) {
25845 set_number_from_substraction
(deltax
, DX
, BX
);
25846 set_number_from_substraction
(deltay
, DY
, BY);
25848 if
(number_zero
(deltax
) && number_zero(deltay)) {
25849 set_number_from_substraction
(deltax
, DX
, AX
);
25850 set_number_from_substraction
(deltay
, DY
, AY
);
25852 mp_an_angle
(mp
, &xo, deltax, deltay);
25853 a
= (bx
- ax
) * (cy
- by
) - (cx
- bx
) * (by
- ay
); /* a
= (bp-ap
)x
(cp-bp
); */
25854 b
= (bx
- ax
) * (dy
- cy
) - (by
- ay
) * (dx
- cx
);; /* b
= (bp-ap
)x
(dp-cp
); */
25855 c
= (cx
- bx
) * (dy
- cy
) - (dx
- cx
) * (cy
- by
); /* c
= (cp-bp
)x
(dp-cp
); */
25856 if
((a
== 0) && (c == 0)) {
25857 res
= (b
== 0 ?
0 : (mp_out
(number_to_double
(xo
)) - mp_out
(number_to_double
(xi
))));
25858 } else if
((a
== 0) ||
(c
== 0)) {
25859 if
((mp_sign
(b
) == mp_sign
(a
)) ||
(mp_sign
(b
) == mp_sign
(c
))) {
25860 res
= mp_out
(number_to_double
(xo
)) - mp_out
(number_to_double
(xi
)); /* ?
*/
25863 else if
(res
> 180.0)
25866 res
= mp_out
(number_to_double
(xo
)) - mp_out
(number_to_double
(xi
)); /* ?
*/
25868 } else if
((mp_sign
(a
) * mp_sign
(c
)) < 0) {
25869 res
= mp_out
(number_to_double
(xo
)) - mp_out
(number_to_double
(xi
)); /* ?
*/
25872 else if
(res
> 180.0)
25875 if
(mp_sign
(a
) == mp_sign
(b
)) {
25876 res
= mp_out
(number_to_double
(xo
)) - mp_out
(number_to_double
(xi
)); /* ?
*/
25879 else if
(res
> 180.0)
25882 if
((b
* b
) == (4 * a
* c
)) {
25883 res
= (double
) bezier_error
;
25884 } else if
((b
* b
) < (4 * a
* c
)) {
25885 res
= mp_out
(number_to_double
(xo
)) - mp_out
(number_to_double
(xi
)); /* ?
*/
25886 if
(res
<= 0.0 && res > -180.0)
25888 else if
(res
>= 0.0 && res < 180.0)
25891 res
= mp_out
(number_to_double
(xo
)) - mp_out
(number_to_double
(xi
));
25894 else if
(res
> 180.0)
25899 free_number
(deltax
);
25900 free_number
(deltay
);
25904 set_number_from_double
(*ret
, res
);
25905 convert_scaled_to_angle
(*ret
);
25910 @d p_nextnext mp_next_knot
(mp_next_knot
(p
))
25911 @d p_next mp_next_knot
(p
)
25913 @
<Declare unary action...@
>=
25914 static void mp_turn_cycles
(MP mp
, mp_number
*turns
, mp_knot c
) {
25915 mp_angle res
, ang
; /* the angles of intermediate results
*/
25916 mp_knot p
; /* for running around the path
*/
25917 mp_number xp
, yp
; /* coordinates of next point
*/
25918 mp_number x
, y
; /* helper coordinates
*/
25919 mp_number arg1
, arg2
;
25920 mp_angle in_angle
, out_angle
; /* helper angles
*/
25921 mp_angle seven_twenty_deg_t
, neg_one_eighty_deg_t
;
25922 unsigned old_setting
; /* saved |selector| setting
*/
25923 set_number_to_zero
(*turns
);
25930 new_angle
(in_angle
);
25931 new_angle
(out_angle
);
25934 new_angle
(seven_twenty_deg_t
);
25935 new_angle
(neg_one_eighty_deg_t
);
25936 number_clone
(seven_twenty_deg_t
, three_sixty_deg_t
);
25937 number_double
(seven_twenty_deg_t
);
25938 number_clone
(neg_one_eighty_deg_t
, one_eighty_deg_t
);
25939 number_negate
(neg_one_eighty_deg_t
);
25941 old_setting
= mp-
>selector
;
25942 mp-
>selector
= term_only
;
25943 if
(number_greater
(internal_value
(mp_tracing_commands
), unity_t
)) {
25944 mp_begin_diagnostic
(mp
);
25945 mp_print_nl
(mp
, "");
25946 mp_end_diagnostic
(mp
, false
);
25949 number_clone
(xp
, p_next-
>x_coord
);
25950 number_clone
(yp
, p_next-
>y_coord
);
25951 mp_bezier_slope
(mp
, &ang, p->x_coord, p->y_coord, p->right_x, p->right_y,
25952 p_next-
>left_x
, p_next-
>left_y
, xp
, yp
);
25953 if
(number_greater
(ang
, seven_twenty_deg_t
)) {
25954 mp_error
(mp
, "Strange path", NULL, true
);
25955 mp-
>selector
= old_setting
;
25956 set_number_to_zero
(*turns
);
25959 number_add
(res
, ang
);
25960 if
(number_greater
(res
, one_eighty_deg_t
)) {
25961 number_substract
(res
, three_sixty_deg_t
);
25962 number_add
(*turns
, unity_t
);
25964 if
(number_lessequal
(res
, neg_one_eighty_deg_t
)) {
25965 number_add
(res
, three_sixty_deg_t
);
25966 number_substract
(*turns
, unity_t
);
25968 /* incoming angle at next point
*/
25969 number_clone
(x
, p_next-
>left_x
);
25970 number_clone
(y
, p_next-
>left_y
);
25971 if
(number_equal
(xp
, x
) && number_equal(yp, y)) {
25972 number_clone
(x
, p-
>right_x
);
25973 number_clone
(y
, p-
>right_y
);
25975 if
(number_equal
(xp
, x
) && number_equal(yp, y)) {
25976 number_clone
(x
, p-
>x_coord
);
25977 number_clone
(y
, p-
>y_coord
);
25979 set_number_from_substraction
(arg1
, xp
, x
);
25980 set_number_from_substraction
(arg2
, yp
, y
);
25981 mp_an_angle
(mp
, &in_angle, arg1, arg2);
25982 /* outgoing angle at next point
*/
25983 number_clone
(x
, p_next-
>right_x
);
25984 number_clone
(y
, p_next-
>right_y
);
25985 if
(number_equal
(xp
, x
) && number_equal(yp, y)) {
25986 number_clone
(x
, p_nextnext-
>left_x
);
25987 number_clone
(y
, p_nextnext-
>left_y
);
25989 if
(number_equal
(xp
, x
) && number_equal(yp, y)) {
25990 number_clone
(x
, p_nextnext-
>x_coord
);
25991 number_clone
(y
, p_nextnext-
>y_coord
);
25993 set_number_from_substraction
(arg1
, x
, xp
);
25994 set_number_from_substraction
(arg2
, y
, yp
);
25995 mp_an_angle
(mp
, &out_angle, arg1, arg2);
25996 set_number_from_substraction
(ang
, out_angle
, in_angle
);
25997 mp_reduce_angle
(mp
, &ang);
25998 if
(number_nonzero
(ang
)) {
25999 number_add
(res
, ang
);
26000 if
(number_greaterequal
(res
, one_eighty_deg_t
)) {
26001 number_substract
(res
, three_sixty_deg_t
);
26002 number_add
(*turns
, unity_t
);
26004 if
(number_lessequal
(res
, neg_one_eighty_deg_t
)) {
26005 number_add
(res
, three_sixty_deg_t
);
26006 number_substract
(*turns
, unity_t
);
26009 p
= mp_next_knot
(p
);
26011 mp-
>selector
= old_setting
;
26017 free_number
(seven_twenty_deg_t
);
26018 free_number
(neg_one_eighty_deg_t
);
26019 free_number
(in_angle
);
26020 free_number
(out_angle
);
26027 @ @
<Declare unary action...@
>=
26028 static void mp_turn_cycles_wrapper
(MP mp
, mp_number
*ret
, mp_knot c
) {
26029 if
(mp_next_knot
(c
) == c
) {
26030 /* one-knot paths always have a turning number of
1 */
26031 set_number_to_unity
(*ret
);
26033 mp_turn_cycles
(mp
, ret
, c
);
26037 @ @
<Declare unary action procedures@
>=
26038 static void mp_test_known
(MP mp
, quarterword c
) {
26039 int b
; /* is the current expression known?
*/
26040 mp_node p
; /* location in a big node
*/
26042 memset
(&new_expr,0,sizeof(mp_value));
26043 new_number
(new_expr.data.n
);
26045 switch
(mp-
>cur_exp.type
) {
26047 case mp_boolean_type
:
26048 case mp_string_type
:
26051 case mp_picture_type
:
26055 case mp_transform_type
:
26056 p
= value_node
(cur_exp_node
());
26057 if
(mp_type
(tx_part
(p
)) != mp_known
)
26059 if
(mp_type
(ty_part
(p
)) != mp_known
)
26061 if
(mp_type
(xx_part
(p
)) != mp_known
)
26063 if
(mp_type
(xy_part
(p
)) != mp_known
)
26065 if
(mp_type
(yx_part
(p
)) != mp_known
)
26067 if
(mp_type
(yy_part
(p
)) != mp_known
)
26071 case mp_color_type
:
26072 p
= value_node
(cur_exp_node
());
26073 if
(mp_type
(red_part
(p
)) != mp_known
)
26075 if
(mp_type
(green_part
(p
)) != mp_known
)
26077 if
(mp_type
(blue_part
(p
)) != mp_known
)
26081 case mp_cmykcolor_type
:
26082 p
= value_node
(cur_exp_node
());
26083 if
(mp_type
(cyan_part
(p
)) != mp_known
)
26085 if
(mp_type
(magenta_part
(p
)) != mp_known
)
26087 if
(mp_type
(yellow_part
(p
)) != mp_known
)
26089 if
(mp_type
(black_part
(p
)) != mp_known
)
26094 p
= value_node
(cur_exp_node
());
26095 if
(mp_type
(x_part
(p
)) != mp_known
)
26097 if
(mp_type
(y_part
(p
)) != mp_known
)
26104 if
(c
== mp_known_op
) {
26105 set_number_from_boolean
(new_expr.data.n
, b
);
26107 if
(b
==mp_true_code
) {
26108 set_number_from_boolean
(new_expr.data.n
, mp_false_code
);
26110 set_number_from_boolean
(new_expr.data.n
, mp_true_code
);
26113 mp_flush_cur_exp
(mp
, new_expr
);
26114 cur_exp_node
() = NULL; /* !! do not replace with |set_cur_exp_node
()|
!! */
26115 mp-
>cur_exp.type
= mp_boolean_type
;
26118 @ The |pair_value| routine changes the current expression to a
26119 given ordered pair of values.
26121 @
<Declare unary action procedures@
>=
26122 static void mp_pair_value
(MP mp
, mp_number x
, mp_number y
) {
26123 mp_node p
; /* a pair node
*/
26128 number_clone
(x1
, x
);
26129 number_clone
(y1
, y
);
26130 memset
(&new_expr,0,sizeof(mp_value));
26131 new_number
(new_expr.data.n
);
26132 p
= mp_get_value_node
(mp
);
26133 new_expr.type
= mp_type
(p
);
26134 new_expr.data.node
= p
;
26135 mp_flush_cur_exp
(mp
, new_expr
);
26136 mp-
>cur_exp.type
= mp_pair_type
;
26137 mp_name_type
(p
) = mp_capsule
;
26138 mp_init_pair_node
(mp
, p
);
26139 p
= value_node
(p
);
26140 mp_type
(x_part
(p
)) = mp_known
;
26141 set_value_number
(x_part
(p
), x1
);
26142 mp_type
(y_part
(p
)) = mp_known
;
26143 set_value_number
(y_part
(p
), y1
);
26149 @ Here is a function that sets |minx|
, |maxx|
, |miny|
, |maxy| to the bounding
26150 box of the current expression. The boolean result is |false| if the expression
26151 has the wrong type.
26153 @
<Declare unary action procedures@
>=
26154 static boolean mp_get_cur_bbox
(MP mp
) {
26155 switch
(mp-
>cur_exp.type
) {
26156 case mp_picture_type
:
26158 mp_edge_header_node p0
= (mp_edge_header_node
)cur_exp_node
();
26159 mp_set_bbox
(mp
, p0
, true
);
26160 if
(number_greater
(p0-
>minx
, p0-
>maxx
)) {
26161 set_number_to_zero
(mp_minx
);
26162 set_number_to_zero
(mp_maxx
);
26163 set_number_to_zero
(mp_miny
);
26164 set_number_to_zero
(mp_maxy
);
26166 number_clone
(mp_minx
, p0-
>minx
);
26167 number_clone
(mp_maxx
, p0-
>maxx
);
26168 number_clone
(mp_miny
, p0-
>miny
);
26169 number_clone
(mp_maxy
, p0-
>maxy
);
26174 mp_path_bbox
(mp
, cur_exp_knot
());
26177 mp_pen_bbox
(mp
, cur_exp_knot
());
26186 @ Here is a routine that interprets |cur_exp| as a file name and tries to read
26187 a line from the file or to close the file.
26189 @
<Declare unary action procedures@
>=
26190 static void mp_do_read_or_close
(MP mp
, quarterword c
) {
26192 readf_index n
, n0
; /* indices for searching |rd_fname|
*/
26193 memset
(&new_expr,0,sizeof(mp_value));
26194 new_number
(new_expr.data.n
);
26195 /* Find the |n| where |rd_fname
[n
]=cur_exp|
; if |cur_exp| must be inserted
,
26196 call |start_read_input| and |goto found| or |not_found|
*/
26197 /* Free slots in the |rd_file| and |rd_fname| arrays are marked with
NULL's in
26201 n
= mp-
>read_files
;
26202 n0
= mp-
>read_files
;
26203 fn
= mp_xstrdup
(mp
, mp_str
(mp
, cur_exp_str
()));
26204 while
(mp_xstrcmp
(fn
, mp-
>rd_fname
[n
]) != 0) {
26207 } else if
(c
== mp_close_from_op
) {
26210 if
(n0
== mp-
>read_files
) {
26211 if
(mp-
>read_files
< mp-
>max_read_files
) {
26212 incr
(mp-
>read_files
);
26217 l
= mp-
>max_read_files
+ (mp-
>max_read_files
/ 4);
26218 rd_file
= xmalloc
((l
+ 1), sizeof
(void
*));
26219 rd_fname
= xmalloc
((l
+ 1), sizeof
(char
*));
26220 for
(k
= 0; k
<= l
; k
++) {
26221 if
(k
<= mp-
>max_read_files
) {
26222 rd_file
[k
] = mp-
>rd_file
[k
];
26223 rd_fname
[k
] = mp-
>rd_fname
[k
];
26226 rd_fname
[k
] = NULL;
26229 xfree
(mp-
>rd_file
);
26230 xfree
(mp-
>rd_fname
);
26231 mp-
>max_read_files
= l
;
26232 mp-
>rd_file
= rd_file
;
26233 mp-
>rd_fname
= rd_fname
;
26237 if
(mp_start_read_input
(mp
, fn
, n
))
26242 if
(mp-
>rd_fname
[n
] == NULL) {
26246 if
(c
== mp_close_from_op
) {
26247 (mp-
>close_file
) (mp
, mp-
>rd_file
[n
]);
26251 mp_begin_file_reading
(mp
);
26253 if
(mp_input_ln
(mp
, mp-
>rd_file
[n
]))
26255 mp_end_file_reading
(mp
);
26257 /* Record the end of file and set |cur_exp| to a dummy value
*/
26258 xfree
(mp-
>rd_fname
[n
]);
26259 mp-
>rd_fname
[n
] = NULL;
26260 if
(n
== mp-
>read_files
- 1)
26261 mp-
>read_files
= n
;
26262 if
(c
== mp_close_from_op
)
26264 new_expr.data.str
= mp-
>eof_line
;
26265 add_str_ref
(new_expr.data.str
);
26266 mp_flush_cur_exp
(mp
, new_expr
);
26267 mp-
>cur_exp.type
= mp_string_type
;
26270 mp_flush_cur_exp
(mp
, new_expr
);
26271 mp-
>cur_exp.type
= mp_vacuous
;
26274 mp_flush_cur_exp
(mp
, new_expr
);
26275 mp_finish_read
(mp
);
26278 @ The string denoting end-of-file is a one-byte string at position zero
, by definition.
26279 I have to cheat a little here because
26282 mp_string eof_line
;
26285 mp-
>eof_line
= mp_rtsl
(mp
, "\0", 1);
26286 mp-
>eof_line-
>refs
= MAX_STR_REF
;
26288 @ Finally
, we have the operations that combine a capsule~|p|
26289 with the current expression.
26291 Several of the binary operations are potentially complicated by the
26292 fact that |independent| values can sneak into capsules. For example
,
26293 we've seen an instance of this difficulty in the unary operation
26294 of negation. In order to reduce the number of cases that need to be
26295 handled
, we first change the two operands
(if necessary
)
26296 to rid them of |independent| components. The original operands are
26297 put into capsules called |old_p| and |old_exp|
, which will be
26298 recycled after the binary operation has been safely carried out.
26300 @d binary_return
{ mp_finish_binary
(mp
, old_p
, old_exp
); return
; }
26303 @
<Declare binary action procedures@
>;
26304 static void mp_finish_binary
(MP mp
, mp_node old_p
, mp_node old_exp
) {
26306 /* Recycle any sidestepped |independent| capsules
*/
26307 if
(old_p
!= NULL) {
26308 mp_recycle_value
(mp
, old_p
);
26309 mp_free_value_node
(mp
, old_p
);
26311 if
(old_exp
!= NULL) {
26312 mp_recycle_value
(mp
, old_exp
);
26313 mp_free_value_node
(mp
, old_exp
);
26316 static void mp_do_binary
(MP mp
, mp_node p
, integer c
) {
26317 mp_node q
, r
, rr
; /* for list manipulation
*/
26318 mp_node old_p
, old_exp
; /* capsules to recycle
*/
26321 if
(number_greater
(internal_value
(mp_tracing_commands
), two_t
)) {
26322 /* Trace the current binary operation
*/
26323 mp_begin_diagnostic
(mp
);
26324 mp_print_nl
(mp
, "{(");
26325 mp_print_exp
(mp
, p
, 0); /* show the operand
, but not verbosely
*/
26326 mp_print_char
(mp
, xord
('
)'
));
26327 mp_print_op
(mp
, (quarterword
) c
);
26328 mp_print_char
(mp
, xord
('
('
));
26329 mp_print_exp
(mp
, NULL, 0);
26330 mp_print
(mp
, ")}");
26331 mp_end_diagnostic
(mp
, false
);
26333 /* Sidestep |independent| cases in capsule |p|
*/
26334 /* A big node is considered to be ``tarnished'' if it contains at least one
26335 independent component. We will define a simple function called `|tarnished|'
26336 that returns |
NULL| if and only if its argument is not tarnished.
*/
26337 switch
(mp_type
(p
)) {
26338 case mp_transform_type
:
26339 case mp_color_type
:
26340 case mp_cmykcolor_type
:
26342 old_p
= mp_tarnished
(mp
, p
);
26344 case mp_independent
:
26351 if
(old_p
!= NULL) {
26352 q
= mp_stash_cur_exp
(mp
);
26354 mp_make_exp_copy
(mp
, old_p
);
26355 p
= mp_stash_cur_exp
(mp
);
26356 mp_unstash_cur_exp
(mp
, q
);
26359 /* Sidestep |independent| cases in the current expression
*/
26360 switch
(mp-
>cur_exp.type
) {
26361 case mp_transform_type
:
26362 case mp_color_type
:
26363 case mp_cmykcolor_type
:
26365 old_exp
= mp_tarnished
(mp
, cur_exp_node
());
26367 case mp_independent
:
26374 if
(old_exp
!= NULL) {
26375 old_exp
= cur_exp_node
();
26376 mp_make_exp_copy
(mp
, old_exp
);
26382 /* Add or subtract the current expression from |p|
*/
26383 if
((mp-
>cur_exp.type
< mp_color_type
) ||
(mp_type
(p
) < mp_color_type
)) {
26384 mp_bad_binary
(mp
, p
, (quarterword
) c
);
26386 quarterword cc
= (quarterword
)c
;
26387 if
((mp-
>cur_exp.type
> mp_pair_type
) && (mp_type (p) > mp_pair_type)) {
26388 mp_add_or_subtract
(mp
, p
, NULL, cc
);
26390 if
(mp-
>cur_exp.type
!= mp_type
(p
)) {
26391 mp_bad_binary
(mp
, p
, cc
);
26393 q
= value_node
(p
);
26394 r
= value_node
(cur_exp_node
());
26395 switch
(mp-
>cur_exp.type
) {
26397 mp_add_or_subtract
(mp
, x_part
(q
), x_part
(r
),cc
);
26398 mp_add_or_subtract
(mp
, y_part
(q
), y_part
(r
),cc
);
26400 case mp_color_type
:
26401 mp_add_or_subtract
(mp
, red_part
(q
), red_part
(r
),cc
);
26402 mp_add_or_subtract
(mp
, green_part
(q
), green_part
(r
),cc
);
26403 mp_add_or_subtract
(mp
, blue_part
(q
), blue_part
(r
),cc
);
26405 case mp_cmykcolor_type
:
26406 mp_add_or_subtract
(mp
, cyan_part
(q
), cyan_part
(r
),cc
);
26407 mp_add_or_subtract
(mp
, magenta_part
(q
), magenta_part
(r
),cc
);
26408 mp_add_or_subtract
(mp
, yellow_part
(q
), yellow_part
(r
),cc
);
26409 mp_add_or_subtract
(mp
, black_part
(q
), black_part
(r
),cc
);
26411 case mp_transform_type
:
26412 mp_add_or_subtract
(mp
, tx_part
(q
), tx_part
(r
),cc
);
26413 mp_add_or_subtract
(mp
, ty_part
(q
), ty_part
(r
),cc
);
26414 mp_add_or_subtract
(mp
, xx_part
(q
), xx_part
(r
),cc
);
26415 mp_add_or_subtract
(mp
, xy_part
(q
), xy_part
(r
),cc
);
26416 mp_add_or_subtract
(mp
, yx_part
(q
), yx_part
(r
),cc
);
26417 mp_add_or_subtract
(mp
, yy_part
(q
), yy_part
(r
),cc
);
26419 default
: /* there are no other valid cases
, but please the compiler
*/
26427 case mp_less_or_equal
:
26428 case mp_greater_than
:
26429 case mp_greater_or_equal
:
26431 case mp_unequal_to
:
26432 check_arith
(); /* at this point |arith_error| should be |false|?
*/
26433 if
((mp-
>cur_exp.type
> mp_pair_type
) && (mp_type (p) > mp_pair_type)) {
26434 mp_add_or_subtract
(mp
, p
, NULL, mp_minus
); /* |cur_exp
:=(p
)-cur_exp|
*/
26435 } else if
(mp-
>cur_exp.type
!= mp_type
(p
)) {
26436 mp_bad_binary
(mp
, p
, (quarterword
) c
);
26438 } else if
(mp-
>cur_exp.type
== mp_string_type
) {
26439 memset
(&new_expr,0,sizeof(mp_value));
26440 new_number
(new_expr.data.n
);
26441 set_number_from_scaled
(new_expr.data.n
, mp_str_vs_str
(mp
, value_str
(p
), cur_exp_str
()));
26442 mp_flush_cur_exp
(mp
, new_expr
);
26443 } else if
((mp-
>cur_exp.type
== mp_unknown_string
) ||
26444 (mp-
>cur_exp.type
== mp_unknown_boolean
)) {
26445 /* Check if unknowns have been equated
*/
26446 /* When two unknown strings are in the same ring
, we know that they are
26447 equal. Otherwise
, we don't know whether they are equal or not
, so we
26449 q
= value_node
(cur_exp_node
());
26450 while
((q
!= cur_exp_node
()) && (q != p))
26451 q
= value_node
(q
);
26453 memset
(&new_expr,0,sizeof(mp_value));
26454 new_number
(new_expr.data.n
);
26455 set_cur_exp_node
(NULL);
26456 mp_flush_cur_exp
(mp
, new_expr
);
26459 } else if
((mp-
>cur_exp.type
<= mp_pair_type
)
26460 && (mp->cur_exp.type >= mp_transform_type)) {
26461 /* Reduce comparison of big nodes to comparison of scalars
*/
26462 /* In the following
, the |while| loops exist just so that |break| can be used
,
26463 each loop runs exactly once.
*/
26464 quarterword part_type
;
26465 q
= value_node
(p
);
26466 r
= value_node
(cur_exp_node
());
26468 switch
(mp-
>cur_exp.type
) {
26470 while
(part_type
==0) {
26472 part_type
= mp_x_part
;
26473 mp_add_or_subtract
(mp
, x_part
(q
), rr
, mp_minus
);
26474 if
(mp_type
(rr
) != mp_known ||
! number_zero
(value_number
(rr
)))
26477 part_type
= mp_y_part
;
26478 mp_add_or_subtract
(mp
, y_part
(q
), rr
, mp_minus
);
26479 if
(mp_type
(rr
) != mp_known ||
!number_zero
(value_number
(rr
)))
26482 mp_take_part
(mp
, part_type
);
26484 case mp_color_type
:
26485 while
(part_type
==0) {
26487 part_type
= mp_red_part
;
26488 mp_add_or_subtract
(mp
, red_part
(q
), rr
, mp_minus
);
26489 if
(mp_type
(rr
) != mp_known ||
! number_zero
(value_number
(rr
)))
26491 rr
= green_part
(r
);
26492 part_type
= mp_green_part
;
26493 mp_add_or_subtract
(mp
, green_part
(q
), rr
, mp_minus
);
26494 if
(mp_type
(rr
) != mp_known ||
!number_zero
(value_number
(rr
)))
26496 rr
= blue_part
(r
);
26497 part_type
= mp_blue_part
;
26498 mp_add_or_subtract
(mp
, blue_part
(q
), rr
, mp_minus
);
26499 if
(mp_type
(rr
) != mp_known ||
!number_zero
(value_number
(rr
)))
26502 mp_take_part
(mp
, part_type
);
26504 case mp_cmykcolor_type
:
26505 while
(part_type
==0) {
26506 rr
= cyan_part
(r
);
26507 part_type
= mp_cyan_part
;
26508 mp_add_or_subtract
(mp
, cyan_part
(q
), rr
, mp_minus
);
26509 if
(mp_type
(rr
) != mp_known ||
!number_zero
(value_number
(rr
)))
26511 rr
= magenta_part
(r
);
26512 part_type
= mp_magenta_part
;
26513 mp_add_or_subtract
(mp
, magenta_part
(q
), rr
, mp_minus
);
26514 if
(mp_type
(rr
) != mp_known ||
!number_zero
(value_number
(rr
)))
26516 rr
= yellow_part
(r
);
26517 part_type
= mp_yellow_part
;
26518 mp_add_or_subtract
(mp
, yellow_part
(q
), rr
, mp_minus
);
26519 if
(mp_type
(rr
) != mp_known ||
!number_zero
(value_number
(rr
)))
26521 rr
= black_part
(r
);
26522 part_type
= mp_black_part
;
26523 mp_add_or_subtract
(mp
, black_part
(q
), rr
, mp_minus
);
26524 if
(mp_type
(rr
) != mp_known ||
!number_zero
(value_number
(rr
)))
26527 mp_take_part
(mp
, part_type
);
26529 case mp_transform_type
:
26530 while
(part_type
==0) {
26532 part_type
= mp_x_part
;
26533 mp_add_or_subtract
(mp
, tx_part
(q
), rr
, mp_minus
);
26534 if
(mp_type
(rr
) != mp_known ||
!number_zero
(value_number
(rr
)))
26537 part_type
= mp_y_part
;
26538 mp_add_or_subtract
(mp
, ty_part
(q
), rr
, mp_minus
);
26539 if
(mp_type
(rr
) != mp_known ||
!number_zero
(value_number
(rr
)))
26542 part_type
= mp_xx_part
;
26543 mp_add_or_subtract
(mp
, xx_part
(q
), rr
, mp_minus
);
26544 if
(mp_type
(rr
) != mp_known ||
!number_zero
(value_number
(rr
)))
26547 part_type
= mp_xy_part
;
26548 mp_add_or_subtract
(mp
, xy_part
(q
), rr
, mp_minus
);
26549 if
(mp_type
(rr
) != mp_known ||
!number_zero
(value_number
(rr
)))
26552 part_type
= mp_yx_part
;
26553 mp_add_or_subtract
(mp
, yx_part
(q
), rr
, mp_minus
);
26554 if
(mp_type
(rr
) != mp_known ||
!number_zero
(value_number
(rr
)))
26557 part_type
= mp_yy_part
;
26558 mp_add_or_subtract
(mp
, yy_part
(q
), rr
, mp_minus
);
26559 if
(mp_type
(rr
) != mp_known ||
!number_zero
(value_number
(rr
)))
26562 mp_take_part
(mp
, part_type
);
26565 assert
(0); /* todo
: |mp-
>cur_exp.type
>mp_transform_node_type| ?
*/
26569 } else if
(mp-
>cur_exp.type
== mp_boolean_type
) {
26570 memset
(&new_expr,0,sizeof(mp_value));
26571 new_number
(new_expr.data.n
);
26572 set_number_from_boolean
(new_expr.data.n
, number_to_scaled
(cur_exp_value_number
()) -
26573 number_to_scaled
(value_number
(p
)));
26574 mp_flush_cur_exp
(mp
, new_expr
);
26576 mp_bad_binary
(mp
, p
, (quarterword
) c
);
26579 /* Compare the current expression with zero
*/
26580 if
(mp-
>cur_exp.type
!= mp_known
) {
26581 const char
*hlp
[] = {
26582 "Oh dear. I can\'t decide if the expression above is positive,",
26583 "negative, or zero. So this comparison test won't be `true'.",
26585 if
(mp-
>cur_exp.type
< mp_known
) {
26586 mp_disp_err
(mp
, p
);
26587 hlp
[0] = "The quantities shown above have not been equated.";
26590 mp_disp_err
(mp
, NULL);
26591 memset
(&new_expr,0,sizeof(mp_value));
26592 new_number
(new_expr.data.n
);
26593 set_number_from_boolean
(new_expr.data.n
, mp_false_code
);
26594 mp_back_error
(mp
,"Unknown relation will be considered false", hlp
, true
);
26595 @.Unknown relation...@
>;
26596 mp_get_x_next
(mp
);
26597 mp_flush_cur_exp
(mp
, new_expr
);
26601 boolean_reset
(number_negative
(cur_exp_value_number
()));
26603 case mp_less_or_equal
:
26604 boolean_reset
(number_nonpositive
(cur_exp_value_number
()));
26606 case mp_greater_than
:
26607 boolean_reset
(number_positive
(cur_exp_value_number
()));
26609 case mp_greater_or_equal
:
26610 boolean_reset
(number_nonnegative
(cur_exp_value_number
()));
26613 boolean_reset
(number_zero
(cur_exp_value_number
()));
26615 case mp_unequal_to
:
26616 boolean_reset
(number_nonzero
(cur_exp_value_number
()));
26618 }; /* there are no other cases
*/
26620 mp-
>cur_exp.type
= mp_boolean_type
;
26622 mp-
>arith_error
= false
; /* ignore overflow in comparisons
*/
26626 /* Here we use the sneaky fact that |and_op-false_code
=or_op-true_code|
*/
26627 if
((mp_type
(p
) != mp_boolean_type
) ||
(mp-
>cur_exp.type
!= mp_boolean_type
))
26628 mp_bad_binary
(mp
, p
, (quarterword
) c
);
26629 else if
(number_to_boolean
(p-
>data.n
) == c
+ mp_false_code
- mp_and_op
) {
26630 set_cur_exp_value_boolean
(number_to_boolean
(p-
>data.n
));
26634 if
((mp-
>cur_exp.type
< mp_color_type
) ||
(mp_type
(p
) < mp_color_type
)) {
26635 mp_bad_binary
(mp
, p
, mp_times
);
26636 } else if
((mp-
>cur_exp.type
== mp_known
) ||
(mp_type
(p
) == mp_known
)) {
26637 /* Multiply when at least one operand is known
*/
26640 if
(mp_type
(p
) == mp_known
) {
26641 number_clone
(vv
, value_number
(p
));
26642 mp_free_value_node
(mp
, p
);
26644 number_clone
(vv
, cur_exp_value_number
());
26645 mp_unstash_cur_exp
(mp
, p
);
26647 if
(mp-
>cur_exp.type
== mp_known
) {
26650 take_scaled
(ret
, cur_exp_value_number
(), vv
);
26651 set_cur_exp_value_number
(ret
);
26653 } else if
(mp-
>cur_exp.type
== mp_pair_type
) {
26654 mp_dep_mult
(mp
, (mp_value_node
) x_part
(value_node
(cur_exp_node
())), vv
, true
);
26655 mp_dep_mult
(mp
, (mp_value_node
) y_part
(value_node
(cur_exp_node
())), vv
, true
);
26656 } else if
(mp-
>cur_exp.type
== mp_color_type
) {
26657 mp_dep_mult
(mp
, (mp_value_node
) red_part
(value_node
(cur_exp_node
())), vv
, true
);
26658 mp_dep_mult
(mp
, (mp_value_node
) green_part
(value_node
(cur_exp_node
())), vv
, true
);
26659 mp_dep_mult
(mp
, (mp_value_node
) blue_part
(value_node
(cur_exp_node
())), vv
, true
);
26660 } else if
(mp-
>cur_exp.type
== mp_cmykcolor_type
) {
26661 mp_dep_mult
(mp
, (mp_value_node
) cyan_part
(value_node
(cur_exp_node
())), vv
, true
);
26662 mp_dep_mult
(mp
, (mp_value_node
) magenta_part
(value_node
(cur_exp_node
())), vv
, true
);
26663 mp_dep_mult
(mp
, (mp_value_node
) yellow_part
(value_node
(cur_exp_node
())), vv
, true
);
26664 mp_dep_mult
(mp
, (mp_value_node
) black_part
(value_node
(cur_exp_node
())), vv
, true
);
26666 mp_dep_mult
(mp
, NULL, vv
, true
);
26671 } else if
((mp_nice_color_or_pair
(mp
, p
, mp_type
(p
))
26672 && (mp->cur_exp.type > mp_pair_type))
26673 ||
(mp_nice_color_or_pair
(mp
, cur_exp_node
(), mp-
>cur_exp.type
)
26674 && (mp_type (p) > mp_pair_type))) {
26675 mp_hard_times
(mp
, p
);
26678 mp_bad_binary
(mp
, p
, mp_times
);
26682 if
((mp-
>cur_exp.type
!= mp_known
) ||
(mp_type
(p
) < mp_color_type
)) {
26683 mp_bad_binary
(mp
, p
, mp_over
);
26687 number_clone
(v_n
, cur_exp_value_number
());
26688 mp_unstash_cur_exp
(mp
, p
);
26689 if
(number_zero
(v_n
)) {
26690 /* Squeal about division by zero
*/
26691 const char
*hlp
[] = {
26692 "You're trying to divide the quantity shown above the error",
26693 "message by zero. I'm going to divide it by one instead.",
26695 mp_disp_err
(mp
, NULL);
26696 mp_back_error
(mp
, "Division by zero", hlp
, true
);
26697 mp_get_x_next
(mp
);
26700 if
(mp-
>cur_exp.type
== mp_known
) {
26703 make_scaled
(ret
, cur_exp_value_number
(), v_n
);
26704 set_cur_exp_value_number
(ret
);
26706 } else if
(mp-
>cur_exp.type
== mp_pair_type
) {
26707 mp_dep_div
(mp
, (mp_value_node
) x_part
(value_node
(cur_exp_node
())),
26709 mp_dep_div
(mp
, (mp_value_node
) y_part
(value_node
(cur_exp_node
())),
26711 } else if
(mp-
>cur_exp.type
== mp_color_type
) {
26713 (mp_value_node
) red_part
(value_node
(cur_exp_node
())),
26716 (mp_value_node
) green_part
(value_node
(cur_exp_node
())),
26719 (mp_value_node
) blue_part
(value_node
(cur_exp_node
())),
26721 } else if
(mp-
>cur_exp.type
== mp_cmykcolor_type
) {
26723 (mp_value_node
) cyan_part
(value_node
(cur_exp_node
())),
26725 mp_dep_div
(mp
, (mp_value_node
)
26726 magenta_part
(value_node
(cur_exp_node
())), v_n
);
26727 mp_dep_div
(mp
, (mp_value_node
)
26728 yellow_part
(value_node
(cur_exp_node
())), v_n
);
26730 (mp_value_node
) black_part
(value_node
(cur_exp_node
())),
26733 mp_dep_div
(mp
, NULL, v_n
);
26740 case mp_pythag_add
:
26741 case mp_pythag_sub
:
26742 if
((mp-
>cur_exp.type
== mp_known
) && (mp_type (p) == mp_known)) {
26745 if
(c
== mp_pythag_add
) {
26746 pyth_add
(r
, value_number
(p
), cur_exp_value_number
());
26748 pyth_sub
(r
, value_number
(p
), cur_exp_value_number
());
26750 set_cur_exp_value_number
(r
);
26753 mp_bad_binary
(mp
, p
, (quarterword
) c
);
26755 case mp_rotated_by
:
26756 case mp_slanted_by
:
26758 case mp_shifted_by
:
26759 case mp_transformed_by
:
26763 /* The next few sections of the program deal with affine transformations
26764 of coordinate data.
*/
26765 if
(mp_type
(p
) == mp_path_type
) {
26766 path_trans
((quarterword
) c
, p
);
26768 } else if
(mp_type
(p
) == mp_pen_type
) {
26769 pen_trans
((quarterword
) c
, p
);
26770 set_cur_exp_knot
(mp_convex_hull
(mp
, cur_exp_knot
()));
26771 /* rounding error could destroy convexity
*/
26773 } else if
((mp_type
(p
) == mp_pair_type
) ||
(mp_type
(p
) == mp_transform_type
)) {
26774 mp_big_trans
(mp
, p
, (quarterword
) c
);
26775 } else if
(mp_type
(p
) == mp_picture_type
) {
26776 mp_do_edges_trans
(mp
, p
, (quarterword
) c
);
26779 mp_bad_binary
(mp
, p
, (quarterword
) c
);
26782 case mp_concatenate
:
26783 if
((mp-
>cur_exp.type
== mp_string_type
) && (mp_type (p) == mp_string_type)) {
26784 mp_string str
= mp_cat
(mp
, value_str
(p
), cur_exp_str
());
26785 delete_str_ref
(cur_exp_str
()) ;
26786 set_cur_exp_str
(str
);
26788 mp_bad_binary
(mp
, p
, mp_concatenate
);
26790 case mp_substring_of
:
26791 if
(mp_nice_pair
(mp
, p
, mp_type
(p
)) && (mp->cur_exp.type == mp_string_type)) {
26792 mp_string str
= mp_chop_string
(mp
,
26794 round_unscaled
(value_number
(x_part
(value_node
(p
)))),
26795 round_unscaled
(value_number
(y_part
(value_node
(p
)))));
26796 delete_str_ref
(cur_exp_str
()) ;
26797 set_cur_exp_str
(str
);
26799 mp_bad_binary
(mp
, p
, mp_substring_of
);
26801 case mp_subpath_of
:
26802 if
(mp-
>cur_exp.type
== mp_pair_type
)
26803 mp_pair_to_path
(mp
);
26804 if
(mp_nice_pair
(mp
, p
, mp_type
(p
)) && (mp->cur_exp.type == mp_path_type))
26805 mp_chop_path
(mp
, value_node
(p
));
26807 mp_bad_binary
(mp
, p
, mp_subpath_of
);
26810 case mp_precontrol_of
:
26811 case mp_postcontrol_of
:
26812 if
(mp-
>cur_exp.type
== mp_pair_type
)
26813 mp_pair_to_path
(mp
);
26814 if
((mp-
>cur_exp.type
== mp_path_type
) && (mp_type (p) == mp_known))
26815 mp_find_point
(mp
, value_number
(p
), (quarterword
) c
);
26817 mp_bad_binary
(mp
, p
, (quarterword
) c
);
26819 case mp_pen_offset_of
:
26820 if
((mp-
>cur_exp.type
== mp_pen_type
) && mp_nice_pair (mp, p, mp_type (p)))
26821 mp_set_up_offset
(mp
, value_node
(p
));
26823 mp_bad_binary
(mp
, p
, mp_pen_offset_of
);
26825 case mp_direction_time_of
:
26826 if
(mp-
>cur_exp.type
== mp_pair_type
)
26827 mp_pair_to_path
(mp
);
26828 if
((mp-
>cur_exp.type
== mp_path_type
) && mp_nice_pair (mp, p, mp_type (p)))
26829 mp_set_up_direction_time
(mp
, value_node
(p
));
26831 mp_bad_binary
(mp
, p
, mp_direction_time_of
);
26833 case mp_envelope_of
:
26834 if
((mp_type
(p
) != mp_pen_type
) ||
(mp-
>cur_exp.type
!= mp_path_type
))
26835 mp_bad_binary
(mp
, p
, mp_envelope_of
);
26837 mp_set_up_envelope
(mp
, p
);
26839 case mp_glyph_infont
:
26840 if
((mp_type
(p
) != mp_string_type
&&
26841 mp_type
(p
) != mp_known
) ||
(mp-
>cur_exp.type
!= mp_string_type
))
26842 mp_bad_binary
(mp
, p
, mp_glyph_infont
);
26844 mp_set_up_glyph_infont
(mp
, p
);
26846 case mp_arc_time_of
:
26847 if
(mp-
>cur_exp.type
== mp_pair_type
)
26848 mp_pair_to_path
(mp
);
26849 if
((mp-
>cur_exp.type
== mp_path_type
) && (mp_type (p) == mp_known)) {
26850 memset
(&new_expr,0,sizeof(mp_value));
26851 new_number
(new_expr.data.n
);
26852 mp_get_arc_time
(mp
, &new_expr.data.n, cur_exp_knot (), value_number (p));
26853 mp_flush_cur_exp
(mp
, new_expr
);
26855 mp_bad_binary
(mp
, p
, (quarterword
) c
);
26859 if
(mp_type
(p
) == mp_pair_type
) {
26860 q
= mp_stash_cur_exp
(mp
);
26861 mp_unstash_cur_exp
(mp
, p
);
26862 mp_pair_to_path
(mp
);
26863 p
= mp_stash_cur_exp
(mp
);
26864 mp_unstash_cur_exp
(mp
, q
);
26866 if
(mp-
>cur_exp.type
== mp_pair_type
)
26867 mp_pair_to_path
(mp
);
26868 if
((mp-
>cur_exp.type
== mp_path_type
) && (mp_type (p) == mp_path_type)) {
26869 mp_number arg1
, arg2
;
26872 mp_path_intersection
(mp
, value_knot
(p
), cur_exp_knot
());
26873 number_clone
(arg1
, mp-
>cur_t
);
26874 number_clone
(arg2
, mp-
>cur_tt
);
26875 mp_pair_value
(mp
, arg1
, arg2
);
26876 free_number
(arg1
);
26877 free_number
(arg2
);
26879 mp_bad_binary
(mp
, p
, mp_intersect
);
26883 if
((mp-
>cur_exp.type
!= mp_string_type
) || mp_type
(p
) != mp_string_type
) {
26884 mp_bad_binary
(mp
, p
, mp_in_font
);
26886 mp_do_infont
(mp
, p
);
26890 } /* there are no other cases
*/
26891 mp_recycle_value
(mp
, p
);
26892 mp_free_value_node
(mp
, p
); /* |return| to avoid this
*/
26893 mp_finish_binary
(mp
, old_p
, old_exp
);
26897 @ @
<Declare binary action...@
>=
26898 static void mp_bad_binary
(MP mp
, mp_node p
, quarterword c
) {
26901 int old_setting
= mp-
>selector
;
26902 const char
*hlp
[] = {
26903 "I'm afraid I don't know how to apply that operation to that",
26904 "combination of types. Continue, and I'll return the second",
26905 "argument (see above) as the result of the operation.",
26907 mp-
>selector
= new_string
;
26908 if
(c
>= mp_min_of
)
26909 mp_print_op
(mp
, c
);
26910 mp_print_known_or_unknown_type
(mp
, mp_type
(p
), p
);
26911 if
(c
>= mp_min_of
)
26912 mp_print
(mp
, "of");
26914 mp_print_op
(mp
, c
);
26915 mp_print_known_or_unknown_type
(mp
, mp-
>cur_exp.type
, cur_exp_node
());
26916 sname
= mp_make_string
(mp
);
26917 mp-
>selector
= old_setting
;
26918 mp_snprintf
(msg
, 256, "Not implemented: %s", mp_str
(mp
, sname
));
26919 @.Not implemented...@
>;
26920 delete_str_ref
(sname
);
26921 mp_disp_err
(mp
, p
);
26922 mp_disp_err
(mp
, NULL);
26923 mp_back_error
(mp
, msg
, hlp
, true
);
26924 mp_get_x_next
(mp
);
26926 static void mp_bad_envelope_pen
(MP mp
) {
26927 const char
*hlp
[] = {
26928 "I'm afraid I don't know how to apply that operation to that",
26929 "combination of types. Continue, and I'll return the second",
26930 "argument (see above) as the result of the operation.",
26932 mp_disp_err
(mp
, NULL);
26933 mp_disp_err
(mp
, NULL);
26934 mp_back_error
(mp
, "Not implemented: envelope(elliptical pen)of(path)", hlp
, true
);
26935 @.Not implemented...@
>;
26936 mp_get_x_next
(mp
);
26939 @ @
<Declare binary action...@
>=
26940 static mp_node mp_tarnished
(MP mp
, mp_node p
) {
26941 mp_node q
; /* beginning of the big node
*/
26942 mp_node r
; /* moving value node pointer
*/
26944 q
= value_node
(p
);
26945 switch
(mp_type
(p
)) {
26948 if
(mp_type
(r
) == mp_independent
)
26951 if
(mp_type
(r
) == mp_independent
)
26954 case mp_color_type
:
26956 if
(mp_type
(r
) == mp_independent
)
26958 r
= green_part
(q
);
26959 if
(mp_type
(r
) == mp_independent
)
26962 if
(mp_type
(r
) == mp_independent
)
26965 case mp_cmykcolor_type
:
26967 if
(mp_type
(r
) == mp_independent
)
26969 r
= magenta_part
(q
);
26970 if
(mp_type
(r
) == mp_independent
)
26972 r
= yellow_part
(q
);
26973 if
(mp_type
(r
) == mp_independent
)
26975 r
= black_part
(q
);
26976 if
(mp_type
(r
) == mp_independent
)
26979 case mp_transform_type
:
26981 if
(mp_type
(r
) == mp_independent
)
26984 if
(mp_type
(r
) == mp_independent
)
26987 if
(mp_type
(r
) == mp_independent
)
26990 if
(mp_type
(r
) == mp_independent
)
26993 if
(mp_type
(r
) == mp_independent
)
26996 if
(mp_type
(r
) == mp_independent
)
26999 default
: /* there are no other valid cases
, but please the compiler
*/
27005 @ The first argument to |add_or_subtract| is the location of a value node
27006 in a capsule or pair node that will soon be recycled. The second argument
27007 is either a location within a pair or transform node of |cur_exp|
,
27008 or it is
NULL (which means that |cur_exp| itself should be the second
27009 argument
). The third argument is either |plus| or |minus|.
27011 The sum or difference of the numeric quantities will replace the second
27012 operand. Arithmetic overflow may go undetected
; users aren't supposed to
27013 be monkeying around with really big values.
27014 @^overflow in arithmetic@
>
27016 @
<Declare binary action...@
>=
27017 @
<Declare the procedure called |dep_finish|@
>;
27018 static void mp_add_or_subtract
(MP mp
, mp_node p
, mp_node q
, quarterword c
) {
27019 mp_variable_type s
, t
; /* operand types
*/
27020 mp_value_node r
; /* dependency list traverser
*/
27021 mp_value_node v
= NULL; /* second operand value for dep lists
*/
27022 mp_number vv
; /* second operand value for known values
*/
27025 t
= mp-
>cur_exp.type
;
27026 if
(t
< mp_dependent
)
27027 number_clone
(vv
, cur_exp_value_number
());
27029 v
= (mp_value_node
) dep_list
((mp_value_node
) cur_exp_node
());
27032 if
(t
< mp_dependent
)
27033 number_clone
(vv
, value_number
(q
));
27035 v
= (mp_value_node
) dep_list
((mp_value_node
) q
);
27037 if
(t
== mp_known
) {
27038 mp_value_node qq
= (mp_value_node
) q
;
27040 number_negate
(vv
);
27041 if
(mp_type
(p
) == mp_known
) {
27042 slow_add
(vv
, value_number
(p
), vv
);
27044 set_cur_exp_value_number
(vv
);
27046 set_value_number
(q
, vv
);
27050 /* Add a known value to the constant term of |dep_list
(p
)|
*/
27051 r
= (mp_value_node
) dep_list
((mp_value_node
) p
);
27052 while
(dep_info
(r
) != NULL)
27053 r
= (mp_value_node
) mp_link
(r
);
27054 slow_add
(vv
, dep_value
(r
), vv
);
27055 set_dep_value
(r
, vv
);
27057 qq
= mp_get_dep_node
(mp
);
27058 set_cur_exp_node
((mp_node
) qq
);
27059 mp-
>cur_exp.type
= mp_type
(p
);
27060 mp_name_type
(qq
) = mp_capsule
;
27061 /* clang
: never read
: |q
= (mp_node
) qq
;|
*/
27063 set_dep_list
(qq
, dep_list
((mp_value_node
) p
));
27064 mp_type
(qq
) = mp_type
(p
);
27065 set_prev_dep
(qq
, prev_dep
((mp_value_node
) p
));
27066 mp_link
(prev_dep
((mp_value_node
) p
)) = (mp_node
) qq
;
27067 mp_type
(p
) = mp_known
; /* this will keep the recycler from collecting non-garbage
*/
27070 mp_negate_dep_list
(mp
, v
);
27071 /* Add operand |p| to the dependency list |v|
*/
27072 /* We prefer |dependent| lists to |mp_proto_dependent| ones
, because it is
27073 nice to retain the extra accuracy of |fraction| coefficients.
27074 But we have to handle both kinds
, and mixtures too.
*/
27075 if
(mp_type
(p
) == mp_known
) {
27076 /* Add the known |value
(p
)| to the constant term of |v|
*/
27077 while
(dep_info
(v
) != NULL) {
27078 v
= (mp_value_node
) mp_link
(v
);
27080 slow_add
(vv
, value_number
(p
), dep_value
(v
));
27081 set_dep_value
(v
, vv
);
27084 r
= (mp_value_node
) dep_list
((mp_value_node
) p
);
27085 if
(t
== mp_dependent
) {
27086 if
(s
== mp_dependent
) {
27087 mp_number ret1
, ret2
;
27088 new_fraction
(ret1
);
27089 new_fraction
(ret2
);
27090 mp_max_coef
(mp
, &ret1, r);
27091 mp_max_coef
(mp
, &ret2, v);
27092 number_add
(ret1
, ret2
);
27093 free_number
(ret2
);
27094 if
(number_less
(ret1
, coef_bound_k
)) {
27095 v
= mp_p_plus_q
(mp
, v
, r
, mp_dependent
);
27096 free_number
(ret1
);
27099 free_number
(ret1
);
27100 } /* |fix_needed| will necessarily be false
*/
27101 t
= mp_proto_dependent
;
27102 v
= mp_p_over_v
(mp
, v
, unity_t
, mp_dependent
, mp_proto_dependent
);
27104 if
(s
== mp_proto_dependent
)
27105 v
= mp_p_plus_q
(mp
, v
, r
, mp_proto_dependent
);
27107 v
= mp_p_plus_fq
(mp
, v
, unity_t
, r
, mp_proto_dependent
, mp_dependent
);
27109 /* Output the answer
, |v|
(which might have become |known|
) */
27111 mp_dep_finish
(mp
, v
, (mp_value_node
) q
, t
);
27113 mp-
>cur_exp.type
= t
;
27114 mp_dep_finish
(mp
, v
, NULL, t
);
27122 @ Here's the current situation
: The dependency list |v| of type |t|
27123 should either be put into the current expression
(if |q
=NULL|
) or
27124 into location |q| within a pair node
(otherwise
). The destination
(|cur_exp|
27125 or |q|
) formerly held a dependency list with the same
27126 final pointer as the list |v|.
27128 @
<Declare the procedure called |dep_finish|@
>=
27129 static void mp_dep_finish
(MP mp
, mp_value_node v
, mp_value_node q
,
27131 mp_value_node p
; /* the destination
*/
27133 p
= (mp_value_node
) cur_exp_node
();
27136 set_dep_list
(p
, v
);
27138 if
(dep_info
(v
) == NULL) {
27139 mp_number vv
; /* the value
, if it is |known|
*/
27141 number_clone
(vv
, value_number
(v
));
27144 memset
(&new_expr,0,sizeof(mp_value));
27145 new_number
(new_expr.data.n
);
27146 number_clone
(new_expr.data.n
, vv
);
27147 mp_flush_cur_exp
(mp
, new_expr
);
27149 mp_recycle_value
(mp
, (mp_node
) p
);
27150 mp_type
(q
) = mp_known
;
27151 set_value_number
(q
, vv
);
27154 } else if
(q
== NULL) {
27155 mp-
>cur_exp.type
= t
;
27157 if
(mp-
>fix_needed
)
27158 mp_fix_dependencies
(mp
);
27161 @ @
<Declare binary action...@
>=
27162 static void mp_dep_mult
(MP mp
, mp_value_node p
, mp_number v
, boolean v_is_scaled
) {
27163 mp_value_node q
; /* the dependency list being multiplied by |v|
*/
27164 quarterword s
, t
; /* its type
, before and after
*/
27166 q
= (mp_value_node
) cur_exp_node
();
27167 } else if
(mp_type
(p
) != mp_known
) {
27171 mp_number r1
, arg1
;
27173 number_clone
(arg1
, dep_value
(p
));
27176 take_scaled
(r1
, arg1
, v
);
27179 take_fraction
(r1
, arg1
, v
);
27181 set_dep_value
(p
, r1
);
27183 free_number
(arg1
);
27188 q
= (mp_value_node
) dep_list
(q
);
27190 if
(t
== mp_dependent
) {
27192 mp_number ab_vs_cd
;
27193 mp_number arg1
, arg2
;
27194 new_number
(ab_vs_cd
);
27196 new_fraction
(arg1
);
27197 mp_max_coef
(mp
, &arg1, q);
27198 number_clone
(arg2
, v
);
27200 ab_vs_cd
(ab_vs_cd
, arg1
, arg2
, coef_bound_minus_1
, unity_t
);
27201 free_number
(arg1
);
27202 free_number
(arg2
);
27203 if
(number_nonnegative
(ab_vs_cd
)) {
27204 t
= mp_proto_dependent
;
27206 free_number
(ab_vs_cd
);
27209 q
= mp_p_times_v
(mp
, q
, v
, s
, t
, v_is_scaled
);
27210 mp_dep_finish
(mp
, q
, p
, t
);
27214 @ Here is a routine that is similar to |times|
; but it is invoked only
27215 internally
, when |v| is a |fraction| whose magnitude is at most~
1,
27216 and when |cur_type
>=mp_color_type|.
27219 static void mp_frac_mult
(MP mp
, mp_number n
, mp_number d
) {
27220 /* multiplies |cur_exp| by |n
/d|
*/
27221 mp_node old_exp
; /* a capsule to recycle
*/
27222 mp_number v
; /* |n
/d|
*/
27224 if
(number_greater
(internal_value
(mp_tracing_commands
), two_t
)) {
27225 @
<Trace the fraction multiplication@
>;
27227 switch
(mp-
>cur_exp.type
) {
27228 case mp_transform_type
:
27229 case mp_color_type
:
27230 case mp_cmykcolor_type
:
27232 old_exp
= mp_tarnished
(mp
, cur_exp_node
());
27234 case mp_independent
:
27241 if
(old_exp
!= NULL) {
27242 old_exp
= cur_exp_node
();
27243 mp_make_exp_copy
(mp
, old_exp
);
27245 make_fraction
(v
, n
, d
);
27246 if
(mp-
>cur_exp.type
== mp_known
) {
27247 mp_number r1
, arg1
;
27250 number_clone
(arg1
, cur_exp_value_number
());
27251 take_fraction
(r1
, arg1
, v
);
27252 set_cur_exp_value_number
(r1
);
27254 free_number
(arg1
);
27255 } else if
(mp-
>cur_exp.type
== mp_pair_type
) {
27256 mp_dep_mult
(mp
, (mp_value_node
) x_part
(value_node
(cur_exp_node
())), v
, false
);
27257 mp_dep_mult
(mp
, (mp_value_node
) y_part
(value_node
(cur_exp_node
())), v
, false
);
27258 } else if
(mp-
>cur_exp.type
== mp_color_type
) {
27259 mp_dep_mult
(mp
, (mp_value_node
) red_part
(value_node
(cur_exp_node
())), v
, false
);
27260 mp_dep_mult
(mp
, (mp_value_node
) green_part
(value_node
(cur_exp_node
())), v
, false
);
27261 mp_dep_mult
(mp
, (mp_value_node
) blue_part
(value_node
(cur_exp_node
())), v
, false
);
27262 } else if
(mp-
>cur_exp.type
== mp_cmykcolor_type
) {
27263 mp_dep_mult
(mp
, (mp_value_node
) cyan_part
(value_node
(cur_exp_node
())), v
, false
);
27264 mp_dep_mult
(mp
, (mp_value_node
) magenta_part
(value_node
(cur_exp_node
())), v
, false
);
27265 mp_dep_mult
(mp
, (mp_value_node
) yellow_part
(value_node
(cur_exp_node
())), v
, false
);
27266 mp_dep_mult
(mp
, (mp_value_node
) black_part
(value_node
(cur_exp_node
())), v
, false
);
27268 mp_dep_mult
(mp
, NULL, v
, false
);
27270 if
(old_exp
!= NULL) {
27271 mp_recycle_value
(mp
, old_exp
);
27272 mp_free_value_node
(mp
, old_exp
);
27278 @ @
<Trace the fraction multiplication@
>=
27280 mp_begin_diagnostic
(mp
);
27281 mp_print_nl
(mp
, "{(");
27283 mp_print_char
(mp
, xord
('
/'
));
27285 mp_print
(mp
, ")*(");
27286 mp_print_exp
(mp
, NULL, 0);
27287 mp_print
(mp
, ")}");
27288 mp_end_diagnostic
(mp
, false
);
27292 @ The |hard_times| routine multiplies a nice color or pair by a dependency list.
27294 @
<Declare binary action procedures@
>=
27295 static void mp_hard_times
(MP mp
, mp_node p
) {
27296 mp_value_node q
; /* a copy of the dependent variable |p|
*/
27297 mp_value_node pp
; /* for typecasting p
*/
27298 mp_node r
; /* a component of the big node for the nice color or pair
*/
27299 mp_number v
; /* the known value for |r|
*/
27301 if
(mp_type
(p
) <= mp_pair_type
) {
27302 q
= (mp_value_node
) mp_stash_cur_exp
(mp
);
27303 mp_unstash_cur_exp
(mp
, p
);
27305 } /* now |cur_type
=mp_pair_type| or |cur_type
=mp_color_type| or |cur_type
=mp_cmykcolor_type|
*/
27306 pp
= (mp_value_node
) p
;
27307 if
(mp-
>cur_exp.type
== mp_pair_type
) {
27308 r
= x_part
(value_node
(cur_exp_node
()));
27309 number_clone
(v
, value_number
(r
));
27310 mp_new_dep
(mp
, r
, mp_type
(pp
),
27311 mp_copy_dep_list
(mp
, (mp_value_node
) dep_list
(pp
)));
27312 mp_dep_mult
(mp
, (mp_value_node
) r
, v
, true
);
27313 r
= y_part
(value_node
(cur_exp_node
()));
27314 number_clone
(v
, value_number
(r
));
27315 mp_new_dep
(mp
, r
, mp_type
(pp
),
27316 mp_copy_dep_list
(mp
, (mp_value_node
) dep_list
(pp
)));
27317 mp_dep_mult
(mp
, (mp_value_node
) r
, v
, true
);
27318 } else if
(mp-
>cur_exp.type
== mp_color_type
) {
27319 r
= red_part
(value_node
(cur_exp_node
()));
27320 number_clone
(v
, value_number
(r
));
27321 mp_new_dep
(mp
, r
, mp_type
(pp
),
27322 mp_copy_dep_list
(mp
, (mp_value_node
) dep_list
(pp
)));
27323 mp_dep_mult
(mp
, (mp_value_node
) r
, v
, true
);
27324 r
= green_part
(value_node
(cur_exp_node
()));
27325 number_clone
(v
, value_number
(r
));
27326 mp_new_dep
(mp
, r
, mp_type
(pp
),
27327 mp_copy_dep_list
(mp
, (mp_value_node
) dep_list
(pp
)));
27328 mp_dep_mult
(mp
, (mp_value_node
) r
, v
, true
);
27329 r
= blue_part
(value_node
(cur_exp_node
()));
27330 number_clone
(v
, value_number
(r
));
27331 mp_new_dep
(mp
, r
, mp_type
(pp
),
27332 mp_copy_dep_list
(mp
, (mp_value_node
) dep_list
(pp
)));
27333 mp_dep_mult
(mp
, (mp_value_node
) r
, v
, true
);
27334 } else if
(mp-
>cur_exp.type
== mp_cmykcolor_type
) {
27335 r
= cyan_part
(value_node
(cur_exp_node
()));
27336 number_clone
(v
, value_number
(r
));
27337 mp_new_dep
(mp
, r
, mp_type
(pp
),
27338 mp_copy_dep_list
(mp
, (mp_value_node
) dep_list
(pp
)));
27339 mp_dep_mult
(mp
, (mp_value_node
) r
, v
, true
);
27340 r
= yellow_part
(value_node
(cur_exp_node
()));
27341 number_clone
(v
, value_number
(r
));
27342 mp_new_dep
(mp
, r
, mp_type
(pp
),
27343 mp_copy_dep_list
(mp
, (mp_value_node
) dep_list
(pp
)));
27344 mp_dep_mult
(mp
, (mp_value_node
) r
, v
, true
);
27345 r
= magenta_part
(value_node
(cur_exp_node
()));
27346 number_clone
(v
, value_number
(r
));
27347 mp_new_dep
(mp
, r
, mp_type
(pp
),
27348 mp_copy_dep_list
(mp
, (mp_value_node
) dep_list
(pp
)));
27349 mp_dep_mult
(mp
, (mp_value_node
) r
, v
, true
);
27350 r
= black_part
(value_node
(cur_exp_node
()));
27351 number_clone
(v
, value_number
(r
));
27352 mp_new_dep
(mp
, r
, mp_type
(pp
),
27353 mp_copy_dep_list
(mp
, (mp_value_node
) dep_list
(pp
)));
27354 mp_dep_mult
(mp
, (mp_value_node
) r
, v
, true
);
27359 @ @
<Declare binary action...@
>=
27360 static void mp_dep_div
(MP mp
, mp_value_node p
, mp_number v
) {
27361 mp_value_node q
; /* the dependency list being divided by |v|
*/
27362 quarterword s
, t
; /* its type
, before and after
*/
27364 q
= (mp_value_node
) cur_exp_node
();
27365 else if
(mp_type
(p
) != mp_known
)
27370 make_scaled
(ret
, value_number
(p
), v
);
27371 set_value_number
(p
, ret
);
27376 q
= (mp_value_node
) dep_list
(q
);
27378 if
(t
== mp_dependent
) {
27379 mp_number ab_vs_cd
;
27380 mp_number arg1
, arg2
;
27381 new_number
(ab_vs_cd
);
27383 new_fraction
(arg1
);
27384 mp_max_coef
(mp
, &arg1, q);
27385 number_clone
(arg2
, v
);
27387 ab_vs_cd
(ab_vs_cd
, arg1
, unity_t
, coef_bound_minus_1
, arg2
);
27388 free_number
(arg1
);
27389 free_number
(arg2
);
27390 if
(number_nonnegative
(ab_vs_cd
)) {
27391 t
= mp_proto_dependent
;
27393 free_number
(ab_vs_cd
);
27395 q
= mp_p_over_v
(mp
, q
, v
, s
, t
);
27396 mp_dep_finish
(mp
, q
, p
, t
);
27399 @ Let |c| be one of the eight transform operators. The procedure call
27400 |set_up_trans
(c
)| first changes |cur_exp| to a transform that corresponds to
27401 |c| and the original value of |cur_exp|.
(In particular
, |cur_exp| doesn't
27402 change at all if |c
=transformed_by|.
)
27404 Then
, if all components of the resulting transform are |known|
, they are
27405 moved to the global variables |txx|
, |txy|
, |tyx|
, |tyy|
, |tx|
, |ty|
;
27406 and |cur_exp| is changed to the known value zero.
27408 @
<Declare binary action...@
>=
27409 static void mp_set_up_trans
(MP mp
, quarterword c
) {
27410 mp_node p
, q
, r
; /* list manipulation registers
*/
27412 memset
(&new_expr,0,sizeof(mp_value));
27413 if
((c
!= mp_transformed_by
) ||
(mp-
>cur_exp.type
!= mp_transform_type
)) {
27414 /* Put the current transform into |cur_exp|
*/
27415 const char
*hlp
[] = {
27416 "The expression shown above has the wrong type,",
27417 "so I can\'t transform anything using it.",
27418 "Proceed, and I'll omit the transformation.",
27420 p
= mp_stash_cur_exp
(mp
);
27421 set_cur_exp_node
(mp_id_transform
(mp
));
27422 mp-
>cur_exp.type
= mp_transform_type
;
27423 q
= value_node
(cur_exp_node
());
27425 @
<For each of the eight cases
, change the relevant fields of |cur_exp|
27427 but do nothing if capsule |p| doesn't have the appropriate type@
>;
27428 }; /* there are no other cases
*/
27429 mp_disp_err
(mp
, p
);
27430 mp_back_error
(mp
, "Improper transformation argument", hlp
, true
);
27431 mp_get_x_next
(mp
);
27433 mp_recycle_value
(mp
, p
);
27434 mp_free_value_node
(mp
, p
);
27437 /* If the current transform is entirely known
, stash it in global variables
;
27438 otherwise |return|
*/
27439 q
= value_node
(cur_exp_node
());
27440 if
(mp_type
(tx_part
(q
)) != mp_known
)
27442 if
(mp_type
(ty_part
(q
)) != mp_known
)
27444 if
(mp_type
(xx_part
(q
)) != mp_known
)
27446 if
(mp_type
(xy_part
(q
)) != mp_known
)
27448 if
(mp_type
(yx_part
(q
)) != mp_known
)
27450 if
(mp_type
(yy_part
(q
)) != mp_known
)
27452 number_clone
(mp-
>txx
, value_number
(xx_part
(q
)));
27453 number_clone
(mp-
>txy
, value_number
(xy_part
(q
)));
27454 number_clone
(mp-
>tyx
, value_number
(yx_part
(q
)));
27455 number_clone
(mp-
>tyy
, value_number
(yy_part
(q
)));
27456 number_clone
(mp-
>tx
, value_number
(tx_part
(q
)));
27457 number_clone
(mp-
>ty
, value_number
(ty_part
(q
)));
27458 new_number
(new_expr.data.n
);
27459 set_number_to_zero
(new_expr.data.n
);
27460 mp_flush_cur_exp
(mp
, new_expr
);
27470 mp_number ty
; /* current transform coefficients
*/
27472 @ @
<Initialize table...@
>=
27473 new_number
(mp-
>txx
);
27474 new_number
(mp-
>txy
);
27475 new_number
(mp-
>tyx
);
27476 new_number
(mp-
>tyy
);
27477 new_number
(mp-
>tx
);
27478 new_number
(mp-
>ty
);
27480 @ @
<Free table...@
>=
27481 free_number
(mp-
>txx
);
27482 free_number
(mp-
>txy
);
27483 free_number
(mp-
>tyx
);
27484 free_number
(mp-
>tyy
);
27485 free_number
(mp-
>tx
);
27486 free_number
(mp-
>ty
);
27489 @ @
<For each of the eight cases...@
>=
27490 case mp_rotated_by
:
27491 if
(mp_type
(p
) == mp_known
)
27492 @
<Install sines and cosines
, then |goto done|@
>;
27494 case mp_slanted_by
:
27495 if
(mp_type
(p
) > mp_pair_type
) {
27496 mp_install
(mp
, xy_part
(q
), p
);
27501 if
(mp_type
(p
) > mp_pair_type
) {
27502 mp_install
(mp
, xx_part
(q
), p
);
27503 mp_install
(mp
, yy_part
(q
), p
);
27507 case mp_shifted_by
:
27508 if
(mp_type
(p
) == mp_pair_type
) {
27509 r
= value_node
(p
);
27510 mp_install
(mp
, tx_part
(q
), x_part
(r
));
27511 mp_install
(mp
, ty_part
(q
), y_part
(r
));
27516 if
(mp_type
(p
) > mp_pair_type
) {
27517 mp_install
(mp
, xx_part
(q
), p
);
27522 if
(mp_type
(p
) > mp_pair_type
) {
27523 mp_install
(mp
, yy_part
(q
), p
);
27528 if
(mp_type
(p
) == mp_pair_type
)
27529 @
<Install a complex multiplier
, then |goto done|@
>;
27531 case mp_transformed_by
:
27535 @ @
<Install sines and cosines
, then |goto done|@
>=
27537 mp_number n_sin
, n_cos
, arg1
, arg2
;
27540 new_fraction
(n_sin
);
27541 new_fraction
(n_cos
); /* results computed by |n_sin_cos|
*/
27542 number_clone
(arg2
, unity_t
);
27543 number_clone
(arg1
, value_number
(p
));
27544 number_multiply_int
(arg2
, 360);
27545 number_modulo
(arg1
, arg2
);
27546 convert_scaled_to_angle
(arg1
);
27547 n_sin_cos
(arg1
, n_cos
, n_sin
);
27548 fraction_to_round_scaled
(n_sin
);
27549 fraction_to_round_scaled
(n_cos
);
27550 set_value_number
(xx_part
(q
), n_cos
);
27551 set_value_number
(yx_part
(q
), n_sin
);
27552 set_value_number
(xy_part
(q
), value_number
(yx_part
(q
)));
27553 number_negate
(value_number
(xy_part
(q
)));
27554 set_value_number
(yy_part
(q
), value_number
(xx_part
(q
)));
27555 free_number
(arg1
);
27556 free_number
(arg2
);
27557 free_number
(n_sin
);
27558 free_number
(n_cos
);
27563 @ @
<Install a complex multiplier
, then |goto done|@
>=
27565 r
= value_node
(p
);
27566 mp_install
(mp
, xx_part
(q
), x_part
(r
));
27567 mp_install
(mp
, yy_part
(q
), x_part
(r
));
27568 mp_install
(mp
, yx_part
(q
), y_part
(r
));
27569 if
(mp_type
(y_part
(r
)) == mp_known
) {
27570 set_value_number
(y_part
(r
), value_number
(y_part
(r
)));
27571 number_negate
(value_number
(y_part
(r
)));
27573 mp_negate_dep_list
(mp
, (mp_value_node
) dep_list
((mp_value_node
)
27576 mp_install
(mp
, xy_part
(q
), y_part
(r
));
27581 @ Procedure |set_up_known_trans| is like |set_up_trans|
, but it
27582 insists that the transformation be entirely known.
27584 @
<Declare binary action...@
>=
27585 static void mp_set_up_known_trans
(MP mp
, quarterword c
) {
27586 mp_set_up_trans
(mp
, c
);
27587 if
(mp-
>cur_exp.type
!= mp_known
) {
27589 const char
*hlp
[] = {
27590 "I'm unable to apply a partially specified transformation",
27591 "except to a fully known pair or transform.",
27592 "Proceed, and I'll omit the transformation.",
27594 memset
(&new_expr,0,sizeof(mp_value));
27595 new_number
(new_expr.data.n
);
27596 mp_disp_err
(mp
, NULL);
27597 set_number_to_zero
(new_expr.data.n
);
27598 mp_back_error
(mp
,"Transform components aren't all known", hlp
, true
);
27599 mp_get_x_next
(mp
);
27600 mp_flush_cur_exp
(mp
, new_expr
);
27601 set_number_to_unity
(mp-
>txx
);
27602 set_number_to_zero
(mp-
>txy
);
27603 set_number_to_zero
(mp-
>tyx
);
27604 set_number_to_unity
(mp-
>tyy
);
27605 set_number_to_zero
(mp-
>tx
);
27606 set_number_to_zero
(mp-
>ty
);
27611 @ Here's a procedure that applies the transform |txx..ty| to a pair of
27612 coordinates in locations |p| and~|q|.
27614 @
<Declare binary action...@
>=
27615 static void mp_number_trans
(MP mp
, mp_number
*p
, mp_number
*q
) {
27616 mp_number r1
, r2
, v
;
27620 take_scaled
(r1
, *p
, mp-
>txx
);
27621 take_scaled
(r2
, *q
, mp-
>txy
);
27622 number_add
(r1
, r2
);
27623 set_number_from_addition
(v
, r1
, mp-
>tx
);
27624 take_scaled
(r1
, *p
, mp-
>tyx
);
27625 take_scaled
(r2
, *q
, mp-
>tyy
);
27626 number_add
(r1
, r2
);
27627 set_number_from_addition
(*q
, r1
, mp-
>ty
);
27628 number_clone
(*p
,v
);
27635 @ The simplest transformation procedure applies a transform to all
27636 coordinates of a path. The |path_trans
(c
)(p
)| macro applies
27637 a transformation defined by |cur_exp| and the transform operator |c|
27640 @d path_trans
(A
,B
) { mp_set_up_known_trans
(mp
, (A
));
27641 mp_unstash_cur_exp
(mp
, (B
));
27642 mp_do_path_trans
(mp
, cur_exp_knot
()); }
27644 @
<Declare binary action...@
>=
27645 static void mp_do_path_trans
(MP mp
, mp_knot p
) {
27646 mp_knot q
; /* list traverser
*/
27649 if
(mp_left_type
(q
) != mp_endpoint
)
27650 mp_number_trans
(mp
, &q->left_x, &q->left_y);
27651 mp_number_trans
(mp
, &q->x_coord, &q->y_coord);
27652 if
(mp_right_type
(q
) != mp_endpoint
)
27653 mp_number_trans
(mp
, &q->right_x, &q->right_y);
27654 q
= mp_next_knot
(q
);
27659 @ Transforming a pen is very similar
, except that there are no |mp_left_type|
27660 and |mp_right_type| fields.
27662 @d pen_trans
(A
,B
) { mp_set_up_known_trans
(mp
, (A
));
27663 mp_unstash_cur_exp
(mp
, (B
));
27664 mp_do_pen_trans
(mp
, cur_exp_knot
()); }
27666 @
<Declare binary action...@
>=
27667 static void mp_do_pen_trans
(MP mp
, mp_knot p
) {
27668 mp_knot q
; /* list traverser
*/
27669 if
(pen_is_elliptical
(p
)) {
27670 mp_number_trans
(mp
, &p->left_x, &p->left_y);
27671 mp_number_trans
(mp
, &p->right_x, &p->right_y);
27675 mp_number_trans
(mp
, &q->x_coord, &q->y_coord);
27676 q
= mp_next_knot
(q
);
27681 @ The next transformation procedure applies to edge structures. It will do
27682 any transformation
, but the results may be substandard if the picture contains
27683 text that uses downloaded bitmap fonts. The binary action procedure is
27684 |do_edges_trans|
, but we also need a function that just scales a picture.
27685 That routine is |scale_edges|. Both it and the underlying routine |edges_trans|
27686 should be thought of as procedures that update an edge structure |h|
, except
27687 that they have to return a
(possibly new
) structure because of the need to call
27690 @
<Declare binary action...@
>=
27691 static mp_edge_header_node mp_edges_trans
(MP mp
, mp_edge_header_node h
) {
27692 mp_node q
; /* the object being transformed
*/
27693 mp_dash_node r
, s
; /* for list manipulation
*/
27694 mp_number sx
, sy
; /* saved transformation parameters
*/
27695 mp_number sqdet
; /* square root of determinant for |dash_scale|
*/
27696 mp_number sgndet
; /* sign of the determinant
*/
27697 h
= mp_private_edges
(mp
, h
);
27701 new_number
(sgndet
);
27702 mp_sqrt_det
(mp
, &sqdet, mp->txx, mp->txy, mp->tyx, mp->tyy);
27703 ab_vs_cd
(sgndet
, mp-
>txx
, mp-
>tyy
, mp-
>txy
, mp-
>tyx
);
27704 if
(dash_list
(h
) != mp-
>null_dash
) {
27705 @
<Try to transform the dash list of |h|@
>;
27707 @
<Make the bounding box of |h| unknown if it can't be updated properly
27708 without scanning the whole structure@
>;
27709 q
= mp_link
(edge_list
(h
));
27710 while
(q
!= NULL) {
27711 @
<Transform graphical object |q|@
>;
27716 free_number
(sqdet
);
27717 free_number
(sgndet
);
27720 static void mp_do_edges_trans
(MP mp
, mp_node p
, quarterword c
) {
27721 mp_set_up_known_trans
(mp
, c
);
27722 set_value_node
(p
, (mp_node
)mp_edges_trans
(mp
, (mp_edge_header_node
)value_node
(p
)));
27723 mp_unstash_cur_exp
(mp
, p
);
27725 static mp_edge_header_node mp_scale_edges
(MP mp
, mp_number se_sf
, mp_edge_header_node se_pic
) {
27726 number_clone
(mp-
>txx
, se_sf
);
27727 number_clone
(mp-
>tyy
, se_sf
);
27728 set_number_to_zero
(mp-
>txy
);
27729 set_number_to_zero
(mp-
>tyx
);
27730 set_number_to_zero
(mp-
>tx
);
27731 set_number_to_zero
(mp-
>ty
);
27732 return mp_edges_trans
(mp
, se_pic
);
27736 @ @
<Try to transform the dash list of |h|@
>=
27737 if
(number_nonzero
(mp-
>txy
) || number_nonzero
(mp-
>tyx
) ||
27738 number_nonzero
(mp-
>ty
) || number_nonequalabs
(mp-
>txx
, mp-
>tyy
)) {
27739 mp_flush_dash_list
(mp
, h
);
27741 mp_number abs_tyy
, ret
;
27742 new_number
(abs_tyy
);
27743 if
(number_negative
(mp-
>txx
)) {
27744 @
<Reverse the dash list of |h|@
>;
27746 @
<Scale the dash list by |txx| and shift it by |tx|@
>;
27747 number_clone
(abs_tyy
, mp-
>tyy
);
27748 number_abs
(abs_tyy
);
27750 take_scaled
(ret
, h-
>dash_y
, abs_tyy
);
27751 number_clone
(h-
>dash_y
, ret
);
27753 free_number
(abs_tyy
);
27757 @ @
<Reverse the dash list of |h|@
>=
27760 set_dash_list
(h
, mp-
>null_dash
);
27761 while
(r
!= mp-
>null_dash
) {
27763 r
= (mp_dash_node
)mp_link
(r
);
27764 number_swap
(s-
>start_x
, s-
>stop_x
);
27765 mp_link
(s
) = (mp_node
)dash_list
(h
);
27766 set_dash_list
(h
, s
);
27771 @ @
<Scale the dash list by |txx| and shift it by |tx|@
>=
27776 while
(r
!= mp-
>null_dash
) {
27777 take_scaled
(arg1
, r-
>start_x
, mp-
>txx
);
27778 set_number_from_addition
(r-
>start_x
, arg1
, mp-
>tx
);
27779 take_scaled
(arg1
, r-
>stop_x
, mp-
>txx
);
27780 set_number_from_addition
(r-
>stop_x
, arg1
, mp-
>tx
);
27781 r
= (mp_dash_node
)mp_link
(r
);
27783 free_number
(arg1
);
27787 @ @
<Make the bounding box of |h| unknown if it can't be updated properly...@
>=
27788 if
(number_zero
(mp-
>txx
) && number_zero(mp->tyy)) {
27789 @
<Swap the $x$ and $y$ parameters in the bounding box of |h|@
>;
27790 } else if
(number_nonzero
(mp-
>txy
) || number_nonzero
(mp-
>tyx
)) {
27791 mp_init_bbox
(mp
, h
);
27794 if
(number_lessequal
(h-
>minx
, h-
>maxx
)) {
27795 @
<Scale the bounding box by |txx
+txy| and |tyx
+tyy|
; then shift by
27801 @ @
<Swap the $x$ and $y$ parameters in the bounding box of |h|@
>=
27803 number_swap
(h-
>minx
, h-
>miny
);
27804 number_swap
(h-
>maxx
, h-
>maxy
);
27808 @ The sum ``|txx
+txy|'' is whichever of |txx| or |txy| is nonzero. The other
27811 @
<Scale the bounding box by |txx
+txy| and |tyx
+tyy|
; then shift...@
>=
27813 mp_number tot
, ret
;
27816 set_number_from_addition
(tot
,mp-
>txx
,mp-
>txy
);
27817 take_scaled
(ret
, h-
>minx
, tot
);
27818 set_number_from_addition
(h-
>minx
,ret
, mp-
>tx
);
27819 take_scaled
(ret
, h-
>maxx
, tot
);
27820 set_number_from_addition
(h-
>maxx
,ret
, mp-
>tx
);
27822 set_number_from_addition
(tot
,mp-
>tyx
,mp-
>tyy
);
27823 take_scaled
(ret
, h-
>miny
, tot
);
27824 set_number_from_addition
(h-
>miny
, ret
, mp-
>ty
);
27825 take_scaled
(ret
, h-
>maxy
, tot
);
27826 set_number_from_addition
(h-
>maxy
, ret
, mp-
>ty
);
27828 set_number_from_addition
(tot
, mp-
>txx
, mp-
>txy
);
27829 if
(number_negative
(tot
)) {
27830 number_swap
(h-
>minx
, h-
>maxx
);
27832 set_number_from_addition
(tot
, mp-
>tyx
, mp-
>tyy
);
27833 if
(number_negative
(tot
)) {
27834 number_swap
(h-
>miny
, h-
>maxy
);
27841 @ Now we ready for the main task of transforming the graphical objects in edge
27844 @
<Transform graphical object |q|@
>=
27845 switch
(mp_type
(q
)) {
27846 case mp_fill_node_type
:
27848 mp_fill_node qq
= (mp_fill_node
) q
;
27849 mp_do_path_trans
(mp
, mp_path_p
(qq
));
27850 @
<Transform |mp_pen_p
(qq
)|
, making sure polygonal pens stay counter-clockwise@
>;
27853 case mp_stroked_node_type
:
27855 mp_stroked_node qq
= (mp_stroked_node
) q
;
27856 mp_do_path_trans
(mp
, mp_path_p
(qq
));
27857 @
<Transform |mp_pen_p
(qq
)|
, making sure polygonal pens stay counter-clockwise@
>;
27860 case mp_start_clip_node_type
:
27861 mp_do_path_trans
(mp
, mp_path_p
((mp_start_clip_node
) q
));
27863 case mp_start_bounds_node_type
:
27864 mp_do_path_trans
(mp
, mp_path_p
((mp_start_bounds_node
) q
));
27866 case mp_text_node_type
:
27867 @
<Transform the compact transformation@
>;
27869 case mp_stop_clip_node_type
:
27870 case mp_stop_bounds_node_type
:
27872 default
: /* there are no other valid cases
, but please the compiler
*/
27877 @ Note that the shift parameters |
(tx
,ty
)| apply only to the path being stroked.
27878 The |dash_scale| has to be adjusted to scale the dash lengths in |mp_dash_p
(q
)|
27879 since the \ps\ output procedures will try to compensate for the transformation
27880 we are applying to |mp_pen_p
(q
)|. Since this compensation is based on the square
27881 root of the determinant
, |sqdet| is the appropriate factor.
27883 We pass the mptrap test only if |dash_scale| is not adjusted
, nowadays
27884 (backend is changed?
)
27886 @
<Transform |mp_pen_p
(qq
)|
, making sure...@
>=
27887 if
(mp_pen_p
(qq
) != NULL) {
27888 number_clone
(sx
, mp-
>tx
);
27889 number_clone
(sy
, mp-
>ty
);
27890 set_number_to_zero
(mp-
>tx
);
27891 set_number_to_zero
(mp-
>ty
);
27892 mp_do_pen_trans
(mp
, mp_pen_p
(qq
));
27893 if
(number_nonzero
(sqdet
)
27894 && ((mp_type (q) == mp_stroked_node_type) && (mp_dash_p (q) != NULL))) {
27897 take_scaled
(ret
, ((mp_stroked_node
)q
)->dash_scale
, sqdet
);
27898 number_clone
(((mp_stroked_node
)q
)->dash_scale
, ret
);
27901 if
(!pen_is_elliptical
(mp_pen_p
(qq
)))
27902 if
(number_negative
(sgndet
))
27903 mp_pen_p
(qq
) = mp_make_pen
(mp
, mp_copy_path
(mp
, mp_pen_p
(qq
)), true
);
27904 /* this unreverses the pen
*/
27905 number_clone
(mp-
>tx
, sx
);
27906 number_clone
(mp-
>ty
, sy
);
27909 @ @
<Transform the compact transformation@
>=
27910 mp_number_trans
(mp
, &((mp_text_node)q)->tx, &((mp_text_node)q)->ty);
27911 number_clone
(sx
, mp-
>tx
);
27912 number_clone
(sy
, mp-
>ty
);
27913 set_number_to_zero
(mp-
>tx
);
27914 set_number_to_zero
(mp-
>ty
);
27915 mp_number_trans
(mp
, &((mp_text_node)q)->txx, &((mp_text_node)q)->tyx);
27916 mp_number_trans
(mp
, &((mp_text_node)q)->txy, &((mp_text_node)q)->tyy);
27917 number_clone
(mp-
>tx
, sx
);
27918 number_clone
(mp-
>ty
, sy
)
27920 @ The hard cases of transformation occur when big nodes are involved
,
27921 and when some of their components are unknown.
27923 @
<Declare binary action...@
>=
27924 @
<Declare subroutines needed by |big_trans|@
>;
27925 static void mp_big_trans
(MP mp
, mp_node p
, quarterword c
) {
27926 mp_node q
, r
, pp
, qq
; /* list manipulation registers
*/
27927 q
= value_node
(p
);
27928 if
(mp_type
(q
) == mp_pair_node_type
) {
27929 if
(mp_type
(x_part
(q
)) != mp_known ||
27930 mp_type
(y_part
(q
)) != mp_known
) {
27931 @
<Transform an unknown big node and |return|@
>;
27933 } else
{ /* |mp_transform_type|
*/
27934 if
(mp_type
(tx_part
(q
)) != mp_known ||
27935 mp_type
(ty_part
(q
)) != mp_known ||
27936 mp_type
(xx_part
(q
)) != mp_known ||
27937 mp_type
(xy_part
(q
)) != mp_known ||
27938 mp_type
(yx_part
(q
)) != mp_known ||
27939 mp_type
(yy_part
(q
)) != mp_known
) {
27940 @
<Transform an unknown big node and |return|@
>;
27943 @
<Transform a known big node@
>;
27944 } /* node |p| will now be recycled by |do_binary|
*/
27947 @ @
<Transform an unknown big node and |return|@
>=
27949 mp_set_up_known_trans
(mp
, c
);
27950 mp_make_exp_copy
(mp
, p
);
27951 r
= value_node
(cur_exp_node
());
27952 if
(mp-
>cur_exp.type
== mp_transform_type
) {
27953 mp_bilin1
(mp
, yy_part
(r
), mp-
>tyy
, xy_part
(q
), mp-
>tyx
, zero_t
);
27954 mp_bilin1
(mp
, yx_part
(r
), mp-
>tyy
, xx_part
(q
), mp-
>tyx
, zero_t
);
27955 mp_bilin1
(mp
, xy_part
(r
), mp-
>txx
, yy_part
(q
), mp-
>txy
, zero_t
);
27956 mp_bilin1
(mp
, xx_part
(r
), mp-
>txx
, yx_part
(q
), mp-
>txy
, zero_t
);
27958 mp_bilin1
(mp
, y_part
(r
), mp-
>tyy
, x_part
(q
), mp-
>tyx
, mp-
>ty
);
27959 mp_bilin1
(mp
, x_part
(r
), mp-
>txx
, y_part
(q
), mp-
>txy
, mp-
>tx
);
27964 @ Let |p| point to a value field inside a big node of |cur_exp|
,
27965 and let |q| point to a another value field. The |bilin1| procedure
27966 replaces |p| by $p\cdot t
+q\cdot u
+\delta$.
27968 @
<Declare subroutines needed by |big_trans|@
>=
27969 static void mp_bilin1
(MP mp
, mp_node p
, mp_number t
, mp_node q
,
27970 mp_number u
, mp_number delta_orig
) {
27972 new_number
(delta
);
27973 number_clone
(delta
, delta_orig
);
27974 if
(!number_equal
(t
, unity_t
)) {
27975 mp_dep_mult
(mp
, (mp_value_node
) p
, t
, true
);
27977 if
(number_nonzero
(u
)) {
27978 if
(mp_type
(q
) == mp_known
) {
27981 take_scaled
(tmp
, value_number
(q
), u
);
27982 number_add
(delta
, tmp
);
27985 /* Ensure that |type
(p
)=mp_proto_dependent|
*/
27986 if
(mp_type
(p
) != mp_proto_dependent
) {
27987 if
(mp_type
(p
) == mp_known
) {
27988 mp_new_dep
(mp
, p
, mp_type
(p
), mp_const_dependency
(mp
, value_number
(p
)));
27990 set_dep_list
((mp_value_node
) p
,
27992 (mp_value_node
) dep_list
((mp_value_node
)
27994 mp_dependent
, mp_proto_dependent
, true
));
27996 mp_type
(p
) = mp_proto_dependent
;
27998 set_dep_list
((mp_value_node
) p
,
28000 (mp_value_node
) dep_list
((mp_value_node
) p
), u
,
28001 (mp_value_node
) dep_list
((mp_value_node
) q
),
28002 mp_proto_dependent
, mp_type
(q
)));
28005 if
(mp_type
(p
) == mp_known
) {
28006 set_value_number
(p
, value_number
(p
));
28007 number_add
(value_number
(p
), delta
);
28010 mp_value_node r
; /* list traverser
*/
28012 r
= (mp_value_node
) dep_list
((mp_value_node
) p
);
28013 while
(dep_info
(r
) != NULL)
28014 r
= (mp_value_node
) mp_link
(r
);
28015 number_clone
(tmp
, value_number
(r
));
28016 number_add
(delta
, tmp
);
28017 if
(r
!= (mp_value_node
) dep_list
((mp_value_node
) p
))
28018 set_value_number
(r
, delta
);
28020 mp_recycle_value
(mp
, p
);
28021 mp_type
(p
) = mp_known
;
28022 set_value_number
(p
, delta
);
28026 if
(mp-
>fix_needed
)
28027 mp_fix_dependencies
(mp
);
28028 free_number
(delta
);
28032 @ @
<Transform a known big node@
>=
28033 mp_set_up_trans
(mp
, c
);
28034 if
(mp-
>cur_exp.type
== mp_known
) {
28035 @
<Transform known by known@
>;
28037 pp
= mp_stash_cur_exp
(mp
);
28038 qq
= value_node
(pp
);
28039 mp_make_exp_copy
(mp
, p
);
28040 r
= value_node
(cur_exp_node
());
28041 if
(mp-
>cur_exp.type
== mp_transform_type
) {
28042 mp_bilin2
(mp
, yy_part
(r
), yy_part
(qq
), value_number
(xy_part
(q
)),
28043 yx_part
(qq
), NULL);
28044 mp_bilin2
(mp
, yx_part
(r
), yy_part
(qq
), value_number
(xx_part
(q
)),
28045 yx_part
(qq
), NULL);
28046 mp_bilin2
(mp
, xy_part
(r
), xx_part
(qq
), value_number
(yy_part
(q
)),
28047 xy_part
(qq
), NULL);
28048 mp_bilin2
(mp
, xx_part
(r
), xx_part
(qq
), value_number
(yx_part
(q
)),
28049 xy_part
(qq
), NULL);
28051 mp_bilin2
(mp
, y_part
(r
), yy_part
(qq
), value_number
(x_part
(q
)),
28052 yx_part
(qq
), y_part
(qq
));
28053 mp_bilin2
(mp
, x_part
(r
), xx_part
(qq
), value_number
(y_part
(q
)),
28054 xy_part
(qq
), x_part
(qq
));
28055 mp_recycle_value
(mp
, pp
);
28056 mp_free_value_node
(mp
, pp
);
28060 @ Let |p| be a |mp_proto_dependent| value whose dependency list ends
28061 at |dep_final|. The following procedure adds |v| times another
28062 numeric quantity to~|p|.
28064 @
<Declare subroutines needed by |big_trans|@
>=
28065 static void mp_add_mult_dep
(MP mp
, mp_value_node p
, mp_number v
, mp_node r
) {
28066 if
(mp_type
(r
) == mp_known
) {
28069 take_scaled
(ret
, value_number
(r
), v
);
28070 set_dep_value
(mp-
>dep_final
, dep_value
(mp-
>dep_final
));
28071 number_add
(dep_value
(mp-
>dep_final
), ret
);
28075 mp_p_plus_fq
(mp
, (mp_value_node
) dep_list
(p
), v
,
28076 (mp_value_node
) dep_list
((mp_value_node
) r
),
28077 mp_proto_dependent
, mp_type
(r
)));
28078 if
(mp-
>fix_needed
)
28079 mp_fix_dependencies
(mp
);
28084 @ The |bilin2| procedure is something like |bilin1|
, but with known
28085 and unknown quantities reversed. Parameter |p| points to a value field
28086 within the big node for |cur_exp|
; and |type
(p
)=mp_known|. Parameters
28087 |t| and~|u| point to value fields elsewhere
; so does parameter~|q|
,
28088 unless it is |
NULL|
(which stands for zero
). Location~|p| will be
28089 replaced by $p\cdot t
+v\cdot u
+q$.
28091 @
<Declare subroutines needed by |big_trans|@
>=
28092 static void mp_bilin2
(MP mp
, mp_node p
, mp_node t
, mp_number v
,
28093 mp_node u
, mp_node q
) {
28094 mp_number vv
; /* temporary storage for |value
(p
)|
*/
28096 number_clone
(vv
, value_number
(p
));
28097 mp_new_dep
(mp
, p
, mp_proto_dependent
, mp_const_dependency
(mp
, zero_t
)); /* this sets |dep_final|
*/
28098 if
(number_nonzero
(vv
)) {
28099 mp_add_mult_dep
(mp
, (mp_value_node
) p
, vv
, t
); /* |dep_final| doesn't change
*/
28101 if
(number_nonzero
(v
)) {
28104 number_clone
(arg1
, v
);
28105 mp_add_mult_dep
(mp
, (mp_value_node
) p
, arg1
, u
);
28106 free_number
(arg1
);
28109 mp_add_mult_dep
(mp
, (mp_value_node
) p
, unity_t
, q
);
28110 if
(dep_list
((mp_value_node
) p
) == (mp_node
) mp-
>dep_final
) {
28111 number_clone
(vv
, dep_value
(mp-
>dep_final
));
28112 mp_recycle_value
(mp
, p
);
28113 mp_type
(p
) = mp_known
;
28114 set_value_number
(p
, vv
);
28120 @ @
<Transform known by known@
>=
28122 mp_make_exp_copy
(mp
, p
);
28123 r
= value_node
(cur_exp_node
());
28124 if
(mp-
>cur_exp.type
== mp_transform_type
) {
28125 mp_bilin3
(mp
, yy_part
(r
), mp-
>tyy
, value_number
(xy_part
(q
)), mp-
>tyx
, zero_t
);
28126 mp_bilin3
(mp
, yx_part
(r
), mp-
>tyy
, value_number
(xx_part
(q
)), mp-
>tyx
, zero_t
);
28127 mp_bilin3
(mp
, xy_part
(r
), mp-
>txx
, value_number
(yy_part
(q
)), mp-
>txy
, zero_t
);
28128 mp_bilin3
(mp
, xx_part
(r
), mp-
>txx
, value_number
(yx_part
(q
)), mp-
>txy
, zero_t
);
28130 mp_bilin3
(mp
, y_part
(r
), mp-
>tyy
, value_number
(x_part
(q
)), mp-
>tyx
, mp-
>ty
);
28131 mp_bilin3
(mp
, x_part
(r
), mp-
>txx
, value_number
(y_part
(q
)), mp-
>txy
, mp-
>tx
);
28135 @ Finally
, in |bilin3| everything is |known|.
28137 @
<Declare subroutines needed by |big_trans|@
>=
28138 static void mp_bilin3
(MP mp
, mp_node p
, mp_number t
,
28139 mp_number v
, mp_number u
, mp_number delta_orig
) {
28143 new_number
(delta
);
28144 number_clone
(delta
, delta_orig
);
28145 if
(!number_equal
(t
, unity_t
)) {
28146 take_scaled
(tmp
, value_number
(p
), t
);
28148 number_clone
(tmp
, value_number
(p
));
28150 number_add
(delta
, tmp
);
28151 if
(number_nonzero
(u
)) {
28154 take_scaled
(ret
, v
, u
);
28155 set_value_number
(p
, delta
);
28156 number_add
(value_number
(p
), ret
);
28159 set_value_number
(p
, delta
);
28161 free_number
(delta
);
28165 @ @
<Declare binary action...@
>=
28166 static void mp_chop_path
(MP mp
, mp_node p
) {
28167 mp_knot q
; /* a knot in the original path
*/
28168 mp_knot pp
, qq
, rr
, ss
; /* link variables for copies of path nodes
*/
28169 mp_number a
, b
; /* indices for chopping
*/
28171 boolean reversed
; /* was |a
>b|?
*/
28175 mp_path_length
(mp
, &l);
28176 number_clone
(a
, value_number
(x_part
(p
)));
28177 number_clone
(b
, value_number
(y_part
(p
)));
28178 if
(number_lessequal
(a
, b
)) {
28182 number_swap
(a
, b
);
28184 /* Dispense with the cases |a
<0| and
/or |b
>l|
*/
28185 if
(number_negative
(a
)) {
28186 if
(mp_left_type
(cur_exp_knot
()) == mp_endpoint
) {
28187 set_number_to_zero
(a
);
28188 if
(number_negative
(b
))
28189 set_number_to_zero
(b
);
28194 } while
(number_negative
(a
)); /* a cycle always has length |l
>0|
*/
28197 if
(number_greater
(b
, l
)) {
28198 if
(mp_left_type
(cur_exp_knot
()) == mp_endpoint
) {
28199 number_clone
(b
, l
);
28200 if
(number_greater
(a
, l
))
28201 number_clone
(a
, l
);
28203 while
(number_greaterequal
(a
, l
)) {
28204 number_substract
(a
, l
);
28205 number_substract
(b
, l
);
28210 q
= cur_exp_knot
();
28211 while
(number_greaterequal
(a
, unity_t
)) {
28212 q
= mp_next_knot
(q
);
28213 number_substract
(a
, unity_t
);
28214 number_substract
(b
, unity_t
);
28216 if
(number_equal
(b
, a
)) {
28217 /* Construct a path from |pp| to |qq| of length zero
*/
28218 if
(number_positive
(a
)) {
28221 number_clone
(arg1
, a
);
28222 convert_scaled_to_fraction
(arg1
);
28223 mp_split_cubic
(mp
, q
, arg1
);
28224 free_number
(arg1
);
28225 q
= mp_next_knot
(q
);
28227 pp
= mp_copy_knot
(mp
, q
);
28231 /* Construct a path from |pp| to |qq| of length $\lceil b\rceil$
*/
28232 pp
= mp_copy_knot
(mp
, q
);
28235 q
= mp_next_knot
(q
);
28237 qq
= mp_copy_knot
(mp
, q
);
28238 mp_next_knot
(rr
) = qq
;
28239 number_substract
(b
, unity_t
);
28240 } while
(number_positive
(b
));
28241 if
(number_positive
(a
)) {
28245 number_clone
(arg1
, a
);
28246 convert_scaled_to_fraction
(arg1
);
28247 mp_split_cubic
(mp
, ss
, arg1
);
28248 free_number
(arg1
);
28249 pp
= mp_next_knot
(ss
);
28250 mp_toss_knot
(mp
, ss
);
28252 mp_number arg1
, arg2
;
28255 set_number_from_substraction
(arg1
, unity_t
, a
);
28256 number_clone
(arg2
, b
);
28257 make_scaled
(b
, arg2
, arg1
);
28258 free_number
(arg1
);
28259 free_number
(arg2
);
28263 if
(number_negative
(b
)) {
28266 set_number_from_addition
(arg1
, b
, unity_t
);
28267 convert_scaled_to_fraction
(arg1
);
28268 mp_split_cubic
(mp
, rr
, arg1
);
28269 free_number
(arg1
);
28270 mp_toss_knot
(mp
, qq
);
28271 qq
= mp_next_knot
(rr
);
28275 mp_left_type
(pp
) = mp_endpoint
;
28276 mp_right_type
(qq
) = mp_endpoint
;
28277 mp_next_knot
(qq
) = pp
;
28278 mp_toss_knot_list
(mp
, cur_exp_knot
());
28280 set_cur_exp_knot
(mp_next_knot
(mp_htap_ypoc
(mp
, pp
)));
28281 mp_toss_knot_list
(mp
, pp
);
28283 set_cur_exp_knot
(pp
);
28291 @ @
<Declare binary action...@
>=
28292 static void mp_set_up_offset
(MP mp
, mp_node p
) {
28293 mp_find_offset
(mp
, value_number
(x_part
(p
)), value_number
(y_part
(p
)),
28295 mp_pair_value
(mp
, mp-
>cur_x
, mp-
>cur_y
);
28297 static void mp_set_up_direction_time
(MP mp
, mp_node p
) {
28299 memset
(&new_expr,0,sizeof(mp_value));
28300 new_number
(new_expr.data.n
);
28301 mp_find_direction_time
(mp
, &new_expr.data.n, value_number (x_part (p)),
28302 value_number
(y_part
(p
)),
28304 mp_flush_cur_exp
(mp
, new_expr
);
28306 static void mp_set_up_envelope
(MP mp
, mp_node p
) {
28307 unsigned char ljoin
, lcap
;
28308 mp_number miterlim
;
28309 mp_knot q
= mp_copy_path
(mp
, cur_exp_knot
()); /* the original path
*/
28310 new_number
(miterlim
);
28311 /* TODO
: accept elliptical pens for straight paths
*/
28312 if
(pen_is_elliptical
(value_knot
(p
))) {
28313 mp_bad_envelope_pen
(mp
);
28314 set_cur_exp_knot
(q
);
28315 mp-
>cur_exp.type
= mp_path_type
;
28318 if
(number_greater
(internal_value
(mp_linejoin
), unity_t
))
28320 else if
(number_positive
(internal_value
(mp_linejoin
)))
28324 if
(number_greater
(internal_value
(mp_linecap
), unity_t
))
28326 else if
(number_positive
(internal_value
(mp_linecap
)))
28330 if
(number_less
(internal_value
(mp_miterlimit
), unity_t
))
28331 set_number_to_unity
(miterlim
);
28333 number_clone
(miterlim
, internal_value
(mp_miterlimit
));
28334 set_cur_exp_knot
(mp_make_envelope
28335 (mp
, q
, value_knot
(p
), ljoin
, lcap
, miterlim
));
28336 mp-
>cur_exp.type
= mp_path_type
;
28340 @ This is pretty straightfoward. The one silly thing is that
28341 the output of |mp_ps_do_font_charstring| has to be un-exported.
28343 @
<Declare binary action...@
>=
28344 static void mp_set_up_glyph_infont
(MP mp
, mp_node p
) {
28345 mp_edge_object
*h
= NULL;
28346 mp_ps_font
*f
= NULL;
28347 char
*n
= mp_str
(mp
, cur_exp_str
());
28348 f
= mp_ps_font_parse
(mp
, (int
) mp_find_font
(mp
, n
));
28350 if
(mp_type
(p
) == mp_known
) {
28351 int v
= round_unscaled
(value_number
(p
));
28352 if
(v
< 0 || v
> 255) {
28354 mp_snprintf
(msg
, 256, "glyph index too high (%d)", v
);
28355 mp_error
(mp
, msg
, NULL, true
);
28357 h
= mp_ps_font_charstring
(mp
, f
, v
);
28360 n
= mp_str
(mp
, value_str
(p
));
28361 h
= mp_ps_do_font_charstring
(mp
, f
, n
);
28363 mp_ps_font_free
(mp
, f
);
28366 set_cur_exp_node
((mp_node
)mp_gr_import
(mp
, h
));
28368 set_cur_exp_node
((mp_node
)mp_get_edge_header_node
(mp
));
28369 mp_init_edges
(mp
, (mp_edge_header_node
)cur_exp_node
());
28371 mp-
>cur_exp.type
= mp_picture_type
;
28375 @ @
<Declare binary action...@
>=
28376 static void mp_find_point
(MP mp
, mp_number v_orig
, quarterword c
) {
28377 mp_knot p
; /* the path
*/
28378 mp_number n
; /* its length
*/
28382 number_clone
(v
, v_orig
);
28383 p
= cur_exp_knot
();
28384 if
(mp_left_type
(p
) == mp_endpoint
) {
28385 set_number_to_unity
(n
);
28388 set_number_to_zero
(n
);
28391 p
= mp_next_knot
(p
);
28392 number_add
(n
, unity_t
);
28393 } while
(p
!= cur_exp_knot
());
28394 if
(number_zero
(n
)) {
28395 set_number_to_zero
(v
);
28396 } else if
(number_negative
(v
)) {
28397 if
(mp_left_type
(p
) == mp_endpoint
) {
28398 set_number_to_zero
(v
);
28400 /* |v
= n
- 1 - ((-v
- 1) % n
)
28401 == - ((-v
- 1) % n
) - 1 + n|
*/
28403 number_add_scaled
(v
, -1);
28404 number_modulo
(v
, n
);
28406 number_add_scaled
(v
, -1);
28409 } else if
(number_greater
(v
, n
)) {
28410 if
(mp_left_type
(p
) == mp_endpoint
)
28411 number_clone
(v
, n
);
28413 number_modulo
(v
, n
);
28415 p
= cur_exp_knot
();
28416 while
(number_greaterequal
(v
, unity_t
)) {
28417 p
= mp_next_knot
(p
);
28418 number_substract
(v
, unity_t
);
28420 if
(number_nonzero
(v
)) {
28421 /* Insert a fractional node by splitting the cubic
*/
28422 convert_scaled_to_fraction
(v
);
28423 mp_split_cubic
(mp
, p
, v
);
28424 p
= mp_next_knot
(p
);
28426 /* Set the current expression to the desired path coordinates
*/
28429 mp_pair_value
(mp
, p-
>x_coord
, p-
>y_coord
);
28431 case mp_precontrol_of
:
28432 if
(mp_left_type
(p
) == mp_endpoint
)
28433 mp_pair_value
(mp
, p-
>x_coord
, p-
>y_coord
);
28435 mp_pair_value
(mp
, p-
>left_x
, p-
>left_y
);
28437 case mp_postcontrol_of
:
28438 if
(mp_right_type
(p
) == mp_endpoint
)
28439 mp_pair_value
(mp
, p-
>x_coord
, p-
>y_coord
);
28441 mp_pair_value
(mp
, p-
>right_x
, p-
>right_y
);
28443 } /* there are no other cases
*/
28448 @ Function |new_text_node| owns the reference count for its second argument
28449 (the text string
) but not its first
(the font name
).
28451 @
<Declare binary action...@
>=
28452 static void mp_do_infont
(MP mp
, mp_node p
) {
28453 mp_edge_header_node q
;
28455 memset
(&new_expr,0,sizeof(mp_value));
28456 new_number
(new_expr.data.n
);
28457 q
= mp_get_edge_header_node
(mp
);
28458 mp_init_edges
(mp
, q
);
28459 add_str_ref
(cur_exp_str
());
28460 mp_link
(obj_tail
(q
)) =
28461 mp_new_text_node
(mp
, mp_str
(mp
, cur_exp_str
()), value_str
(p
));
28462 obj_tail
(q
) = mp_link
(obj_tail
(q
));
28463 mp_free_value_node
(mp
, p
);
28464 new_expr.data.node
= (mp_node
)q
;
28465 mp_flush_cur_exp
(mp
, new_expr
);
28466 mp-
>cur_exp.type
= mp_picture_type
;
28470 @
* Statements and commands.
28471 The chief executive of \MP\ is the |do_statement| routine
, which
28472 contains the master switch that causes all the various pieces of \MP\
28473 to do their things
, in the right order.
28475 In a sense
, this is the grand climax of the program
: It applies all the
28476 tools that we have worked so hard to construct. In another sense
, this is
28477 the messiest part of the program
: It necessarily refers to other pieces
28478 of code all over the place
, so that a person can't fully understand what is
28479 going on without paging back and forth to be reminded of conventions that
28480 are defined elsewhere. We are now at the hub of the web.
28482 The structure of |do_statement| itself is quite simple. The first token
28483 of the statement is fetched using |get_x_next|. If it can be the first
28484 token of an expression
, we look for an equation
, an assignment
, or a
28485 title. Otherwise we use a \
&{case} construction to branch at high speed to
28486 the appropriate routine for various and sundry other types of commands
,
28487 each of which has an ``action procedure'' that does the necessary work.
28489 The program uses the fact that
28490 $$\hbox
{|min_primary_command
=max_statement_command
=type_name|
}$$
28491 to interpret a statement that starts with
, e.g.
, `\
&{string}',
28492 as a type declaration rather than a boolean expression.
28495 static void worry_about_bad_statement
(MP mp
);
28496 static void flush_unparsable_junk_after_statement
(MP mp
);
28497 void mp_do_statement
(MP mp
) { /* governs \MP's activities
*/
28498 mp-
>cur_exp.type
= mp_vacuous
;
28499 mp_get_x_next
(mp
);
28500 if
(cur_cmd
() > mp_max_primary_command
) {
28501 worry_about_bad_statement
(mp
);
28502 } else if
(cur_cmd
() > mp_max_statement_command
) {
28503 /* Do an equation
, assignment
, title
, or
28504 `$\langle\
,$expression$\
,\rangle\
,$\
&{endgroup}'; */
28505 /* The most important statements begin with expressions
*/
28507 mp-
>var_flag
= mp_assignment
;
28508 mp_scan_expression
(mp
);
28509 if
(cur_cmd
() < mp_end_group
) {
28510 if
(cur_cmd
() == mp_equals
)
28511 mp_do_equation
(mp
);
28512 else if
(cur_cmd
() == mp_assignment
)
28513 mp_do_assignment
(mp
);
28514 else if
(mp-
>cur_exp.type
== mp_string_type
) {
28516 if
(number_positive
(internal_value
(mp_tracing_titles
))) {
28517 mp_print_nl
(mp
, "");
28518 mp_print_str
(mp
, cur_exp_str
());
28521 } else if
(mp-
>cur_exp.type
!= mp_vacuous
) {
28522 const char
*hlp
[] = {
28523 "I couldn't find an `=' or `:=' after the",
28524 "expression that is shown above this error message,",
28525 "so I guess I'll just ignore it and carry on.",
28527 mp_disp_err
(mp
, NULL);
28528 mp_back_error
(mp
, "Isolated expression", hlp
, true
);
28529 mp_get_x_next
(mp
);
28531 memset
(&new_expr,0,sizeof(mp_value));
28532 new_number
(new_expr.data.n
);
28533 set_number_to_zero
(new_expr.data.n
);
28534 mp_flush_cur_exp
(mp
, new_expr
);
28535 mp-
>cur_exp.type
= mp_vacuous
;
28538 /* Do a statement that doesn't begin with an expression
*/
28539 /* If |do_statement| ends with |cur_cmd
=end_group|
, we should have
28540 |cur_type
=mp_vacuous| unless the statement was simply an expression
;
28541 in the latter case
, |cur_type| and |cur_exp| should represent that
28543 if
(number_positive
(internal_value
(mp_tracing_commands
)))
28545 switch
(cur_cmd
()) {
28547 mp_do_type_declaration
(mp
);
28550 if
(cur_mod
() > var_def
)
28551 mp_make_op_def
(mp
);
28552 else if
(cur_mod
() > end_def
)
28555 case mp_random_seed
:
28556 mp_do_random_seed
(mp
);
28558 case mp_mode_command
:
28560 mp-
>interaction
= cur_mod
();
28561 initialize_print_selector
();
28562 if
(mp-
>log_opened
)
28563 mp-
>selector
= mp-
>selector
+ 2;
28564 mp_get_x_next
(mp
);
28566 case mp_protection_command
:
28567 mp_do_protection
(mp
);
28569 case mp_delimiters
:
28570 mp_def_delims
(mp
);
28572 case mp_save_command
:
28574 mp_get_symbol
(mp
);
28575 mp_save_variable
(mp
, cur_sym
());
28576 mp_get_x_next
(mp
);
28577 } while
(cur_cmd
() == mp_comma
);
28579 case mp_interim_command
:
28580 mp_do_interim
(mp
);
28582 case mp_let_command
:
28585 case mp_new_internal
:
28586 mp_do_new_internal
(mp
);
28588 case mp_show_command
:
28589 mp_do_show_whatever
(mp
);
28591 case mp_add_to_command
:
28594 case mp_bounds_command
:
28597 case mp_ship_out_command
:
28598 mp_do_ship_out
(mp
);
28600 case mp_every_job_command
:
28601 mp_get_symbol
(mp
);
28602 mp-
>start_sym
= cur_sym
();
28603 mp_get_x_next
(mp
);
28605 case mp_message_command
:
28606 mp_do_message
(mp
);
28608 case mp_write_command
:
28611 case mp_tfm_command
:
28612 mp_do_tfm_command
(mp
);
28614 case mp_special_command
:
28615 if
(cur_mod
() == 0)
28616 mp_do_special
(mp
);
28617 else if
(cur_mod
() == 1)
28618 mp_do_mapfile
(mp
);
28620 mp_do_mapline
(mp
);
28623 break
; /* make the compiler happy
*/
28625 mp-
>cur_exp.type
= mp_vacuous
;
28627 if
(cur_cmd
() < mp_semicolon
)
28628 flush_unparsable_junk_after_statement
(mp
);
28629 mp-
>error_count
= 0;
28633 @ @
<Declarations@
>=
28634 @
<Declare action procedures for use by |do_statement|@
>
28637 @ The only command codes |
>max_primary_command| that can be present
28638 at the beginning of a statement are |semicolon| and higher
; these
28639 occur when the statement is null.
28642 static void worry_about_bad_statement
(MP mp
) {
28643 if
(cur_cmd
() < mp_semicolon
) {
28646 int old_setting
= mp-
>selector
;
28647 const char
*hlp
[] = {
28648 "I was looking for the beginning of a new statement.",
28649 "If you just proceed without changing anything, I'll ignore",
28650 "everything up to the next `;'. Please insert a semicolon",
28651 "now in front of anything that you don't want me to delete.",
28652 "(See Chapter 27 of The METAFONTbook for an example.)",
28654 mp-
>selector
= new_string
;
28655 mp_print_cmd_mod
(mp
, cur_cmd
(), cur_mod
());
28656 sname
= mp_make_string
(mp
);
28657 mp-
>selector
= old_setting
;
28658 mp_snprintf
(msg
, 256, "A statement can't begin with `%s'", mp_str
(mp
, sname
));
28659 delete_str_ref
(sname
);
28660 mp_back_error
(mp
, msg
, hlp
, true
);
28661 mp_get_x_next
(mp
);
28666 @ The help message printed here says that everything is flushed up to
28667 a semicolon
, but actually the commands |end_group| and |stop| will
28668 also terminate a statement.
28671 static void flush_unparsable_junk_after_statement
(MP mp
)
28673 const char
*hlp
[] = {
28674 "I've just read as much of that statement as I could fathom,",
28675 "so a semicolon should have been next. It's very puzzling...",
28676 "but I'll try to get myself back together, by ignoring",
28677 "everything up to the next `;'. Please insert a semicolon",
28678 "now in front of anything that you don't want me to delete.",
28679 "(See Chapter 27 of The METAFONTbook for an example.)",
28681 mp_back_error
(mp
, "Extra tokens will be flushed", hlp
, true
);
28682 mp-
>scanner_status
= flushing
;
28685 if
(cur_cmd
() == mp_string_token
) {
28686 delete_str_ref
(cur_mod_str
());
28688 } while
(!mp_end_of_statement
); /* |cur_cmd
=semicolon|
, |end_group|
, or |stop|
*/
28689 mp-
>scanner_status
= normal
;
28694 @ Equations and assignments are performed by the pair of mutually recursive
28696 routines |do_equation| and |do_assignment|. These routines are called when
28697 |cur_cmd
=equals| and when |cur_cmd
=assignment|
, respectively
; the left-hand
28698 side is in |cur_type| and |cur_exp|
, while the right-hand side is yet
28699 to be scanned. After the routines are finished
, |cur_type| and |cur_exp|
28700 will be equal to the right-hand side
(which will normally be equal
28701 to the left-hand side
).
28704 @
<Declare the procedure called |make_eq|@
>;
28705 static void mp_do_equation
(MP mp
);
28708 static void trace_equation
(MP mp
, mp_node lhs
) {
28709 mp_begin_diagnostic
(mp
);
28710 mp_print_nl
(mp
, "{(");
28711 mp_print_exp
(mp
, lhs
, 0);
28712 mp_print
(mp
, ")=(");
28713 mp_print_exp
(mp
, NULL, 0);
28714 mp_print
(mp
, ")}");
28715 mp_end_diagnostic
(mp
, false
);
28717 void mp_do_equation
(MP mp
) {
28718 mp_node lhs
; /* capsule for the left-hand side
*/
28719 lhs
= mp_stash_cur_exp
(mp
);
28720 mp_get_x_next
(mp
);
28721 mp-
>var_flag
= mp_assignment
;
28722 mp_scan_expression
(mp
);
28723 if
(cur_cmd
() == mp_equals
)
28724 mp_do_equation
(mp
);
28725 else if
(cur_cmd
() == mp_assignment
)
28726 mp_do_assignment
(mp
);
28727 if
(number_greater
(internal_value
(mp_tracing_commands
), two_t
)) {
28728 trace_equation
(mp
, lhs
);
28730 if
(mp-
>cur_exp.type
== mp_unknown_path
) {
28731 if
(mp_type
(lhs
) == mp_pair_type
) {
28732 mp_node p
; /* temporary register
*/
28733 p
= mp_stash_cur_exp
(mp
);
28734 mp_unstash_cur_exp
(mp
, lhs
);
28736 } /* in this case |make_eq| will change the pair to a path
*/
28738 mp_make_eq
(mp
, lhs
); /* equate |lhs| to |
(cur_type
,cur_exp
)|
*/
28742 @ And |do_assignment| is similar to |do_equation|
:
28745 static void mp_do_assignment
(MP mp
);
28748 static void bad_lhs
(MP mp
) {
28749 const char
*hlp
[] = {
28750 "I didn't find a variable name at the left of the `:=',",
28751 "so I'm going to pretend that you said `=' instead.",
28753 mp_disp_err
(mp
, NULL);
28754 mp_error
(mp
, "Improper `:=' will be changed to `='", hlp
, true
);
28755 mp_do_equation
(mp
);
28757 static void bad_internal_assignment
(MP mp
, mp_node lhs
) {
28759 const char
*hlp
[] = {
28760 "I can\'t set this internal quantity to anything but a known",
28761 "numeric value, so I'll have to ignore this assignment.",
28763 mp_disp_err
(mp
, NULL);
28764 if
(internal_type
(mp_sym_info
(lhs
)) == mp_known
) {
28765 mp_snprintf
(msg
, 256, "Internal quantity `%s' must receive a known numeric value",
28766 internal_name
(mp_sym_info
(lhs
)));
28768 mp_snprintf
(msg
, 256, "Internal quantity `%s' must receive a known string",
28769 internal_name
(mp_sym_info
(lhs
)));
28770 hlp
[1] = "string, so I'll have to ignore this assignment.";
28772 mp_back_error
(mp
, msg
, hlp
, true
);
28773 mp_get_x_next
(mp
);
28775 static void forbidden_internal_assignment
(MP mp
, mp_node lhs
) {
28777 const char
*hlp
[] = {
28778 "I can\'t set this internal quantity to anything just yet",
28779 "(it is read-only), so I'll have to ignore this assignment.",
28781 mp_snprintf
(msg
, 256, "Internal quantity `%s' is read-only",
28782 internal_name
(mp_sym_info
(lhs
)));
28783 mp_back_error
(mp
, msg
, hlp
, true
);
28784 mp_get_x_next
(mp
);
28786 static void bad_internal_assignment_precision
(MP mp
, mp_node lhs
, mp_number min
, mp_number max
) {
28789 const char
*hlp
[] = {
28790 "Precision values are limited by the current numbersystem.",
28793 mp_snprintf
(msg
, 256, "Bad '%s' has been ignored", internal_name
(mp_sym_info
(lhs
)));
28794 mp_snprintf
(s
, 256, "Currently I am using '%s'; the allowed precision range is [%s,%s].",
28795 mp_str
(mp
, internal_string
(mp_number_system
)), number_tostring
(min
), number_tostring
(max
));
28797 mp_back_error
(mp
, msg
, hlp
, true
);
28798 mp_get_x_next
(mp
);
28800 static void bad_expression_assignment
(MP mp
, mp_node lhs
) {
28801 const char
*hlp
[] = {
28802 "It seems you did a nasty thing---probably by accident,",
28803 "but nevertheless you nearly hornswoggled me...",
28804 "While I was evaluating the right-hand side of this",
28805 "command, something happened, and the left-hand side",
28806 "is no longer a variable! So I won't change anything.",
28808 char
*msg
= mp_obliterated
(mp
, lhs
);
28809 mp_back_error
(mp
, msg
, hlp
, true
);
28811 mp_get_x_next
(mp
);
28813 static void trace_assignment
(MP mp
, mp_node lhs
) {
28814 mp_begin_diagnostic
(mp
);
28815 mp_print_nl
(mp
, "{");
28816 if
(mp_name_type
(lhs
) == mp_internal_sym
)
28817 mp_print
(mp
, internal_name
(mp_sym_info
(lhs
)));
28819 mp_show_token_list
(mp
, lhs
, NULL, 1000, 0);
28820 mp_print
(mp
, ":=");
28821 mp_print_exp
(mp
, NULL, 0);
28822 mp_print_char
(mp
, xord
('
}'
));
28823 mp_end_diagnostic
(mp
, false
);
28825 void mp_do_assignment
(MP mp
) {
28826 if
(mp-
>cur_exp.type
!= mp_token_list
) {
28829 mp_node lhs
; /* token list for the left-hand side
*/
28830 lhs
= cur_exp_node
();
28831 mp-
>cur_exp.type
= mp_vacuous
;
28832 mp_get_x_next
(mp
);
28833 mp-
>var_flag
= mp_assignment
;
28834 mp_scan_expression
(mp
);
28835 if
(cur_cmd
() == mp_equals
)
28836 mp_do_equation
(mp
);
28837 else if
(cur_cmd
() == mp_assignment
)
28838 mp_do_assignment
(mp
);
28839 if
(number_greater
(internal_value
(mp_tracing_commands
), two_t
)) {
28840 trace_assignment
(mp
, lhs
);
28842 if
(mp_name_type
(lhs
) == mp_internal_sym
) {
28843 /* Assign the current expression to an internal variable
*/
28844 if
((mp-
>cur_exp.type
== mp_known || mp-
>cur_exp.type
== mp_string_type
)
28845 && (internal_type (mp_sym_info (lhs)) == mp->cur_exp.type)) {
28846 if
(mp_sym_info
(lhs
) == mp_number_system
) {
28847 forbidden_internal_assignment
(mp
, lhs
);
28848 } else if
(mp_sym_info
(lhs
) == mp_number_precision
) {
28849 if
(!(mp-
>cur_exp.type
== mp_known
&&
28850 (!number_less
(cur_exp_value_number
(), precision_min
)) &&
28851 (!number_greater
(cur_exp_value_number
(), precision_max
))
28853 bad_internal_assignment_precision
(mp
, lhs
, precision_min
, precision_max
);
28855 set_internal_from_cur_exp
(mp_sym_info
(lhs
));
28859 set_internal_from_cur_exp
(mp_sym_info
(lhs
));
28862 bad_internal_assignment
(mp
, lhs
);
28865 /* Assign the current expression to the variable |lhs|
*/
28866 mp_node p
; /* where the left-hand value is stored
*/
28867 mp_node q
; /* temporary capsule for the right-hand value
*/
28868 p
= mp_find_variable
(mp
, lhs
);
28870 q
= mp_stash_cur_exp
(mp
);
28871 mp-
>cur_exp.type
= mp_und_type
(mp
, p
);
28872 mp_recycle_value
(mp
, p
);
28873 mp_type
(p
) = mp-
>cur_exp.type
;
28874 set_value_number
(p
, zero_t
);
28875 mp_make_exp_copy
(mp
, p
);
28876 p
= mp_stash_cur_exp
(mp
);
28877 mp_unstash_cur_exp
(mp
, q
);
28878 mp_make_eq
(mp
, p
);
28880 bad_expression_assignment
(mp
, lhs
);
28883 mp_flush_node_list
(mp
, lhs
);
28888 @ And now we get to the nitty-gritty. The |make_eq| procedure is given
28889 a pointer to a capsule that is to be equated to the current expression.
28891 @
<Declare the procedure called |make_eq|@
>=
28892 static void mp_make_eq
(MP mp
, mp_node lhs
);
28896 static void announce_bad_equation
(MP mp
, mp_node lhs
) {
28898 const char
*hlp
[] = {
28899 "I'm sorry, but I don't know how to make such things equal.",
28900 "(See the two expressions just above the error message.)",
28902 mp_snprintf
(msg
, 256, "Equation cannot be performed (%s=%s)",
28903 (mp_type
(lhs
) <= mp_pair_type ? mp_type_string
(mp_type
(lhs
)) : "numeric"),
28904 (mp-
>cur_exp.type
<= mp_pair_type ? mp_type_string
(mp-
>cur_exp.type
) : "numeric"));
28905 mp_disp_err
(mp
, lhs
);
28906 mp_disp_err
(mp
, NULL);
28907 mp_back_error
(mp
, msg
, hlp
, true
);
28908 mp_get_x_next
(mp
);
28910 static void exclaim_inconsistent_equation
(MP mp
) {
28911 const char
*hlp
[] = {
28912 "The equation I just read contradicts what was said before.",
28913 "But don't worry; continue and I'll just ignore it.",
28915 mp_back_error
(mp
,"Inconsistent equation", hlp
, true
);
28916 mp_get_x_next
(mp
);
28918 static void exclaim_redundant_or_inconsistent_equation
(MP mp
) {
28919 const char
*hlp
[] = {
28920 "An equation between already-known quantities can't help.",
28921 "But don't worry; continue and I'll just ignore it.",
28923 mp_back_error
(mp
, "Redundant or inconsistent equation", hlp
, true
);
28924 mp_get_x_next
(mp
);
28926 static void report_redundant_or_inconsistent_equation
(MP mp
, mp_node lhs
, mp_number v
) {
28927 if
(mp-
>cur_exp.type
<= mp_string_type
) {
28928 if
(mp-
>cur_exp.type
== mp_string_type
) {
28929 if
(mp_str_vs_str
(mp
, value_str
(lhs
), cur_exp_str
()) != 0) {
28930 exclaim_inconsistent_equation
(mp
);
28932 exclaim_redundant_equation
(mp
);
28934 } else if
(!number_equal
(v
, cur_exp_value_number
())) {
28935 exclaim_inconsistent_equation
(mp
);
28937 exclaim_redundant_equation
(mp
);
28940 exclaim_redundant_or_inconsistent_equation
(mp
);
28944 void mp_make_eq
(MP mp
, mp_node lhs
) {
28946 mp_variable_type t
; /* type of the left-hand side
*/
28947 mp_number v
; /* value of the left-hand side
*/
28948 memset
(&new_expr,0,sizeof(mp_value));
28952 if
(t
<= mp_pair_type
)
28953 number_clone
(v
, value_number
(lhs
));
28954 /* For each type |t|
, make an equation or complain if |cur_type|
28955 is incompatible with~|t|
*/
28957 case mp_boolean_type
:
28958 case mp_string_type
:
28961 case mp_picture_type
:
28962 if
(mp-
>cur_exp.type
== t
+ unknown_tag
) {
28963 new_number
(new_expr.data.n
);
28964 if
(t
==mp_boolean_type
) {
28965 number_clone
(new_expr.data.n
, v
);
28966 } else if
(t
==mp_string_type
) {
28967 new_expr.data.str
= value_str
(lhs
);
28968 } else if
(t
==mp_picture_type
) {
28969 new_expr.data.node
= value_node
(lhs
);
28970 } else
{ /* pen or path
*/
28971 new_expr.data.p
= value_knot
(lhs
);
28973 mp_nonlinear_eq
(mp
, new_expr
, cur_exp_node
(), false
);
28974 mp_unstash_cur_exp
(mp
, cur_exp_node
());
28975 } else if
(mp-
>cur_exp.type
== t
) {
28976 report_redundant_or_inconsistent_equation
(mp
, lhs
, v
);
28978 announce_bad_equation
(mp
, lhs
);
28981 case unknown_types
:
28982 if
(mp-
>cur_exp.type
== t
- unknown_tag
) {
28983 mp_nonlinear_eq
(mp
, mp-
>cur_exp
, lhs
, true
);
28984 } else if
(mp-
>cur_exp.type
== t
) {
28985 mp_ring_merge
(mp
, lhs
, cur_exp_node
());
28986 } else if
(mp-
>cur_exp.type
== mp_pair_type
) {
28987 if
(t
== mp_unknown_path
) {
28988 mp_pair_to_path
(mp
);
28992 announce_bad_equation
(mp
, lhs
);
28995 case mp_transform_type
:
28996 case mp_color_type
:
28997 case mp_cmykcolor_type
:
28999 if
(mp-
>cur_exp.type
== t
) {
29000 /* Do multiple equations
*/
29001 mp_node q
= value_node
(cur_exp_node
());
29002 mp_node p
= value_node
(lhs
);
29004 case mp_transform_type
:
29005 mp_try_eq
(mp
, yy_part
(p
), yy_part
(q
));
29006 mp_try_eq
(mp
, yx_part
(p
), yx_part
(q
));
29007 mp_try_eq
(mp
, xy_part
(p
), xy_part
(q
));
29008 mp_try_eq
(mp
, xx_part
(p
), xx_part
(q
));
29009 mp_try_eq
(mp
, ty_part
(p
), ty_part
(q
));
29010 mp_try_eq
(mp
, tx_part
(p
), tx_part
(q
));
29012 case mp_color_type
:
29013 mp_try_eq
(mp
, blue_part
(p
), blue_part
(q
));
29014 mp_try_eq
(mp
, green_part
(p
), green_part
(q
));
29015 mp_try_eq
(mp
, red_part
(p
), red_part
(q
));
29017 case mp_cmykcolor_type
:
29018 mp_try_eq
(mp
, black_part
(p
), black_part
(q
));
29019 mp_try_eq
(mp
, yellow_part
(p
), yellow_part
(q
));
29020 mp_try_eq
(mp
, magenta_part
(p
), magenta_part
(q
));
29021 mp_try_eq
(mp
, cyan_part
(p
), cyan_part
(q
));
29024 mp_try_eq
(mp
, y_part
(p
), y_part
(q
));
29025 mp_try_eq
(mp
, x_part
(p
), x_part
(q
));
29027 default
: /* there are no other valid cases
, but please the compiler
*/
29031 announce_bad_equation
(mp
, lhs
);
29036 case mp_proto_dependent
:
29037 case mp_independent
:
29038 if
(mp-
>cur_exp.type
>= mp_known
) {
29039 mp_try_eq
(mp
, lhs
, NULL);
29041 announce_bad_equation
(mp
, lhs
);
29045 announce_bad_equation
(mp
, lhs
);
29047 default
: /* there are no other valid cases
, but please the compiler
*/
29048 announce_bad_equation
(mp
, lhs
);
29052 mp_recycle_value
(mp
, lhs
);
29054 mp_free_value_node
(mp
, lhs
);
29057 @ The first argument to |try_eq| is the location of a value node
29058 in a capsule that will soon be recycled. The second argument is
29059 either a location within a pair or transform node pointed to by
29060 |cur_exp|
, or it is |
NULL|
(which means that |cur_exp| itself
29061 serves as the second argument
). The idea is to leave |cur_exp| unchanged
,
29062 but to equate the two operands.
29065 static void mp_try_eq
(MP mp
, mp_node l
, mp_node r
);
29068 @d equation_threshold_k
((math_data
*)mp-
>math
)->equation_threshold_t
29071 static void deal_with_redundant_or_inconsistent_equation
(MP mp
, mp_value_node p
, mp_node r
) {
29074 number_clone
(absp
, value_number
(p
));
29076 if
(number_greater
(absp
, equation_threshold_k
)) { /* off by
.001 or more
*/
29078 const char
*hlp
[] = {
29079 "The equation I just read contradicts what was said before.",
29080 "But don't worry; continue and I'll just ignore it.",
29082 mp_snprintf
(msg
, 256, "Inconsistent equation (off by %s)", number_tostring
(value_number
(p
)));
29083 mp_back_error
(mp
, msg
, hlp
, true
);
29084 mp_get_x_next
(mp
);
29085 } else if
(r
== NULL) {
29086 exclaim_redundant_equation
(mp
);
29088 free_number
(absp
);
29089 mp_free_dep_node
(mp
, p
);
29092 void mp_try_eq
(MP mp
, mp_node l
, mp_node r
) {
29093 mp_value_node p
; /* dependency list for right operand minus left operand
*/
29094 mp_variable_type t
; /* the type of list |p|
*/
29095 mp_value_node q
; /* the constant term of |p| is here
*/
29096 mp_value_node pp
; /* dependency list for right operand
*/
29097 mp_variable_type tt
; /* the type of list |pp|
*/
29098 boolean copied
; /* have we copied a list that ought to be recycled?
*/
29099 /* Remove the left operand from its container
, negate it
, and
29100 put it into dependency list~|p| with constant term~|q|
*/
29102 if
(t
== mp_known
) {
29105 number_clone
(arg1
, value_number
(l
));
29106 number_negate
(arg1
);
29108 p
= mp_const_dependency
(mp
, arg1
);
29110 free_number
(arg1
);
29111 } else if
(t
== mp_independent
) {
29113 p
= mp_single_dependency
(mp
, l
);
29114 number_negate
(dep_value
(p
));
29117 mp_value_node ll
= (mp_value_node
) l
;
29118 p
= (mp_value_node
) dep_list
(ll
);
29121 number_negate
(dep_value
(q
));
29122 if
(dep_info
(q
) == NULL)
29124 q
= (mp_value_node
) mp_link
(q
);
29126 mp_link
(prev_dep
(ll
)) = mp_link
(q
);
29127 set_prev_dep
((mp_value_node
) mp_link
(q
), prev_dep
(ll
));
29128 mp_type
(ll
) = mp_known
;
29131 /* Add the right operand to list |p|
*/
29133 if
(mp-
>cur_exp.type
== mp_known
) {
29134 number_add
(value_number
(q
), cur_exp_value_number
());
29137 tt
= mp-
>cur_exp.type
;
29138 if
(tt
== mp_independent
)
29139 pp
= mp_single_dependency
(mp
, cur_exp_node
());
29141 pp
= (mp_value_node
) dep_list
((mp_value_node
) cur_exp_node
());
29144 if
(mp_type
(r
) == mp_known
) {
29145 number_add
(dep_value
(q
), value_number
(r
));
29149 if
(tt
== mp_independent
)
29150 pp
= mp_single_dependency
(mp
, r
);
29152 pp
= (mp_value_node
) dep_list
((mp_value_node
) r
);
29155 if
(tt
!= mp_independent
) {
29161 /* Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|
*/
29162 mp-
>watch_coefs
= false
;
29164 p
= mp_p_plus_q
(mp
, p
, pp
, (quarterword
) t
);
29165 } else if
(t
== mp_proto_dependent
) {
29166 p
= mp_p_plus_fq
(mp
, p
, unity_t
, pp
, mp_proto_dependent
, mp_dependent
);
29171 while
(dep_info
(q
) != NULL) {
29172 number_clone
(x
, dep_value
(q
));
29173 fraction_to_round_scaled
(x
);
29174 set_dep_value
(q
, x
);
29175 q
= (mp_value_node
) mp_link
(q
);
29178 t
= mp_proto_dependent
;
29179 p
= mp_p_plus_q
(mp
, p
, pp
, (quarterword
) t
);
29181 mp-
>watch_coefs
= true
;
29184 mp_flush_node_list
(mp
, (mp_node
) pp
);
29187 if
(dep_info
(p
) == NULL) {
29188 deal_with_redundant_or_inconsistent_equation
(mp
, p
, r
);
29190 mp_linear_eq
(mp
, p
, (quarterword
) t
);
29191 if
(r
== NULL && mp->cur_exp.type != mp_known) {
29192 if
(mp_type
(cur_exp_node
()) == mp_known
) {
29193 mp_node pp
= cur_exp_node
();
29194 set_cur_exp_value_number
(value_number
(pp
));
29195 mp-
>cur_exp.type
= mp_known
;
29196 mp_free_value_node
(mp
, pp
);
29202 @ Our next goal is to process type declarations. For this purpose it's
29203 convenient to have a procedure that scans a $\langle\
,$declared
29204 variable$\
,\rangle$ and returns the corresponding token list. After the
29205 following procedure has acted
, the token after the declared variable
29206 will have been scanned
, so it will appear in |cur_cmd|
, |cur_mod|
,
29210 static mp_node mp_scan_declared_variable
(MP mp
);
29213 mp_node mp_scan_declared_variable
(MP mp
) {
29214 mp_sym x
; /* hash address of the variable's root
*/
29215 mp_node h
, t
; /* head and tail of the token list to be returned
*/
29216 mp_get_symbol
(mp
);
29218 if
(cur_cmd
() != mp_tag_token
)
29219 mp_clear_symbol
(mp
, x
, false
);
29220 h
= mp_get_symbolic_node
(mp
);
29221 set_mp_sym_sym
(h
, x
);
29224 mp_get_x_next
(mp
);
29225 if
(cur_sym
() == NULL)
29227 if
(cur_cmd
() != mp_tag_token
) {
29228 if
(cur_cmd
() != mp_internal_quantity
) {
29229 if
(cur_cmd
() == mp_left_bracket
) {
29230 /* Descend past a collective subscript
*/
29231 /* If the subscript isn't collective
, we don't accept it as part of the
29232 declared variable.
*/
29233 mp_sym ll
= cur_sym
(); /* hash address of left bracket
*/
29234 mp_get_x_next
(mp
);
29235 if
(cur_cmd
() == mp_right_bracket
) {
29236 set_cur_sym
(collective_subscript
);
29238 mp_back_input
(mp
);
29240 set_cur_cmd
((mp_variable_type
)mp_left_bracket
);
29248 mp_link
(t
) = mp_get_symbolic_node
(mp
);
29250 set_mp_sym_sym
(t
, cur_sym
());
29251 mp_name_type
(t
) = cur_sym_mod
();
29253 if
((eq_type
(x
) % mp_outer_tag
) != mp_tag_token
)
29254 mp_clear_symbol
(mp
, x
, false
);
29255 if
(equiv_node
(x
) == NULL)
29256 mp_new_root
(mp
, x
);
29261 @ Type declarations are introduced by the following primitive operations.
29264 mp_primitive
(mp
, "numeric", mp_type_name
, mp_numeric_type
);
29265 @
:numeric_
}{\
&{numeric} primitive@>;
29266 mp_primitive
(mp
, "string", mp_type_name
, mp_string_type
);
29267 @
:string_
}{\
&{string} primitive@>;
29268 mp_primitive
(mp
, "boolean", mp_type_name
, mp_boolean_type
);
29269 @
:boolean_
}{\
&{boolean} primitive@>;
29270 mp_primitive
(mp
, "path", mp_type_name
, mp_path_type
);
29271 @
:path_
}{\
&{path} primitive@>;
29272 mp_primitive
(mp
, "pen", mp_type_name
, mp_pen_type
);
29273 @
:pen_
}{\
&{pen} primitive@>;
29274 mp_primitive
(mp
, "picture", mp_type_name
, mp_picture_type
);
29275 @
:picture_
}{\
&{picture} primitive@>;
29276 mp_primitive
(mp
, "transform", mp_type_name
, mp_transform_type
);
29277 @
:transform_
}{\
&{transform} primitive@>;
29278 mp_primitive
(mp
, "color", mp_type_name
, mp_color_type
);
29279 @
:color_
}{\
&{color} primitive@>;
29280 mp_primitive
(mp
, "rgbcolor", mp_type_name
, mp_color_type
);
29281 @
:color_
}{\
&{rgbcolor} primitive@>;
29282 mp_primitive
(mp
, "cmykcolor", mp_type_name
, mp_cmykcolor_type
);
29283 @
:color_
}{\
&{cmykcolor} primitive@>;
29284 mp_primitive
(mp
, "pair", mp_type_name
, mp_pair_type
);
29285 @
:pair_
}{\
&{pair} primitive@>
29288 @ @
<Cases of |print_cmd...@
>=
29290 mp_print_type
(mp
, (quarterword
) m
);
29293 @ Now we are ready to handle type declarations
, assuming that a
29294 |type_name| has just been scanned.
29296 @
<Declare action procedures for use by |do_statement|@
>=
29297 static void mp_do_type_declaration
(MP mp
);
29300 static void flush_spurious_symbols_after_declared_variable
(MP mp
);
29301 void mp_do_type_declaration
(MP mp
) {
29302 integer t
; /* the type being declared
*/
29303 mp_node p
; /* token list for a declared variable
*/
29304 mp_node q
; /* value node for the variable
*/
29305 if
(cur_mod
() >= mp_transform_type
)
29306 t
= (quarterword
) cur_mod
();
29308 t
= (quarterword
) (cur_mod
() + unknown_tag
);
29310 p
= mp_scan_declared_variable
(mp
);
29311 mp_flush_variable
(mp
, equiv_node
(mp_sym_sym
(p
)), mp_link
(p
), false
);
29312 q
= mp_find_variable
(mp
, p
);
29315 set_value_number
(q
, zero_t
); /* todo
: this was |null|
*/
29317 const char
*hlp
[] = {
29318 "You can't use, e.g., `numeric foo[]' after `vardef foo'.",
29319 "Proceed, and I'll ignore the illegal redeclaration.",
29321 mp_back_error
(mp
, "Declared variable conflicts with previous vardef", hlp
, true
);
29322 mp_get_x_next
(mp
);
29324 mp_flush_node_list
(mp
, p
);
29325 if
(cur_cmd
() < mp_comma
) {
29326 flush_spurious_symbols_after_declared_variable
(mp
);
29328 } while
(!mp_end_of_statement
);
29334 static void flush_spurious_symbols_after_declared_variable
(MP mp
)
29336 const char
*hlp
[] = {
29337 "Variables in declarations must consist entirely of",
29338 "names and collective subscripts, e.g., `x[]a'.",
29339 "Are you trying to use a reserved word in a variable name?",
29340 "I'm going to discard the junk I found here,",
29341 "up to the next comma or the end of the declaration.",
29343 if
(cur_cmd
() == mp_numeric_token
)
29344 hlp
[2] = "Explicit subscripts like `x15a' aren't permitted.";
29345 mp_back_error
(mp
, "Illegal suffix of declared variable will be flushed", hlp
, true
);
29346 mp_get_x_next
(mp
);
29347 mp-
>scanner_status
= flushing
;
29350 @
<Decrease the string reference count...@
>;
29351 } while
(cur_cmd
() < mp_comma
); /* break on either |end_of_statement| or |comma|
*/
29352 mp-
>scanner_status
= normal
;
29356 @ \MP's |main_control| procedure just calls |do_statement| repeatedly
29357 until coming to the end of the user's program.
29358 Each execution of |do_statement| concludes with
29359 |cur_cmd
=semicolon|
, |end_group|
, or |stop|.
29362 static void mp_main_control
(MP mp
) {
29364 mp_do_statement
(mp
);
29365 if
(cur_cmd
() == mp_end_group
) {
29367 const char
*hlp
[] = {
29368 "I'm not currently working on a `begingroup',",
29369 "so I had better not try to end anything.",
29371 memset
(&new_expr,0,sizeof(mp_value));
29372 new_number
(new_expr.data.n
);
29373 mp_error
(mp
, "Extra `endgroup'", hlp
, true
);
29374 mp_flush_cur_exp
(mp
, new_expr
);
29376 } while
(cur_cmd
() != mp_stop
);
29378 int mp_run
(MP mp
) {
29379 if
(mp-
>history
< mp_fatal_error_stop
) {
29380 xfree
(mp-
>jump_buf
);
29381 mp-
>jump_buf
= malloc
(sizeof
(jmp_buf
));
29382 if
(mp-
>jump_buf
== NULL || setjmp
(*(mp-
>jump_buf
)) != 0)
29383 return mp-
>history
;
29384 mp_main_control
(mp
); /* come to life
*/
29385 mp_final_cleanup
(mp
); /* prepare for death
*/
29386 mp_close_files_and_terminate
(mp
);
29388 return mp-
>history
;
29392 @ This function allows setting of internals from an external
29393 source
(like the command line or a controlling application
).
29395 It accepts two |char
*|'s
, even for numeric assignments when
29396 it calls |atoi| to get an integer from the start of the string.
29399 void mp_set_internal
(MP mp
, char
*n
, char
*v
, int isstring
) {
29400 size_t l
= strlen
(n
);
29402 const char
*errid
= NULL;
29404 mp_sym p
= mp_id_lookup
(mp
, n
, l
, false
);
29406 errid
= "variable does not exist";
29408 if
(eq_type
(p
) == mp_internal_quantity
) {
29409 if
((internal_type
(equiv
(p
)) == mp_string_type
) && (isstring)) {
29410 set_internal_string
(equiv
(p
), mp_rts
(mp
, v
));
29411 } else if
((internal_type
(equiv
(p
)) == mp_known
) && (!isstring)) {
29412 int test
= atoi
(v
);
29413 if
(test
> 16383) {
29414 errid
= "value is too large";
29415 } else if
(test
< -16383) {
29416 errid
= "value is too small";
29418 set_internal_from_number
(equiv
(p
), unity_t
);
29419 number_multiply_int
(internal_value
(equiv
(p
)), test
);
29422 errid
= "value has the wrong type";
29425 errid
= "variable is not an internal";
29429 if
(errid
!= NULL) {
29431 mp_snprintf
(err
, 256, "%s=\"%s\
": %s, assignment ignored.", n
, v
, errid
);
29433 mp_snprintf
(err
, 256, "%s=%d: %s, assignment ignored.", n
, atoi
(v
),
29441 @ @
<Exported function headers@
>=
29442 void mp_set_internal
(MP mp
, char
*n
, char
*v
, int isstring
);
29444 @ For |mp_execute|
, we need to define a structure to store the
29445 redirected input and output. This structure holds the five relevant
29446 streams
: the three informational output streams
, the PostScript
29447 generation stream
, and the input stream. These streams have many
29448 things in common
, so it makes sense to give them their own structure
29451 \item
{fptr
} is a virtual file pointer
29452 \item
{data
} is the data this stream holds
29453 \item
{cur
} is a cursor pointing into |data|
29454 \item
{size
} is the allocated length of the data stream
29455 \item
{used
} is the actual length of the data stream
29457 There are small differences between input and output
: |term_in| never
29458 uses |used|
, whereas the other four never use |cur|.
29460 The file |luatexdir
/tex
/texfileio.h| defines |term_in| as |stdin| and
29461 |term_out| as |stdout|. Moreover |stdio.h| for MinGW defines |stdin| as
29462 |
(&_iob[0])| and |stdout| as |(&_iob[1])|. We must avoid all that.
29464 @
<Exported types@
>=
29476 mp_stream term_out
;
29477 mp_stream error_out
;
29479 mp_stream ship_out
;
29481 struct mp_edge_object
*edges
;
29484 @ We need a function to clear an output stream
, this is called at the
29485 beginning of |mp_execute|. We also need one for destroying an output
29486 stream
, this is called just before a stream is
(re
)opened.
29489 static void mp_reset_stream
(mp_stream
* str
) {
29495 static void mp_free_stream
(mp_stream
* str
) {
29497 mp_reset_stream
(str
);
29501 @ @
<Declarations@
>=
29502 static void mp_reset_stream
(mp_stream
* str
);
29503 static void mp_free_stream
(mp_stream
* str
);
29505 @ The global instance contains a pointer instead of the actual structure
29506 even though it is essentially static
, because that makes it is easier to move
29510 mp_run_data run_data
;
29512 @ Another type is needed
: the indirection will overload some of the
29513 file pointer objects in the instance
(but not all
). For clarity
, an
29514 indirect object is used that wraps a |
FILE *|.
29517 typedef struct File
{
29521 @ Here are all of the functions that need to be overloaded for |mp_execute|.
29524 static void
*mplib_open_file
(MP mp
, const char
*fname
, const char
*fmode
,
29526 static int mplib_get_char
(void
*f
, mp_run_data
* mplib_data
);
29527 static void mplib_unget_char
(void
*f
, mp_run_data
* mplib_data
, int c
);
29528 static char
*mplib_read_ascii_file
(MP mp
, void
*ff
, size_t
* size
);
29529 static void mplib_write_ascii_file
(MP mp
, void
*ff
, const char
*s
);
29530 static void mplib_read_binary_file
(MP mp
, void
*ff
, void
**data
,
29532 static void mplib_write_binary_file
(MP mp
, void
*ff
, void
*s
, size_t size
);
29533 static void mplib_close_file
(MP mp
, void
*ff
);
29534 static int mplib_eof_file
(MP mp
, void
*ff
);
29535 static void mplib_flush_file
(MP mp
, void
*ff
);
29536 static void mplib_shipout_backend
(MP mp
, void
*h
);
29538 @ The |xmalloc
(1,1)| calls make sure the stored indirection values are unique.
29540 @d reset_stream
(a
) do
{
29541 mp_reset_stream
(&(a));
29543 ff-
>f
= xmalloc
(1,1);
29548 static void
*mplib_open_file
(MP mp
, const char
*fname
, const char
*fmode
,
29550 File
*ff
= xmalloc
(1, sizeof
(File
));
29551 mp_run_data
*run
= mp_rundata
(mp
);
29553 if
(ftype
== mp_filetype_terminal
) {
29554 if
(fmode
[0] == 'r'
) {
29556 ff-
>f
= xmalloc
(1, 1);
29557 run-
>term_in.fptr
= ff-
>f
;
29560 reset_stream
(run-
>term_out
);
29562 } else if
(ftype
== mp_filetype_error
) {
29563 reset_stream
(run-
>error_out
);
29564 } else if
(ftype
== mp_filetype_log
) {
29565 reset_stream
(run-
>log_out
);
29566 } else if
(ftype
== mp_filetype_postscript
) {
29567 mp_free_stream
(&(run->ship_out));
29568 ff-
>f
= xmalloc
(1, 1);
29569 run-
>ship_out.fptr
= ff-
>f
;
29570 } else if
(ftype
== mp_filetype_bitmap
) {
29571 mp_free_stream
(&(run->ship_out));
29572 ff-
>f
= xmalloc
(1, 1);
29573 run-
>ship_out.fptr
= ff-
>f
;
29576 char
*f
= (mp-
>find_file
) (mp
, fname
, fmode
, ftype
);
29579 realmode
[0] = *fmode
;
29582 ff-
>f
= fopen
(f
, realmode
);
29584 if
((fmode
[0] == 'r'
) && (ff->f == NULL)) {
29591 static int mplib_get_char
(void
*f
, mp_run_data
* run
) {
29593 if
(f
== run-
>term_in.fptr
&& run->term_in.data != NULL) {
29594 if
(run-
>term_in.size
== 0) {
29595 if
(run-
>term_in.cur
!= NULL) {
29596 run-
>term_in.cur
= NULL;
29598 xfree
(run-
>term_in.data
);
29602 run-
>term_in.size--
;
29603 c
= *(run-
>term_in.cur
)++;
29610 static void mplib_unget_char
(void
*f
, mp_run_data
* run
, int c
) {
29611 if
(f
== run-
>term_in.fptr
&& run->term_in.cur != NULL) {
29612 run-
>term_in.size
++;
29613 run-
>term_in.cur--
;
29618 static char
*mplib_read_ascii_file
(MP mp
, void
*ff
, size_t
* size
) {
29622 size_t len
= 0, lim
= 128;
29623 mp_run_data
*run
= mp_rundata
(mp
);
29624 FILE *f
= ((File
*) ff
)->f
;
29628 c
= mplib_get_char
(f
, run
);
29634 while
(c
!= EOF
&& c != '\n' && c != '\r') {
29635 if
(len
>= (lim
- 1)) {
29636 s
= xrealloc
(s
, (lim
+ (lim
>> 2)), 1);
29641 s
[len
++] = (char
) c
;
29642 c
= mplib_get_char
(f
, run
);
29645 c
= mplib_get_char
(f
, run
);
29646 if
(c
!= EOF
&& c != '\n')
29647 mplib_unget_char
(f
, run
, c
);
29654 static void mp_append_string
(MP mp
, mp_stream
* a
, const char
*b
) {
29655 size_t l
= strlen
(b
) + 1; /* don't forget the trailing |'\
0'|
*/
29656 if
((a-
>used
+ l
) >= a-
>size
) {
29657 a-
>size
+= 256 + (a-
>size
) / 5 + l
;
29658 a-
>data
= xrealloc
(a-
>data
, a-
>size
, 1);
29660 memcpy
(a-
>data
+ a-
>used
, b
, l
);
29663 static void mp_append_data
(MP mp
, mp_stream
* a
, void
*b
, size_t l
) {
29664 if
((a-
>used
+ l
) >= a-
>size
) {
29665 a-
>size
+= 256 + (a-
>size
) / 5 + l
;
29666 a-
>data
= xrealloc
(a-
>data
, a-
>size
, 1);
29668 memcpy
(a-
>data
+ a-
>used
, b
, l
);
29671 static void mplib_write_ascii_file
(MP mp
, void
*ff
, const char
*s
) {
29673 void
*f
= ((File
*) ff
)->f
;
29674 mp_run_data
*run
= mp_rundata
(mp
);
29676 if
(f
== run-
>term_out.fptr
) {
29677 mp_append_string
(mp
, &(run->term_out), s);
29678 } else if
(f
== run-
>error_out.fptr
) {
29679 mp_append_string
(mp
, &(run->error_out), s);
29680 } else if
(f
== run-
>log_out.fptr
) {
29681 mp_append_string
(mp
, &(run->log_out), s);
29682 } else if
(f
== run-
>ship_out.fptr
) {
29683 mp_append_string
(mp
, &(run->ship_out), s);
29685 fprintf
((FILE *) f
, "%s", s
);
29690 static void mplib_read_binary_file
(MP mp
, void
*ff
, void
**data
, size_t
* size
) {
29694 FILE *f
= ((File
*) ff
)->f
;
29696 len
= fread
(*data
, 1, *size
, f
);
29700 static void mplib_write_binary_file
(MP mp
, void
*ff
, void
*s
, size_t size
) {
29703 void
*f
= ((File
*) ff
)->f
;
29704 mp_run_data
*run
= mp_rundata
(mp
);
29706 if
(f
== run-
>ship_out.fptr
) {
29707 mp_append_data
(mp
, &(run->ship_out), s, size);
29709 (void
) fwrite
(s
, size
, 1, f
);
29714 static void mplib_close_file
(MP mp
, void
*ff
) {
29716 mp_run_data
*run
= mp_rundata
(mp
);
29717 void
*f
= ((File
*) ff
)->f
;
29719 if
(f
!= run-
>term_out.fptr
29720 && f != run->error_out.fptr
29721 && f != run->log_out.fptr
29722 && f != run->ship_out.fptr && f != run->term_in.fptr) {
29729 static int mplib_eof_file
(MP mp
, void
*ff
) {
29731 mp_run_data
*run
= mp_rundata
(mp
);
29732 FILE *f
= ((File
*) ff
)->f
;
29735 if
(f
== run-
>term_in.fptr
&& run->term_in.data != NULL) {
29736 return
(run-
>term_in.size
== 0);
29742 static void mplib_flush_file
(MP mp
, void
*ff
) {
29747 static void mplib_shipout_backend
(MP mp
, void
*voidh
) {
29748 mp_edge_header_node h
= (mp_edge_header_node
) voidh
;
29749 mp_edge_object
*hh
= mp_gr_export
(mp
, h
);
29751 mp_run_data
*run
= mp_rundata
(mp
);
29752 if
(run-
>edges
== NULL) {
29755 mp_edge_object
*p
= run-
>edges
;
29756 while
(p-
>next
!= NULL) {
29765 @ This is where we fill them all in.
29766 @
<Prepare function pointers for non-interactive use@
>=
29768 mp-
>open_file
= mplib_open_file
;
29769 mp-
>close_file
= mplib_close_file
;
29770 mp-
>eof_file
= mplib_eof_file
;
29771 mp-
>flush_file
= mplib_flush_file
;
29772 mp-
>write_ascii_file
= mplib_write_ascii_file
;
29773 mp-
>read_ascii_file
= mplib_read_ascii_file
;
29774 mp-
>write_binary_file
= mplib_write_binary_file
;
29775 mp-
>read_binary_file
= mplib_read_binary_file
;
29776 mp-
>shipout_backend
= mplib_shipout_backend
;
29780 @ Perhaps this is the most important API function in the library.
29782 @
<Exported function ...@
>=
29783 extern mp_run_data
*mp_rundata
(MP mp
);
29786 mp_run_data
*mp_rundata
(MP mp
) {
29787 return
&(mp->run_data);
29792 mp_free_stream
(&(mp->run_data.term_in));
29793 mp_free_stream
(&(mp->run_data.term_out));
29794 mp_free_stream
(&(mp->run_data.log_out));
29795 mp_free_stream
(&(mp->run_data.error_out));
29796 mp_free_stream
(&(mp->run_data.ship_out));
29798 @ @
<Finish non-interactive use@
>=
29799 xfree
(mp-
>term_out
);
29800 xfree
(mp-
>term_in
);
29801 xfree
(mp-
>err_out
);
29803 @ @
<Start non-interactive work@
>=
29804 @
<Initialize the output routines@
>;
29806 mp-
>max_in_stack
= file_bottom
;
29807 mp-
>in_open
= file_bottom
;
29808 mp-
>open_parens
= 0;
29809 mp-
>max_buf_stack
= 0;
29811 mp-
>max_param_stack
= 0;
29813 iindex
= file_bottom
;
29814 nloc
= nstart
= NULL;
29818 mp-
>mpx_name
[file_bottom
] = absent
;
29819 mp-
>force_eof
= false
;
29821 mp-
>scanner_status
= normal
;
29822 if
(!mp-
>ini_version
) {
29823 if
(!mp_load_preload_file
(mp
)) {
29824 mp-
>history
= mp_fatal_error_stop
;
29825 return mp-
>history
;
29828 mp_fix_date_and_time
(mp
);
29829 if
(mp-
>random_seed
== 0)
29831 (number_to_scaled
(internal_value
(mp_time
)) / number_to_scaled
(unity_t
)) + number_to_scaled
(internal_value
(mp_day
));
29832 init_randoms
(mp-
>random_seed
);
29833 initialize_print_selector
();
29834 mp_open_log_file
(mp
);
29835 mp_set_job_id
(mp
);
29836 mp_init_map_file
(mp
, mp-
>troff_mode
);
29837 mp-
>history
= mp_spotless
; /* ready to go
! */
29838 if
(mp-
>troff_mode
) {
29839 number_clone
(internal_value
(mp_gtroffmode
), unity_t
);
29840 number_clone
(internal_value
(mp_prologues
), unity_t
);
29842 @
<Fix up |mp-
>internal
[mp_job_name
]|@
>;
29843 if
(mp-
>start_sym
!= NULL) { /* insert the `\
&{everyjob}' symbol */
29844 set_cur_sym
(mp-
>start_sym
);
29845 mp_back_input
(mp
);
29849 int mp_execute
(MP mp
, char
*s
, size_t l
) {
29850 mp_reset_stream
(&(mp->run_data.term_out));
29851 mp_reset_stream
(&(mp->run_data.log_out));
29852 mp_reset_stream
(&(mp->run_data.error_out));
29853 mp_reset_stream
(&(mp->run_data.ship_out));
29854 if
(mp-
>finished
) {
29855 return mp-
>history
;
29856 } else if
(!mp-
>noninteractive
) {
29857 mp-
>history
= mp_fatal_error_stop
;
29858 return mp-
>history
;
29860 if
(mp-
>history
< mp_fatal_error_stop
) {
29861 xfree
(mp-
>jump_buf
);
29862 mp-
>jump_buf
= malloc
(sizeof
(jmp_buf
));
29863 if
(mp-
>jump_buf
== NULL || setjmp
(*(mp-
>jump_buf
)) != 0) {
29864 return mp-
>history
;
29866 if
(s
== NULL) { /* this signals EOF
*/
29867 mp_final_cleanup
(mp
); /* prepare for death
*/
29868 mp_close_files_and_terminate
(mp
);
29869 return mp-
>history
;
29872 mp-
>term_offset
= 0;
29873 mp-
>file_offset
= 0;
29874 /* Perhaps some sort of warning here when |data| is not
29875 * yet exhausted would be nice ... this happens after errors
29877 if
(mp-
>run_data.term_in.data
)
29878 xfree
(mp-
>run_data.term_in.data
);
29879 mp-
>run_data.term_in.data
= xstrdup
(s
);
29880 mp-
>run_data.term_in.cur
= mp-
>run_data.term_in.data
;
29881 mp-
>run_data.term_in.size
= l
;
29882 if
(mp-
>run_state
== 0) {
29883 mp-
>selector
= term_only
;
29884 @
<Start non-interactive work@
>;
29887 (void
) mp_input_ln
(mp
, mp-
>term_in
);
29888 mp_firm_up_the_line
(mp
);
29889 mp-
>buffer
[limit
] = xord
('
%'
);
29890 mp-
>first
= (size_t
) (limit
+ 1);
29893 mp_do_statement
(mp
);
29894 } while
(cur_cmd
() != mp_stop
);
29895 mp_final_cleanup
(mp
);
29896 mp_close_files_and_terminate
(mp
);
29898 return mp-
>history
;
29902 @ This function cleans up
29904 int mp_finish
(MP mp
) {
29906 if
(mp-
>finished || mp-
>history
>= mp_fatal_error_stop
) {
29907 history
= mp-
>history
;
29911 xfree
(mp-
>jump_buf
);
29912 mp-
>jump_buf
= malloc
(sizeof
(jmp_buf
));
29913 if
(mp-
>jump_buf
== NULL || setjmp
(*(mp-
>jump_buf
)) != 0) {
29914 history
= mp-
>history
;
29916 history
= mp-
>history
;
29917 mp_final_cleanup
(mp
); /* prepare for death
*/
29919 mp_close_files_and_terminate
(mp
);
29925 @ People may want to know the library version
29927 char
*mp_metapost_version
(void
) {
29928 return mp_strdup
(metapost_version
);
29930 void mp_show_library_versions
(void
) {
29931 fprintf
(stdout
, "Compiled with cairo %s; using %s\n", CAIRO_VERSION_STRING
, cairo_version_string
());
29932 fprintf
(stdout
, "Compiled with pixman %s; using %s\n", PIXMAN_VERSION_STRING
, pixman_version_string
());
29933 fprintf
(stdout
, "Compiled with libpng %s; using %s\n", PNG_LIBPNG_VER_STRING
, png_libpng_ver
);
29934 fprintf
(stdout
, "Compiled with zlib %s; using %s\n", ZLIB_VERSION
, zlibVersion
());
29935 fprintf
(stdout
, "Compiled with mpfr %s; using %s\n", MPFR_VERSION_STRING
, mpfr_get_version
());
29936 fprintf
(stdout
, "Compiled with gmp %d.%d.%d; using %s\n\n", __GNU_MP_VERSION
, __GNU_MP_VERSION_MINOR
, __GNU_MP_VERSION_PATCHLEVEL
, gmp_version
);
29939 @ @
<Exported function headers@
>=
29940 int mp_run
(MP mp
);
29941 int mp_execute
(MP mp
, char
*s
, size_t l
);
29942 int mp_finish
(MP mp
);
29943 char
*mp_metapost_version
(void
);void mp_show_library_versions
(void
);
29946 mp_primitive
(mp
, "end", mp_stop
, 0);
29947 @
:end_
}{\
&{end} primitive@>;
29948 mp_primitive
(mp
, "dump", mp_stop
, 1);
29949 mp-
>frozen_dump
= mp_frozen_primitive
(mp
, "dump", mp_stop
, 1);
29950 @
:dump_
}{\
&{dump} primitive@>
29953 @ @
<Cases of |print_cmd...@
>=
29955 if
(cur_mod
() == 0)
29956 mp_print
(mp
, "end");
29958 mp_print
(mp
, "dump");
29962 Let's turn now to statements that are classified as ``commands'' because
29963 of their imperative nature. We'll begin with simple ones
, so that it
29964 will be clear how to hook command processing into the |do_statement| routine
;
29965 then we'll tackle the tougher commands.
29967 Here's one of the simplest
:
29969 @ @
<Declare action procedures for use by |do_statement|@
>=
29970 static void mp_do_random_seed
(MP mp
);
29973 void mp_do_random_seed
(MP mp
) {
29975 memset
(&new_expr,0,sizeof(mp_value));
29976 new_number
(new_expr.data.n
);
29977 mp_get_x_next
(mp
);
29978 if
(cur_cmd
() != mp_assignment
) {
29979 const char
*hlp
[] = { "Always say `randomseed:=<numeric expression>'.", NULL };
29980 mp_back_error
(mp
, "Missing `:=' has been inserted", hlp
, true
);
29983 mp_get_x_next
(mp
);
29984 mp_scan_expression
(mp
);
29985 if
(mp-
>cur_exp.type
!= mp_known
) {
29986 const char
*hlp
[] = {
29987 "Your expression was too random for me to handle,",
29988 "so I won't change the random seed just now.",
29990 mp_disp_err
(mp
, NULL);
29991 mp_back_error
(mp
, "Unknown value will be ignored", hlp
, true
);
29992 @.Unknown value...ignored@
>;
29993 mp_get_x_next
(mp
);
29994 mp_flush_cur_exp
(mp
, new_expr
);
29996 @
<Initialize the random seed to |cur_exp|@
>;
30001 @ @
<Initialize the random seed to |cur_exp|@
>=
30003 init_randoms
(number_to_scaled
(cur_exp_value_number
()));
30004 if
(mp-
>selector
>= log_only
&& mp->selector < write_file) {
30005 mp-
>old_setting
= mp-
>selector
;
30006 mp-
>selector
= log_only
;
30007 mp_print_nl
(mp
, "{randomseed:=");
30008 print_number
(cur_exp_value_number
());
30009 mp_print_char
(mp
, xord
('
}'
));
30010 mp_print_nl
(mp
, "");
30011 mp-
>selector
= mp-
>old_setting
;
30016 @ And here's another simple one
(somewhat different in flavor
):
30019 mp_primitive
(mp
, "batchmode", mp_mode_command
, mp_batch_mode
);
30020 @
:mp_batch_mode_
}{\
&{batchmode} primitive@>;
30021 mp_primitive
(mp
, "nonstopmode", mp_mode_command
, mp_nonstop_mode
);
30022 @
:mp_nonstop_mode_
}{\
&{nonstopmode} primitive@>;
30023 mp_primitive
(mp
, "scrollmode", mp_mode_command
, mp_scroll_mode
);
30024 @
:mp_scroll_mode_
}{\
&{scrollmode} primitive@>;
30025 mp_primitive
(mp
, "errorstopmode", mp_mode_command
, mp_error_stop_mode
);
30026 @
:mp_error_stop_mode_
}{\
&{errorstopmode} primitive@>
30029 @ @
<Cases of |print_cmd_mod|...@
>=
30030 case mp_mode_command
:
30032 case mp_batch_mode
:
30033 mp_print
(mp
, "batchmode");
30035 case mp_nonstop_mode
:
30036 mp_print
(mp
, "nonstopmode");
30038 case mp_scroll_mode
:
30039 mp_print
(mp
, "scrollmode");
30042 mp_print
(mp
, "errorstopmode");
30047 @ The `\
&{inner}' and `\&{outer}' commands are only slightly harder.
30050 mp_primitive
(mp
, "inner", mp_protection_command
, 0);
30051 @
:inner_
}{\
&{inner} primitive@>;
30052 mp_primitive
(mp
, "outer", mp_protection_command
, 1);
30053 @
:outer_
}{\
&{outer} primitive@>
30056 @ @
<Cases of |print_cmd...@
>=
30057 case mp_protection_command
:
30059 mp_print
(mp
, "inner");
30061 mp_print
(mp
, "outer");
30064 @ @
<Declare action procedures for use by |do_statement|@
>=
30065 static void mp_do_protection
(MP mp
);
30068 void mp_do_protection
(MP mp
) {
30069 int m
; /* 0 to unprotect
, 1 to protect
*/
30070 halfword t
; /* the |eq_type| before we change it
*/
30073 mp_get_symbol
(mp
);
30074 t
= eq_type
(cur_sym
());
30076 if
(t
>= mp_outer_tag
)
30077 set_eq_type
(cur_sym
(), (t
- mp_outer_tag
));
30078 } else if
(t
< mp_outer_tag
) {
30079 set_eq_type
(cur_sym
(), (t
+ mp_outer_tag
));
30081 mp_get_x_next
(mp
);
30082 } while
(cur_cmd
() == mp_comma
);
30086 @ \MP\ never defines the tokens `\.
(' and `\.
)' to be primitives
, but
30087 plain \MP\ begins with the declaration `\
&{delimiters} \.{()}'. Such a
30088 declaration assigns the command code |left_delimiter| to `\.
{(}' and
30089 |right_delimiter| to `\.
{)}'
; the |equiv| of each delimiter is the
30090 hash address of its mate.
30092 @ @
<Declare action procedures for use by |do_statement|@
>=
30093 static void mp_def_delims
(MP mp
);
30096 void mp_def_delims
(MP mp
) {
30097 mp_sym l_delim
, r_delim
; /* the new delimiter pair
*/
30098 mp_get_clear_symbol
(mp
);
30099 l_delim
= cur_sym
();
30100 mp_get_clear_symbol
(mp
);
30101 r_delim
= cur_sym
();
30102 set_eq_type
(l_delim
, mp_left_delimiter
);
30103 set_equiv_sym
(l_delim
, r_delim
);
30104 set_eq_type
(r_delim
, mp_right_delimiter
);
30105 set_equiv_sym
(r_delim
, l_delim
);
30106 mp_get_x_next
(mp
);
30110 @ Here is a procedure that is called when \MP\ has reached a point
30111 where some right delimiter is mandatory.
30114 static void mp_check_delimiter
(MP mp
, mp_sym l_delim
, mp_sym r_delim
);
30117 void mp_check_delimiter
(MP mp
, mp_sym l_delim
, mp_sym r_delim
) {
30118 if
(cur_cmd
() == mp_right_delimiter
)
30119 if
(equiv_sym
(cur_sym
()) == l_delim
)
30121 if
(cur_sym
() != r_delim
) {
30123 const char
*hlp
[] = {
30124 "I found no right delimiter to match a left one. So I've",
30125 "put one in, behind the scenes; this may fix the problem.",
30127 mp_snprintf
(msg
, 256, "Missing `%s' has been inserted", mp_str
(mp
, text
(r_delim
)));
30129 mp_back_error
(mp
, msg
, hlp
, true
);
30132 const char
*hlp
[] = {
30133 "Strange: This token has lost its former meaning!",
30134 "I'll read it as a right delimiter this time;",
30135 "but watch out, I'll probably miss it later.",
30137 mp_snprintf
(msg
, 256, "The token `%s' is no longer a right delimiter", mp_str
(mp
, text
(r_delim
)));
30138 @.The token...delimiter@
>;
30139 mp_error
(mp
, msg
, hlp
, true
);
30144 @ The next four commands save or change the values associated with tokens.
30146 @ @
<Declare action procedures for use by |do_statement|@
>=
30147 static void mp_do_statement
(MP mp
);
30148 static void mp_do_interim
(MP mp
);
30151 void mp_do_interim
(MP mp
) {
30152 mp_get_x_next
(mp
);
30153 if
(cur_cmd
() != mp_internal_quantity
) {
30155 const char
*hlp
[] = {
30156 "Something like `tracingonline' should follow `interim'.",
30158 mp_snprintf
(msg
, 256, "The token `%s' isn't an internal quantity",
30159 (cur_sym
() == NULL ?
"(%CAPSULE)" : mp_str
(mp
, text
(cur_sym
()))));
30160 @.The token...quantity@
>;
30161 mp_back_error
(mp
, msg
, hlp
, true
);
30163 mp_save_internal
(mp
, cur_mod
());
30164 mp_back_input
(mp
);
30166 mp_do_statement
(mp
);
30170 @ The following procedure is careful not to undefine the left-hand symbol
30171 too soon
, lest commands like `
{\tt let x
=x
}' have a surprising effect.
30173 @
<Declare action procedures for use by |do_statement|@
>=
30174 static void mp_do_let
(MP mp
);
30177 void mp_do_let
(MP mp
) {
30178 mp_sym l
; /* hash location of the left-hand symbol
*/
30179 mp_get_symbol
(mp
);
30181 mp_get_x_next
(mp
);
30182 if
(cur_cmd
() != mp_equals
&& cur_cmd() != mp_assignment) {
30183 const char
*hlp
[] = {
30184 "You should have said `let symbol = something'.",
30185 "But don't worry; I'll pretend that an equals sign",
30186 "was present. The next token I read will be `something'.",
30188 mp_back_error
(mp
, "Missing `=' has been inserted", hlp
, true
);
30191 mp_get_symbol
(mp
);
30192 switch
(cur_cmd
()) {
30193 case mp_defined_macro
:
30194 case mp_secondary_primary_macro
:
30195 case mp_tertiary_secondary_macro
:
30196 case mp_expression_tertiary_macro
:
30197 add_mac_ref
(cur_mod_node
());
30202 mp_clear_symbol
(mp
, l
, false
);
30203 set_eq_type
(l
, cur_cmd
());
30204 if
(cur_cmd
() == mp_tag_token
)
30205 set_equiv
(l
, 0); /* todo
: this was |null|
*/
30206 else if
(cur_cmd
() == mp_defined_macro ||
30207 cur_cmd
() == mp_secondary_primary_macro ||
30208 cur_cmd
() == mp_tertiary_secondary_macro ||
30209 cur_cmd
() == mp_expression_tertiary_macro
)
30210 set_equiv_node
(l
, cur_mod_node
());
30211 else if
(cur_cmd
() == mp_left_delimiter ||
30212 cur_cmd
() == mp_right_delimiter
)
30213 set_equiv_sym
(l
, equiv_sym
(cur_sym
()));
30215 set_equiv
(l
, cur_mod
());
30216 mp_get_x_next
(mp
);
30220 @ @
<Declarations@
>=
30221 static void mp_do_new_internal
(MP mp
);
30223 @ @
<Internal library ...@
>=
30224 void mp_grow_internals
(MP mp
, int l
);
30227 void mp_grow_internals
(MP mp
, int l
) {
30228 mp_internal
*internal
;
30230 if
(l
> max_halfword
) {
30231 mp_confusion
(mp
, "out of memory space"); /* can't be reached
*/
30233 internal
= xmalloc
((l
+ 1), sizeof
(mp_internal
));
30234 for
(k
= 0; k
<= l
; k
++) {
30235 if
(k
<= mp-
>max_internal
) {
30236 memcpy
(internal
+ k
, mp-
>internal
+ k
, sizeof
(mp_internal
));
30238 memset
(internal
+ k
, 0, sizeof
(mp_internal
));
30239 new_number
(((mp_internal
*)(internal
+ k
))->v.data.n
);
30242 xfree
(mp-
>internal
);
30243 mp-
>internal
= internal
;
30244 mp-
>max_internal
= l
;
30246 void mp_do_new_internal
(MP mp
) {
30247 int the_type
= mp_known
;
30248 mp_get_x_next
(mp
);
30249 if
(cur_cmd
() == mp_type_name
&& cur_mod() == mp_string_type) {
30250 the_type
= mp_string_type
;
30252 if
(!(cur_cmd
() == mp_type_name
&& cur_mod() == mp_numeric_type)) {
30253 mp_back_input
(mp
);
30257 if
(mp-
>int_ptr
== mp-
>max_internal
) {
30258 mp_grow_internals
(mp
, (mp-
>max_internal
+ (mp-
>max_internal
/ 4)));
30260 mp_get_clear_symbol
(mp
);
30261 incr
(mp-
>int_ptr
);
30262 set_eq_type
(cur_sym
(), mp_internal_quantity
);
30263 set_equiv
(cur_sym
(), mp-
>int_ptr
);
30264 if
(internal_name
(mp-
>int_ptr
) != NULL)
30265 xfree
(internal_name
(mp-
>int_ptr
));
30266 set_internal_name
(mp-
>int_ptr
,
30267 mp_xstrdup
(mp
, mp_str
(mp
, text
(cur_sym
()))));
30268 if
(the_type
== mp_string_type
) {
30269 set_internal_string
(mp-
>int_ptr
, mp_rts
(mp
,""));
30271 set_number_to_zero
(internal_value
(mp-
>int_ptr
));
30273 set_internal_type
(mp-
>int_ptr
, the_type
);
30274 mp_get_x_next
(mp
);
30275 } while
(cur_cmd
() == mp_comma
);
30279 @ @
<Dealloc variables@
>=
30280 for
(k
= 0; k
<= mp-
>max_internal
; k
++) {
30281 free_number
(mp-
>internal
[k
].v.data.n
);
30282 xfree
(internal_name
(k
));
30284 xfree
(mp-
>internal
);
30287 @ The various `\
&{show}' commands are distinguished by modifier fields
30290 @d show_token_code
0 /* show the meaning of a single token
*/
30291 @d show_stats_code
1 /* show current memory and string usage
*/
30292 @d show_code
2 /* show a list of expressions
*/
30293 @d show_var_code
3 /* show a variable and its descendents
*/
30294 @d show_dependencies_code
4 /* show dependent variables in terms of independents
*/
30297 mp_primitive
(mp
, "showtoken", mp_show_command
, show_token_code
);
30298 @
:show_token_
}{\
&{showtoken} primitive@>;
30299 mp_primitive
(mp
, "showstats", mp_show_command
, show_stats_code
);
30300 @
:show_stats_
}{\
&{showstats} primitive@>;
30301 mp_primitive
(mp
, "show", mp_show_command
, show_code
);
30302 @
:show_
}{\
&{show} primitive@>;
30303 mp_primitive
(mp
, "showvariable", mp_show_command
, show_var_code
);
30304 @
:show_var_
}{\
&{showvariable} primitive@>;
30305 mp_primitive
(mp
, "showdependencies", mp_show_command
, show_dependencies_code
);
30306 @
:show_dependencies_
}{\
&{showdependencies} primitive@>
30309 @ @
<Cases of |print_cmd...@
>=
30310 case mp_show_command
:
30312 case show_token_code
:
30313 mp_print
(mp
, "showtoken");
30315 case show_stats_code
:
30316 mp_print
(mp
, "showstats");
30319 mp_print
(mp
, "show");
30321 case show_var_code
:
30322 mp_print
(mp
, "showvariable");
30325 mp_print
(mp
, "showdependencies");
30330 @ The value of |cur_mod| controls the |verbosity| in the |print_exp| routine
:
30331 if it's |show_code|
, complicated structures are abbreviated
, otherwise
30334 @
<Declare action procedures for use by |do_statement|@
>=
30335 static void mp_do_show
(MP mp
);
30338 void mp_do_show
(MP mp
) {
30341 memset
(&new_expr,0,sizeof(mp_value));
30342 new_number
(new_expr.data.n
);
30343 mp_get_x_next
(mp
);
30344 mp_scan_expression
(mp
);
30345 mp_print_nl
(mp
, ">> ");
30347 mp_print_exp
(mp
, NULL, 2);
30348 mp_flush_cur_exp
(mp
, new_expr
);
30349 } while
(cur_cmd
() == mp_comma
);
30353 @ @
<Declare action procedures for use by |do_statement|@
>=
30354 static void mp_disp_token
(MP mp
);
30357 void mp_disp_token
(MP mp
) {
30358 mp_print_nl
(mp
, "> ");
30360 if
(cur_sym
() == NULL) {
30361 @
<Show a numeric or string or capsule token@
>;
30363 mp_print_text
(cur_sym
());
30364 mp_print_char
(mp
, xord
('
='
));
30365 if
(eq_type
(cur_sym
()) >= mp_outer_tag
)
30366 mp_print
(mp
, "(outer) ");
30367 mp_print_cmd_mod
(mp
, cur_cmd
(), cur_mod
());
30368 if
(cur_cmd
() == mp_defined_macro
) {
30370 mp_show_macro
(mp
, cur_mod_node
(), NULL, 100000);
30371 } /* this avoids recursion between |show_macro| and |print_cmd_mod|
*/
30377 @ @
<Show a numeric or string or capsule token@
>=
30379 if
(cur_cmd
() == mp_numeric_token
) {
30380 print_number
(cur_mod_number
());
30381 } else if
(cur_cmd
() == mp_capsule_token
) {
30382 mp_print_capsule
(mp
, cur_mod_node
());
30384 mp_print_char
(mp
, xord
('
"'));
30385 mp_print_str (mp, cur_mod_str());
30386 mp_print_char (mp, xord ('"'
));
30387 delete_str_ref
(cur_mod_str
());
30392 @ The following cases of |print_cmd_mod| might arise in connection
30393 with |disp_token|
, although they don't necessarily correspond to
30396 @
<Cases of |print_cmd_...@
>=
30397 case mp_left_delimiter
:
30398 case mp_right_delimiter
:
30399 if
(c
== mp_left_delimiter
)
30400 mp_print
(mp
, "left");
30402 mp_print
(mp
, "right");
30404 mp_print
(mp
, " delimiter that matches ");
30407 mp_print
(mp
, " delimiter");
30411 if
(m
== 0) /* todo
: this was |null|
*/
30412 mp_print
(mp
, "tag");
30414 mp_print
(mp
, "variable");
30416 case mp_defined_macro
:
30417 mp_print
(mp
, "macro:");
30419 case mp_secondary_primary_macro
:
30420 case mp_tertiary_secondary_macro
:
30421 case mp_expression_tertiary_macro
:
30422 mp_print_cmd_mod
(mp
, mp_macro_def
,c
);
30423 mp_print
(mp
, "'d macro:");
30425 mp_show_token_list
(mp
, mp_link
(mp_link
(cur_mod_node
())),0,1000,0);
30427 case mp_repeat_loop
:
30428 mp_print
(mp
, "[repeat the loop]");
30430 case mp_internal_quantity
:
30431 mp_print
(mp
, internal_name
(m
));
30435 @ @
<Declare action procedures for use by |do_statement|@
>=
30436 static void mp_do_show_token
(MP mp
);
30439 void mp_do_show_token
(MP mp
) {
30442 mp_disp_token
(mp
);
30443 mp_get_x_next
(mp
);
30444 } while
(cur_cmd
() == mp_comma
);
30448 @ @
<Declare action procedures for use by |do_statement|@
>=
30449 static void mp_do_show_stats
(MP mp
);
30452 void mp_do_show_stats
(MP mp
) {
30453 mp_print_nl
(mp
, "Memory usage ");
30454 @.Memory usage...@
>;
30455 mp_print_int
(mp
, (integer
) mp-
>var_used
);
30457 mp_print_nl
(mp
, "String usage ");
30458 mp_print_int
(mp
, (int
) mp-
>strs_in_use
);
30459 mp_print_char
(mp
, xord
('
&'));
30460 mp_print_int
(mp
, (int
) mp-
>pool_in_use
);
30462 mp_get_x_next
(mp
);
30466 @ Here's a recursive procedure that gives an abbreviated account
30467 of a variable
, for use by |do_show_var|.
30469 @
<Declare action procedures for use by |do_statement|@
>=
30470 static void mp_disp_var
(MP mp
, mp_node p
);
30473 void mp_disp_var
(MP mp
, mp_node p
) {
30474 mp_node q
; /* traverses attributes and subscripts
*/
30475 int n
; /* amount of macro text to show
*/
30476 if
(mp_type
(p
) == mp_structured
) {
30477 @
<Descend the structure@
>;
30478 } else if
(mp_type
(p
) >= mp_unsuffixed_macro
) {
30479 @
<Display a variable macro@
>;
30480 } else if
(mp_type
(p
) != mp_undefined
) {
30481 mp_print_nl
(mp
, "");
30482 mp_print_variable_name
(mp
, p
);
30483 mp_print_char
(mp
, xord
('
='
));
30484 mp_print_exp
(mp
, p
, 0);
30489 @ @
<Descend the structure@
>=
30493 mp_disp_var
(mp
, q
);
30495 } while
(q
!= mp-
>end_attr
);
30496 q
= subscr_head
(p
);
30497 while
(mp_name_type
(q
) == mp_subscr
) {
30498 mp_disp_var
(mp
, q
);
30504 @ @
<Display a variable macro@
>=
30506 mp_print_nl
(mp
, "");
30507 mp_print_variable_name
(mp
, p
);
30508 if
(mp_type
(p
) > mp_unsuffixed_macro
)
30509 mp_print
(mp
, "@@#"); /* |suffixed_macro|
*/
30510 mp_print
(mp
, "=macro:");
30511 if
((int
) mp-
>file_offset
>= mp-
>max_print_line
- 20)
30514 n
= mp-
>max_print_line
- (int
) mp-
>file_offset
- 15;
30515 mp_show_macro
(mp
, value_node
(p
), NULL, n
);
30519 @ @
<Declare action procedures for use by |do_statement|@
>=
30520 static void mp_do_show_var
(MP mp
);
30523 void mp_do_show_var
(MP mp
) {
30526 if
(cur_sym
() != NULL)
30527 if
(cur_sym_mod
() == 0)
30528 if
(cur_cmd
() == mp_tag_token
)
30529 if
(cur_mod
() != 0 || cur_mod_node
()!=NULL) {
30530 mp_disp_var
(mp
, cur_mod_node
());
30533 mp_disp_token
(mp
);
30535 mp_get_x_next
(mp
);
30536 } while
(cur_cmd
() == mp_comma
);
30540 @ @
<Declare action procedures for use by |do_statement|@
>=
30541 static void mp_do_show_dependencies
(MP mp
);
30544 void mp_do_show_dependencies
(MP mp
) {
30545 mp_value_node p
; /* link that runs through all dependencies
*/
30546 p
= (mp_value_node
) mp_link
(mp-
>dep_head
);
30547 while
(p
!= mp-
>dep_head
) {
30548 if
(mp_interesting
(mp
, (mp_node
) p
)) {
30549 mp_print_nl
(mp
, "");
30550 mp_print_variable_name
(mp
, (mp_node
) p
);
30551 if
(mp_type
(p
) == mp_dependent
)
30552 mp_print_char
(mp
, xord
('
='
));
30554 mp_print
(mp
, " = "); /* extra spaces imply proto-dependency
*/
30555 mp_print_dependency
(mp
, (mp_value_node
) dep_list
(p
), mp_type
(p
));
30557 p
= (mp_value_node
) dep_list
(p
);
30558 while
(dep_info
(p
) != NULL)
30559 p
= (mp_value_node
) mp_link
(p
);
30560 p
= (mp_value_node
) mp_link
(p
);
30562 mp_get_x_next
(mp
);
30566 @ Finally we are ready for the procedure that governs all of the
30569 @
<Declare action procedures for use by |do_statement|@
>=
30570 static void mp_do_show_whatever
(MP mp
);
30573 void mp_do_show_whatever
(MP mp
) {
30574 if
(mp-
>interaction
== mp_error_stop_mode
)
30575 wake_up_terminal
();
30576 switch
(cur_mod
()) {
30577 case show_token_code
:
30578 mp_do_show_token
(mp
);
30580 case show_stats_code
:
30581 mp_do_show_stats
(mp
);
30586 case show_var_code
:
30587 mp_do_show_var
(mp
);
30589 case show_dependencies_code
:
30590 mp_do_show_dependencies
(mp
);
30592 } /* there are no other cases
*/
30593 if
(number_positive
(internal_value
(mp_showstopping
))) {
30594 const char
*hlp
[] = {
30595 "This isn't an error message; I'm just showing something.",
30597 if
(mp-
>interaction
< mp_error_stop_mode
) {
30599 decr
(mp-
>error_count
);
30601 if
(cur_cmd
() == mp_semicolon
) {
30602 mp_error
(mp
, "OK", hlp
, true
);
30604 mp_back_error
(mp
, "OK", hlp
, true
);
30605 mp_get_x_next
(mp
);
30612 @ The `\
&{addto}' command needs the following additional primitives:
30614 @d double_path_code
0 /* command modifier for `\
&{doublepath}' */
30615 @d contour_code
1 /* command modifier for `\
&{contour}' */
30616 @d also_code
2 /* command modifier for `\
&{also}' */
30618 @ Pre and postscripts need two new identifiers
:
30620 @d with_mp_pre_script
11
30621 @d with_mp_post_script
13
30624 mp_primitive
(mp
, "doublepath", mp_thing_to_add
, double_path_code
);
30625 @
:double_path_
}{\
&{doublepath} primitive@>;
30626 mp_primitive
(mp
, "contour", mp_thing_to_add
, contour_code
);
30627 @
:contour_
}{\
&{contour} primitive@>;
30628 mp_primitive
(mp
, "also", mp_thing_to_add
, also_code
);
30629 @
:also_
}{\
&{also} primitive@>;
30630 mp_primitive
(mp
, "withpen", mp_with_option
, mp_pen_type
);
30631 @
:with_pen_
}{\
&{withpen} primitive@>;
30632 mp_primitive
(mp
, "dashed", mp_with_option
, mp_picture_type
);
30633 @
:dashed_
}{\
&{dashed} primitive@>;
30634 mp_primitive
(mp
, "withprescript", mp_with_option
, with_mp_pre_script
);
30635 @
:with_mp_pre_script_
}{\
&{withprescript} primitive@>;
30636 mp_primitive
(mp
, "withpostscript", mp_with_option
, with_mp_post_script
);
30637 @
:with_mp_post_script_
}{\
&{withpostscript} primitive@>;
30638 mp_primitive
(mp
, "withoutcolor", mp_with_option
, mp_no_model
);
30639 @
:with_color_
}{\
&{withoutcolor} primitive@>;
30640 mp_primitive
(mp
, "withgreyscale", mp_with_option
, mp_grey_model
);
30641 @
:with_color_
}{\
&{withgreyscale} primitive@>;
30642 mp_primitive
(mp
, "withcolor", mp_with_option
, mp_uninitialized_model
);
30643 @
:with_color_
}{\
&{withcolor} primitive@>
30644 /* \
&{withrgbcolor} is an alias for \&{withcolor} */
30645 mp_primitive
(mp
, "withrgbcolor", mp_with_option
, mp_rgb_model
);
30646 @
:with_color_
}{\
&{withrgbcolor} primitive@>;
30647 mp_primitive
(mp
, "withcmykcolor", mp_with_option
, mp_cmyk_model
);
30648 @
:with_color_
}{\
&{withcmykcolor} primitive@>
30651 @ @
<Cases of |print_cmd...@
>=
30652 case mp_thing_to_add
:
30653 if
(m
== contour_code
)
30654 mp_print
(mp
, "contour");
30655 else if
(m
== double_path_code
)
30656 mp_print
(mp
, "doublepath");
30658 mp_print
(mp
, "also");
30660 case mp_with_option
:
30661 if
(m
== mp_pen_type
)
30662 mp_print
(mp
, "withpen");
30663 else if
(m
== with_mp_pre_script
)
30664 mp_print
(mp
, "withprescript");
30665 else if
(m
== with_mp_post_script
)
30666 mp_print
(mp
, "withpostscript");
30667 else if
(m
== mp_no_model
)
30668 mp_print
(mp
, "withoutcolor");
30669 else if
(m
== mp_rgb_model
)
30670 mp_print
(mp
, "withrgbcolor");
30671 else if
(m
== mp_uninitialized_model
)
30672 mp_print
(mp
, "withcolor");
30673 else if
(m
== mp_cmyk_model
)
30674 mp_print
(mp
, "withcmykcolor");
30675 else if
(m
== mp_grey_model
)
30676 mp_print
(mp
, "withgreyscale");
30678 mp_print
(mp
, "dashed");
30681 @ The |scan_with_list| procedure parses a $\langle$with list$\rangle$ and
30682 updates the list of graphical objects starting at |p|. Each $\langle$with
30683 clause$\rangle$ updates all graphical objects whose |type| is compatible.
30684 Other objects are ignored.
30686 @
<Declare action procedures for use by |do_statement|@
>=
30687 static void mp_scan_with_list
(MP mp
, mp_node p
);
30689 @ Forcing the color to be between |
0| and |unity| here guarantees that no
30690 picture will ever contain a color outside the legal range for \ps\ graphics.
30692 @d make_cp_a_colored_object
() do
{
30694 while
(cp
!= NULL) {
30695 if
(has_color
(cp
))
30701 @d clear_color
(A
) do
{
30702 set_number_to_zero
(((mp_stroked_node
)(A
))->cyan
);
30703 set_number_to_zero
(((mp_stroked_node
)(A
))->magenta
);
30704 set_number_to_zero
(((mp_stroked_node
)(A
))->yellow
);
30705 set_number_to_zero
(((mp_stroked_node
)(A
))->black
);
30706 mp_color_model
((A
)) = mp_uninitialized_model
;
30709 @d set_color_val
(A
,B
) do
{
30710 number_clone
(A
, (B
));
30711 if
(number_negative
(A
))
30712 set_number_to_zero
(A
);
30713 if
(number_greater
(A
,unity_t
))
30714 set_number_to_unity
(A
);
30718 static int is_invalid_with_list
(MP mp
, mp_variable_type t
) {
30719 return
((t
== with_mp_pre_script
) && (mp->cur_exp.type != mp_string_type)) ||
30720 ((t
== with_mp_post_script
) && (mp->cur_exp.type != mp_string_type)) ||
30721 ((t
== (mp_variable_type
) mp_uninitialized_model
) &&
30722 ((mp-
>cur_exp.type
!= mp_cmykcolor_type
)
30723 && (mp->cur_exp.type != mp_color_type)
30724 && (mp->cur_exp.type != mp_known)
30725 && (mp->cur_exp.type != mp_boolean_type))) || ((t == (mp_variable_type) mp_cmyk_model)
30726 && (mp->cur_exp.type !=
30727 mp_cmykcolor_type
))
30728 ||
((t
== (mp_variable_type
) mp_rgb_model
) && (mp->cur_exp.type != mp_color_type))
30729 ||
((t
== (mp_variable_type
) mp_grey_model
) && (mp->cur_exp.type != mp_known))
30730 ||
((t
== (mp_variable_type
) mp_pen_type
) && (mp->cur_exp.type != t))
30731 ||
((t
== (mp_variable_type
) mp_picture_type
) && (mp->cur_exp.type != t));
30733 static void complain_invalid_with_list
(MP mp
, mp_variable_type t
) {
30734 /* Complain about improper type
*/
30736 const char
*hlp
[] = {
30737 "Next time say `withpen <known pen expression>';",
30738 "I'll ignore the bad `with' clause and look for another.",
30740 memset
(&new_expr,0,sizeof(mp_value));
30741 new_number
(new_expr.data.n
);
30742 mp_disp_err
(mp
, NULL);
30743 if
(t
== with_mp_pre_script
)
30744 hlp
[0] = "Next time say `withprescript <known string expression>';";
30745 else if
(t
== with_mp_post_script
)
30746 hlp
[0] = "Next time say `withpostscript <known string expression>';";
30747 else if
(t
== mp_picture_type
)
30748 hlp
[0] = "Next time say `dashed <known picture expression>';";
30749 else if
(t
== (mp_variable_type
) mp_uninitialized_model
)
30750 hlp
[0] = "Next time say `withcolor <known color expression>';";
30751 else if
(t
== (mp_variable_type
) mp_rgb_model
)
30752 hlp
[0] = "Next time say `withrgbcolor <known color expression>';";
30753 else if
(t
== (mp_variable_type
) mp_cmyk_model
)
30754 hlp
[0] = "Next time say `withcmykcolor <known cmykcolor expression>';";
30755 else if
(t
== (mp_variable_type
) mp_grey_model
)
30756 hlp
[0] = "Next time say `withgreyscale <known numeric expression>';";;
30757 mp_back_error
(mp
, "Improper type", hlp
, true
);
30758 mp_get_x_next
(mp
);
30759 mp_flush_cur_exp
(mp
, new_expr
);
30762 void mp_scan_with_list
(MP mp
, mp_node p
) {
30763 mp_variable_type t
; /* |cur_mod| of the |with_option|
(should match |cur_type|
) */
30764 mp_node q
; /* for list manipulation
*/
30765 mp_node cp
, pp
, dp
, ap
, bp
;
30766 /* objects being updated
; |void| initially
; |
NULL| to suppress update
*/
30772 while
(cur_cmd
() == mp_with_option
) {
30773 /* todo this is not very nice
: the color models have their own enumeration
*/
30774 t
= (mp_variable_type
) cur_mod
();
30775 mp_get_x_next
(mp
);
30776 if
(t
!= (mp_variable_type
) mp_no_model
)
30777 mp_scan_expression
(mp
);
30778 if
(is_invalid_with_list
(mp
, t
)) {
30779 complain_invalid_with_list
(mp
, t
);
30782 if
(t
== (mp_variable_type
) mp_uninitialized_model
) {
30784 memset
(&new_expr,0,sizeof(mp_value));
30785 new_number
(new_expr.data.n
);
30787 make_cp_a_colored_object
();
30789 /* Transfer a color from the current expression to object~|cp|
*/
30790 if
(mp-
>cur_exp.type
== mp_color_type
) {
30791 /* Transfer a rgbcolor from the current expression to object~|cp|
*/
30792 mp_stroked_node cp0
= (mp_stroked_node
)cp
;
30793 q
= value_node
(cur_exp_node
());
30795 mp_color_model
(cp
) = mp_rgb_model
;
30796 set_color_val
(cp0-
>red
, value_number
(red_part
(q
)));
30797 set_color_val
(cp0-
>green
, value_number
(green_part
(q
)));
30798 set_color_val
(cp0-
>blue
, value_number
(blue_part
(q
)));
30799 } else if
(mp-
>cur_exp.type
== mp_cmykcolor_type
) {
30800 /* Transfer a cmykcolor from the current expression to object~|cp|
*/
30801 mp_stroked_node cp0
= (mp_stroked_node
)cp
;
30802 q
= value_node
(cur_exp_node
());
30803 set_color_val
(cp0-
>cyan
, value_number
(cyan_part
(q
)));
30804 set_color_val
(cp0-
>magenta
, value_number
(magenta_part
(q
)));
30805 set_color_val
(cp0-
>yellow
, value_number
(yellow_part
(q
)));
30806 set_color_val
(cp0-
>black
, value_number
(black_part
(q
)));
30807 mp_color_model
(cp
) = mp_cmyk_model
;
30808 } else if
(mp-
>cur_exp.type
== mp_known
) {
30809 /* Transfer a greyscale from the current expression to object~|cp|
*/
30811 mp_stroked_node cp0
= (mp_stroked_node
)cp
;
30813 number_clone
(qq
, cur_exp_value_number
());
30815 mp_color_model
(cp
) = mp_grey_model
;
30816 set_color_val
(cp0-
>grey
, qq
);
30818 } else if
(cur_exp_value_boolean
() == mp_false_code
) {
30819 /* Transfer a noncolor from the current expression to object~|cp|
*/
30821 mp_color_model
(cp
) = mp_no_model
;
30822 } else if
(cur_exp_value_boolean
() == mp_true_code
) {
30823 /* Transfer no color from the current expression to object~|cp|
*/
30825 mp_color_model
(cp
) = mp_uninitialized_model
;
30828 mp_flush_cur_exp
(mp
, new_expr
);
30829 } else if
(t
== (mp_variable_type
) mp_rgb_model
) {
30831 memset
(&new_expr,0,sizeof(mp_value));
30832 new_number
(new_expr.data.n
);
30834 make_cp_a_colored_object
();
30836 /* Transfer a rgbcolor from the current expression to object~|cp|
*/
30837 mp_stroked_node cp0
= (mp_stroked_node
)cp
;
30838 q
= value_node
(cur_exp_node
());
30840 mp_color_model
(cp
) = mp_rgb_model
;
30841 set_color_val
(cp0-
>red
, value_number
(red_part
(q
)));
30842 set_color_val
(cp0-
>green
, value_number
(green_part
(q
)));
30843 set_color_val
(cp0-
>blue
, value_number
(blue_part
(q
)));
30845 mp_flush_cur_exp
(mp
, new_expr
);
30846 } else if
(t
== (mp_variable_type
) mp_cmyk_model
) {
30848 memset
(&new_expr,0,sizeof(mp_value));
30849 new_number
(new_expr.data.n
);
30851 make_cp_a_colored_object
();
30853 /* Transfer a cmykcolor from the current expression to object~|cp|
*/
30854 mp_stroked_node cp0
= (mp_stroked_node
)cp
;
30855 q
= value_node
(cur_exp_node
());
30856 set_color_val
(cp0-
>cyan
, value_number
(cyan_part
(q
)));
30857 set_color_val
(cp0-
>magenta
, value_number
(magenta_part
(q
)));
30858 set_color_val
(cp0-
>yellow
, value_number
(yellow_part
(q
)));
30859 set_color_val
(cp0-
>black
, value_number
(black_part
(q
)));
30860 mp_color_model
(cp
) = mp_cmyk_model
;
30862 mp_flush_cur_exp
(mp
, new_expr
);
30863 } else if
(t
== (mp_variable_type
) mp_grey_model
) {
30865 memset
(&new_expr,0,sizeof(mp_value));
30866 new_number
(new_expr.data.n
);
30868 make_cp_a_colored_object
();
30870 /* Transfer a greyscale from the current expression to object~|cp|
*/
30872 mp_stroked_node cp0
= (mp_stroked_node
)cp
;
30874 number_clone
(qq
, cur_exp_value_number
());
30876 mp_color_model
(cp
) = mp_grey_model
;
30877 set_color_val
(cp0-
>grey
, qq
);
30880 mp_flush_cur_exp
(mp
, new_expr
);
30881 } else if
(t
== (mp_variable_type
) mp_no_model
) {
30883 make_cp_a_colored_object
();
30885 /* Transfer a noncolor from the current expression to object~|cp|
*/
30887 mp_color_model
(cp
) = mp_no_model
;
30889 } else if
(t
== mp_pen_type
) {
30890 if
(pp
== MP_VOID
) {
30891 /* Make |pp| an object in list~|p| that needs a pen
*/
30893 while
(pp
!= NULL) {
30901 switch
(mp_type
(pp
)) {
30902 case mp_fill_node_type
:
30903 if
(mp_pen_p
((mp_fill_node
) pp
) != NULL)
30904 mp_toss_knot_list
(mp
, mp_pen_p
((mp_fill_node
) pp
));
30905 mp_pen_p
((mp_fill_node
) pp
) = cur_exp_knot
();
30907 case mp_stroked_node_type
:
30908 if
(mp_pen_p
((mp_stroked_node
) pp
) != NULL)
30909 mp_toss_knot_list
(mp
, mp_pen_p
((mp_stroked_node
) pp
));
30910 mp_pen_p
((mp_stroked_node
) pp
) = cur_exp_knot
();
30916 mp-
>cur_exp.type
= mp_vacuous
;
30918 } else if
(t
== with_mp_pre_script
) {
30919 if
(cur_exp_str
()->len
) {
30922 while
((ap
!= NULL) && (!has_color (ap)))
30925 if
(mp_pre_script
(ap
) != NULL) { /* build a new
,combined string
*/
30926 unsigned old_setting
; /* saved |selector| setting
*/
30927 mp_string s
; /* for string cleanup after combining
*/
30928 s
= mp_pre_script
(ap
);
30929 old_setting
= mp-
>selector
;
30930 mp-
>selector
= new_string
;
30931 str_room
(mp_pre_script
(ap
)->len
+ cur_exp_str
()->len
+ 2);
30932 mp_print_str
(mp
, cur_exp_str
());
30933 append_char
(13); /* a forced \ps\ newline
*/
30934 mp_print_str
(mp
, mp_pre_script
(ap
));
30935 mp_pre_script
(ap
) = mp_make_string
(mp
);
30936 delete_str_ref
(s
);
30937 mp-
>selector
= old_setting
;
30939 mp_pre_script
(ap
) = cur_exp_str
();
30941 add_str_ref
(mp_pre_script
(ap
));
30942 mp-
>cur_exp.type
= mp_vacuous
;
30945 } else if
(t
== with_mp_post_script
) {
30946 if
(cur_exp_str
()->len
) {
30947 mp_node k
= NULL; /* for finding the near-last item in a list
*/
30951 while
(k
&& mp_link (k) != NULL) { /* clang: dereference null pointer 'k' */
30957 if
(mp_post_script
(bp
) != NULL) {
30958 unsigned old_setting
; /* saved |selector| setting
*/
30959 mp_string s
; /* for string cleanup after combining
*/
30960 s
= mp_post_script
(bp
);
30961 old_setting
= mp-
>selector
;
30962 mp-
>selector
= new_string
;
30963 str_room
(mp_post_script
(bp
)->len
+ cur_exp_str
()->len
+ 2);
30964 mp_print_str
(mp
, mp_post_script
(bp
));
30965 append_char
(13); /* a forced \ps\ newline
*/
30966 mp_print_str
(mp
, cur_exp_str
());
30967 mp_post_script
(bp
) = mp_make_string
(mp
);
30968 delete_str_ref
(s
);
30969 mp-
>selector
= old_setting
;
30971 mp_post_script
(bp
) = cur_exp_str
();
30973 add_str_ref
(mp_post_script
(bp
));
30974 mp-
>cur_exp.type
= mp_vacuous
;
30978 if
(dp
== MP_VOID
) {
30979 /* Make |dp| a stroked node in list~|p|
*/
30981 while
(dp
!= NULL) {
30982 if
(mp_type
(dp
) == mp_stroked_node_type
)
30988 if
(mp_dash_p
(dp
) != NULL)
30989 delete_edge_ref
(mp_dash_p
(dp
));
30990 mp_dash_p
(dp
) = (mp_node
)mp_make_dashes
(mp
, (mp_edge_header_node
)cur_exp_node
());
30991 set_number_to_unity
(((mp_stroked_node
)dp
)->dash_scale
);
30992 mp-
>cur_exp.type
= mp_vacuous
;
30996 /* Copy the information from objects |cp|
, |pp|
, and |dp| into the rest
30998 if
(cp
> MP_VOID
) {
30999 /* Copy |cp|'s color into the colored objects linked to~|cp|
*/
31001 while
(q
!= NULL) {
31002 if
(has_color
(q
)) {
31003 mp_stroked_node q0
= (mp_stroked_node
)q
;
31004 mp_stroked_node cp0
= (mp_stroked_node
)cp
;
31005 number_clone
(q0-
>red
, cp0-
>red
);
31006 number_clone
(q0-
>green
, cp0-
>green
);
31007 number_clone
(q0-
>blue
, cp0-
>blue
);
31008 number_clone
(q0-
>black
, cp0-
>black
);
31009 mp_color_model
(q
) = mp_color_model
(cp
);
31014 if
(pp
> MP_VOID
) {
31015 /* Copy |mp_pen_p
(pp
)| into stroked and filled nodes linked to |pp|
*/
31017 while
(q
!= NULL) {
31019 switch
(mp_type
(q
)) {
31020 case mp_fill_node_type
:
31021 if
(mp_pen_p
((mp_fill_node
) q
) != NULL)
31022 mp_toss_knot_list
(mp
, mp_pen_p
((mp_fill_node
) q
));
31023 mp_pen_p
((mp_fill_node
) q
) = copy_pen
(mp_pen_p
((mp_fill_node
) pp
));
31025 case mp_stroked_node_type
:
31026 if
(mp_pen_p
((mp_stroked_node
) q
) != NULL)
31027 mp_toss_knot_list
(mp
, mp_pen_p
((mp_stroked_node
) q
));
31028 mp_pen_p
((mp_stroked_node
) q
) =
31029 copy_pen
(mp_pen_p
((mp_stroked_node
) pp
));
31039 if
(dp
> MP_VOID
) {
31040 /* Make stroked nodes linked to |dp| refer to |mp_dash_p
(dp
)|
*/
31042 while
(q
!= NULL) {
31043 if
(mp_type
(q
) == mp_stroked_node_type
) {
31044 if
(mp_dash_p
(q
) != NULL)
31045 delete_edge_ref
(mp_dash_p
(q
));
31046 mp_dash_p
(q
) = mp_dash_p
(dp
);
31047 set_number_to_unity
(((mp_stroked_node
)q
)->dash_scale
);
31048 if
(mp_dash_p
(q
) != NULL)
31049 add_edge_ref
(mp_dash_p
(q
));
31057 @ One of the things we need to do when we've parsed an \
&{addto} or
31058 similar command is find the header of a supposed \
&{picture} variable, given
31059 a token list for that variable. Since the edge structure is about to be
31060 updated
, we use |private_edges| to make sure that this is possible.
31062 @
<Declare action procedures for use by |do_statement|@
>=
31063 static mp_edge_header_node mp_find_edges_var
(MP mp
, mp_node t
);
31066 mp_edge_header_node mp_find_edges_var
(MP mp
, mp_node t
) {
31068 mp_edge_header_node cur_edges
; /* the return value
*/
31069 p
= mp_find_variable
(mp
, t
);
31072 const char
*hlp
[] = {
31073 "It seems you did a nasty thing---probably by accident,",
31074 "but nevertheless you nearly hornswoggled me...",
31075 "While I was evaluating the right-hand side of this",
31076 "command, something happened, and the left-hand side",
31077 "is no longer a variable! So I won't change anything.",
31079 char
*msg
= mp_obliterated
(mp
, t
);
31080 mp_back_error
(mp
, msg
, hlp
, true
);
31082 mp_get_x_next
(mp
);
31083 } else if
(mp_type
(p
) != mp_picture_type
) {
31086 int old_setting
= mp-
>selector
;
31087 const char
*hlp
[] = {
31088 "I was looking for a \"known\
" picture variable.",
31089 "So I'll not change anything just now.",
31091 mp-
>selector
= new_string
;
31092 mp_show_token_list
(mp
, t
, NULL, 1000, 0);
31093 sname
= mp_make_string
(mp
);
31094 mp-
>selector
= old_setting
;
31095 mp_snprintf
(msg
, 256, "Variable %s is the wrong type(%s)",
31096 mp_str
(mp
, sname
), mp_type_string
(mp_type
(p
)));
31097 @.Variable x is the wrong type@
>;
31098 delete_str_ref
(sname
);
31099 mp_back_error
(mp
, msg
, hlp
, true
);
31100 mp_get_x_next
(mp
);
31102 set_value_node
(p
, (mp_node
)mp_private_edges
(mp
, (mp_edge_header_node
)value_node
(p
)));
31103 cur_edges
= (mp_edge_header_node
)value_node
(p
);
31105 mp_flush_node_list
(mp
, t
);
31111 mp_primitive
(mp
, "clip", mp_bounds_command
, mp_start_clip_node_type
);
31112 @
:clip_
}{\
&{clip} primitive@>;
31113 mp_primitive
(mp
, "setbounds", mp_bounds_command
, mp_start_bounds_node_type
);
31114 @
:set_bounds_
}{\
&{setbounds} primitive@>
31117 @ @
<Cases of |print_cmd...@
>=
31118 case mp_bounds_command
:
31119 if
(m
== mp_start_clip_node_type
)
31120 mp_print
(mp
, "clip");
31122 mp_print
(mp
, "setbounds");
31125 @ The following function parses the beginning of an \
&{addto} or \&{clip}
31126 command
: it expects a variable name followed by a token with |cur_cmd
=sep|
31127 and then an expression. The function returns the token list for the variable
31128 and stores the command modifier for the separator token in the global variable
31129 |last_add_type|. We must be careful because this variable might get overwritten
31130 any time we call |get_x_next|.
31133 quarterword last_add_type
;
31134 /* command modifier that identifies the last \
&{addto} command */
31136 @ @
<Declare action procedures for use by |do_statement|@
>=
31137 static mp_node mp_start_draw_cmd
(MP mp
, quarterword sep
);
31140 mp_node mp_start_draw_cmd
(MP mp
, quarterword sep
) {
31141 mp_node lhv
; /* variable to add to left
*/
31142 quarterword add_type
= 0; /* value to be returned in |last_add_type|
*/
31144 mp_get_x_next
(mp
);
31145 mp-
>var_flag
= sep
;
31146 mp_scan_primary
(mp
);
31147 if
(mp-
>cur_exp.type
!= mp_token_list
) {
31148 /* Abandon edges command because there's no variable
*/
31150 const char
*hlp
[] = {
31151 "At this point I needed to see the name of a picture variable.",
31152 "(Or perhaps you have indeed presented me with one; I might",
31153 "have missed it, if it wasn't followed by the proper token.)",
31154 "So I'll not change anything just now.",
31156 memset
(&new_expr,0,sizeof(mp_value));
31157 new_number
(new_expr.data.n
);
31158 mp_disp_err
(mp
, NULL);
31159 set_number_to_zero
(new_expr.data.n
);
31160 mp_back_error
(mp
, "Not a suitable variable", hlp
, true
);
31161 mp_get_x_next
(mp
);
31162 mp_flush_cur_exp
(mp
, new_expr
);
31164 lhv
= cur_exp_node
();
31165 add_type
= (quarterword
) cur_mod
();
31166 mp-
>cur_exp.type
= mp_vacuous
;
31167 mp_get_x_next
(mp
);
31168 mp_scan_expression
(mp
);
31170 mp-
>last_add_type
= add_type
;
31174 @ Here is an example of how to use |start_draw_cmd|.
31176 @
<Declare action procedures for use by |do_statement|@
>=
31177 static void mp_do_bounds
(MP mp
);
31180 void mp_do_bounds
(MP mp
) {
31181 mp_node lhv
; /* variable on left
, the corresponding edge structure
*/
31182 mp_edge_header_node lhe
;
31183 mp_node p
; /* for list manipulation
*/
31184 integer m
; /* initial value of |cur_mod|
*/
31186 lhv
= mp_start_draw_cmd
(mp
, mp_to_token
);
31189 memset
(&new_expr,0,sizeof(mp_value));
31190 lhe
= mp_find_edges_var
(mp
, lhv
);
31192 new_number
(new_expr.data.n
);
31193 set_number_to_zero
(new_expr.data.n
);
31194 mp_flush_cur_exp
(mp
, new_expr
);
31195 } else if
(mp-
>cur_exp.type
!= mp_path_type
) {
31196 const char
*hlp
[] ={
31197 "This expression should have specified a known path.",
31198 "So I'll not change anything just now.",
31200 mp_disp_err
(mp
, NULL);
31201 new_number
(new_expr.data.n
);
31202 set_number_to_zero
(new_expr.data.n
);
31203 mp_back_error
(mp
, "Improper `clip'", hlp
, true
);
31204 mp_get_x_next
(mp
);
31205 mp_flush_cur_exp
(mp
, new_expr
);
31206 } else if
(mp_left_type
(cur_exp_knot
()) == mp_endpoint
) {
31207 /* Complain about a non-cycle
*/
31208 const char
*hlp
[] = {
31209 "That contour should have ended with `..cycle' or `&cycle'.",
31210 "So I'll not change anything just now.",
31212 mp_back_error
(mp
, "Not a cycle" , hlp
, true
);
31213 mp_get_x_next
(mp
);
31215 /* Make |cur_exp| into a \
&{setbounds} or clipping path and add it to |lhe| */
31216 p
= mp_new_bounds_node
(mp
, cur_exp_knot
(), (quarterword
) m
);
31217 mp_link
(p
) = mp_link
(edge_list
(lhe
));
31218 mp_link
(edge_list
(lhe
)) = p
;
31219 if
(obj_tail
(lhe
) == edge_list
(lhe
))
31220 obj_tail
(lhe
) = p
;
31221 if
(m
== mp_start_clip_node_type
) {
31222 p
= mp_new_bounds_node
(mp
, NULL, mp_stop_clip_node_type
);
31223 } else if
(m
== mp_start_bounds_node_type
) {
31224 p
= mp_new_bounds_node
(mp
, NULL, mp_stop_bounds_node_type
);
31226 mp_link
(obj_tail
(lhe
)) = p
;
31227 obj_tail
(lhe
) = p
;
31228 mp_init_bbox
(mp
, lhe
);
31234 @ The |do_add_to| procedure is a little like |do_clip| but there are a lot more
31235 cases to deal with.
31237 @
<Declare action procedures for use by |do_statement|@
>=
31238 static void mp_do_add_to
(MP mp
);
31241 void mp_do_add_to
(MP mp
) {
31243 mp_edge_header_node lhe
; /* variable on left
, the corresponding edge structure
*/
31244 mp_node p
; /* the graphical object or list for |scan_with_list| to update
*/
31245 mp_edge_header_node e
; /* an edge structure to be merged
*/
31246 quarterword add_type
; /* |also_code|
, |contour_code|
, or |double_path_code|
*/
31247 lhv
= mp_start_draw_cmd
(mp
, mp_thing_to_add
);
31248 add_type
= mp-
>last_add_type
;
31250 if
(add_type
== also_code
) {
31251 /* Make sure the current expression is a suitable picture and set |e| and |p|
31253 /* Setting |p
:=NULL| causes the $\langle$with list$\rangle$ to be ignored
;
31254 setting |e
:=NULL| prevents anything from being added to |lhe|.
*/
31257 if
(mp-
>cur_exp.type
!= mp_picture_type
) {
31259 const char
*hlp
[]= {
31260 "This expression should have specified a known picture.",
31261 "So I'll not change anything just now.",
31263 memset
(&new_expr,0,sizeof(mp_value));
31264 new_number
(new_expr.data.n
);
31265 mp_disp_err
(mp
, NULL);
31266 set_number_to_zero
(new_expr.data.n
);
31267 mp_back_error
(mp
, "Improper `addto'", hlp
, true
);
31268 mp_get_x_next
(mp
);
31269 mp_flush_cur_exp
(mp
, new_expr
);
31271 e
= mp_private_edges
(mp
, (mp_edge_header_node
)cur_exp_node
());
31272 mp-
>cur_exp.type
= mp_vacuous
;
31273 p
= mp_link
(edge_list
(e
));
31277 /* Create a graphical object |p| based on |add_type| and the current
31279 /* In this case |add_type
<>also_code| so setting |p
:=NULL| suppresses future
31280 attempts to add to the edge structure.
*/
31283 if
(mp-
>cur_exp.type
== mp_pair_type
)
31284 mp_pair_to_path
(mp
);
31285 if
(mp-
>cur_exp.type
!= mp_path_type
) {
31287 const char
*hlp
[] = {
31288 "This expression should have specified a known path.",
31289 "So I'll not change anything just now.",
31291 memset
(&new_expr,0,sizeof(mp_value));
31292 new_number
(new_expr.data.n
);
31293 mp_disp_err
(mp
, NULL);
31294 set_number_to_zero
(new_expr.data.n
);
31295 mp_back_error
(mp
, "Improper `addto'", hlp
, true
);
31296 mp_get_x_next
(mp
);
31297 mp_flush_cur_exp
(mp
, new_expr
);
31298 } else if
(add_type
== contour_code
) {
31299 if
(mp_left_type
(cur_exp_knot
()) == mp_endpoint
) {
31300 /* Complain about a non-cycle
*/
31301 const char
*hlp
[] = {
31302 "That contour should have ended with `..cycle' or `&cycle'.",
31303 "So I'll not change anything just now.",
31305 mp_back_error
(mp
, "Not a cycle" , hlp
, true
);
31306 mp_get_x_next
(mp
);
31309 p
= mp_new_fill_node
(mp
, cur_exp_knot
());
31310 mp-
>cur_exp.type
= mp_vacuous
;
31313 p
= mp_new_stroked_node
(mp
, cur_exp_knot
());
31314 mp-
>cur_exp.type
= mp_vacuous
;
31318 mp_scan_with_list
(mp
, p
);
31319 /* Use |p|
, |e|
, and |add_type| to augment |lhv| as requested
*/
31320 lhe
= mp_find_edges_var
(mp
, lhv
);
31322 if
((e
== NULL) && (p != NULL))
31323 e
= mp_toss_gr_object
(mp
, p
);
31325 delete_edge_ref
(e
);
31326 } else if
(add_type
== also_code
) {
31328 /* Merge |e| into |lhe| and delete |e|
*/
31329 if
(mp_link
(edge_list
(e
)) != NULL) {
31330 mp_link
(obj_tail
(lhe
)) = mp_link
(edge_list
(e
));
31331 obj_tail
(lhe
) = obj_tail
(e
);
31332 obj_tail
(e
) = edge_list
(e
);
31333 mp_link
(edge_list
(e
)) = NULL;
31334 mp_flush_dash_list
(mp
, lhe
);
31336 mp_toss_edges
(mp
, e
);
31338 } else if
(p
!= NULL) {
31339 mp_link
(obj_tail
(lhe
)) = p
;
31340 obj_tail
(lhe
) = p
;
31341 if
(add_type
== double_path_code
) {
31342 if
(mp_pen_p
((mp_stroked_node
) p
) == NULL) {
31343 mp_pen_p
((mp_stroked_node
) p
) = mp_get_pen_circle
(mp
, zero_t
);
31350 @ @
<Declare action procedures for use by |do_statement|@
>=
31351 @
<Declare the \ps\ output procedures@
>;
31352 static void mp_do_ship_out
(MP mp
);
31355 void mp_do_ship_out
(MP mp
) {
31356 integer c
; /* the character code
*/
31358 memset
(&new_expr,0,sizeof(mp_value));
31359 new_number
(new_expr.data.n
);
31360 mp_get_x_next
(mp
);
31361 mp_scan_expression
(mp
);
31362 if
(mp-
>cur_exp.type
!= mp_picture_type
) {
31363 @
<Complain that it's not a known picture@
>;
31365 c
= round_unscaled
(internal_value
(mp_char_code
)) % 256;
31368 @
<Store the width information for character code~|c|@
>;
31369 mp_ship_out
(mp
, cur_exp_node
());
31370 set_number_to_zero
(new_expr.data.n
);
31371 mp_flush_cur_exp
(mp
, new_expr
);
31376 @ @
<Complain that it's not a known picture@
>=
31378 const char
*hlp
[] = { "I can only output known pictures.", NULL };
31379 mp_disp_err
(mp
, NULL);
31380 set_number_to_zero
(new_expr.data.n
);
31381 mp_back_error
(mp
, "Not a known picture", hlp
, true
);
31382 mp_get_x_next
(mp
);
31383 mp_flush_cur_exp
(mp
, new_expr
);
31387 @ The \
&{everyjob} command simply assigns a nonzero value to the global variable
31392 mp_sym start_sym
; /* a symbolic token to insert at beginning of job
*/
31395 mp-
>start_sym
= NULL;
31397 @ Finally
, we have only the ``message'' commands remaining.
31400 @d err_message_code
1
31402 @d filename_template_code
3
31403 @d print_with_leading_zeroes
(A
,B
) do
{
31404 size_t g
= mp-
>cur_length
;
31405 size_t f
= (size_t
)(B
);
31406 mp_print_int
(mp
, (A
));
31407 g
= mp-
>cur_length
- g
;
31409 mp-
>cur_length
= mp-
>cur_length
- g
;
31411 mp_print_char
(mp
, xord
('
0'
));
31414 mp_print_int
(mp
, (A
));
31420 mp_primitive
(mp
, "message", mp_message_command
, message_code
);
31421 @
:message_
}{\
&{message} primitive@>;
31422 mp_primitive
(mp
, "errmessage", mp_message_command
, err_message_code
);
31423 @
:err_message_
}{\
&{errmessage} primitive@>;
31424 mp_primitive
(mp
, "errhelp", mp_message_command
, err_help_code
);
31425 @
:err_help_
}{\
&{errhelp} primitive@>;
31426 mp_primitive
(mp
, "filenametemplate", mp_message_command
, filename_template_code
);
31427 @
:filename_template_
}{\
&{filenametemplate} primitive@>
31430 @ @
<Cases of |print_cmd...@
>=
31431 case mp_message_command
:
31432 if
(m
< err_message_code
)
31433 mp_print
(mp
, "message");
31434 else if
(m
== err_message_code
)
31435 mp_print
(mp
, "errmessage");
31436 else if
(m
== filename_template_code
)
31437 mp_print
(mp
, "filenametemplate");
31439 mp_print
(mp
, "errhelp");
31442 @ @
<Declare action procedures for use by |do_statement|@
>=
31443 @
<Declare a procedure called |no_string_err|@
>;
31444 static void mp_do_message
(MP mp
);
31448 void mp_do_message
(MP mp
) {
31449 int m
; /* the type of message
*/
31452 memset
(&new_expr,0,sizeof(mp_value));
31453 new_number
(new_expr.data.n
);
31454 mp_get_x_next
(mp
);
31455 mp_scan_expression
(mp
);
31456 if
(mp-
>cur_exp.type
!= mp_string_type
)
31457 mp_no_string_err
(mp
, "A message should be a known string expression.");
31461 mp_print_nl
(mp
, "");
31462 mp_print_str
(mp
, cur_exp_str
());
31464 case err_message_code
:
31465 @
<Print string |cur_exp| as an error message@
>;
31467 case err_help_code
:
31468 @
<Save string |cur_exp| as the |err_help|@
>;
31470 case filename_template_code
:
31471 @
<Save the filename template@
>;
31473 } /* there are no other cases
*/
31475 set_number_to_zero
(new_expr.data.n
);
31476 mp_flush_cur_exp
(mp
, new_expr
);
31480 @ @
<Save the filename template@
>=
31482 delete_str_ref
(internal_string
(mp_output_template
));
31483 if
(cur_exp_str
()->len
== 0) {
31484 set_internal_string
(mp_output_template
, mp_rts
(mp
, "%j.%c"));
31486 set_internal_string
(mp_output_template
, cur_exp_str
());
31487 add_str_ref
(internal_string
(mp_output_template
));
31492 @ @
<Declare a procedure called |no_string_err|@
>=
31493 static void mp_no_string_err
(MP mp
, const char
*s
) {
31494 const char
*hlp
[] = {s
, NULL};
31495 mp_disp_err
(mp
, NULL);
31496 mp_back_error
(mp
, "Not a string", hlp
, true
);
31498 mp_get_x_next
(mp
);
31502 @ The global variable |err_help| is zero when the user has most recently
31503 given an empty help string
, or if none has ever been given.
31505 @
<Save string |cur_exp| as the |err_help|@
>=
31507 if
(mp-
>err_help
!= NULL)
31508 delete_str_ref
(mp-
>err_help
);
31509 if
(cur_exp_str
()->len
== 0)
31510 mp-
>err_help
= NULL;
31512 mp-
>err_help
= cur_exp_str
();
31513 add_str_ref
(mp-
>err_help
);
31518 @ If \
&{errmessage} occurs often in |mp_scroll_mode|, without user-defined
31519 \
&{errhelp}, we don't want to give a long help message each time. So we
31520 give a verbose explanation only once.
31523 boolean long_help_seen
; /* has the long \.
{\\errmessage
} help been used?
*/
31526 mp-
>long_help_seen
= false
;
31528 @ @
<Print string |cur_exp| as an error message@
>=
31531 mp_snprintf
(msg
, 256, "%s", mp_str
(mp
, cur_exp_str
()));
31532 if
(mp-
>err_help
!= NULL) {
31533 mp-
>use_err_help
= true
;
31534 mp_back_error
(mp
, msg
, NULL, true
);
31535 } else if
(mp-
>long_help_seen
) {
31536 const char
*hlp
[] = { "(That was another `errmessage'.)", NULL };
31537 mp_back_error
(mp
, msg
, hlp
, true
);
31539 const char
*hlp
[] = {
31540 "This error message was generated by an `errmessage'",
31541 "command, so I can\'t give any explicit help.",
31542 "Pretend that you're Miss Marple: Examine all clues,",
31543 "and deduce the truth by inspired guesses.",
31546 if
(mp-
>interaction
< mp_error_stop_mode
)
31547 mp-
>long_help_seen
= true
;
31548 mp_back_error
(mp
, msg
, hlp
, true
);
31550 mp_get_x_next
(mp
);
31551 mp-
>use_err_help
= false
;
31555 @ @
<Declare action procedures for use by |do_statement|@
>=
31556 static void mp_do_write
(MP mp
);
31559 void mp_do_write
(MP mp
) {
31560 mp_string t
; /* the line of text to be written
*/
31561 write_index n
, n0
; /* for searching |wr_fname| and |wr_file| arrays
*/
31562 unsigned old_setting
; /* for saving |selector| during output
*/
31564 memset
(&new_expr,0,sizeof(mp_value));
31565 new_number
(new_expr.data.n
);
31566 mp_get_x_next
(mp
);
31567 mp_scan_expression
(mp
);
31568 if
(mp-
>cur_exp.type
!= mp_string_type
) {
31569 mp_no_string_err
(mp
,
31570 "The text to be written should be a known string expression");
31571 } else if
(cur_cmd
() != mp_to_token
) {
31572 const char
*hlp
[] = { "A write command should end with `to <filename>'", NULL };
31573 mp_back_error
(mp
, "Missing `to' clause", hlp
, true
);
31574 mp_get_x_next
(mp
);
31576 t
= cur_exp_str
();
31577 mp-
>cur_exp.type
= mp_vacuous
;
31578 mp_get_x_next
(mp
);
31579 mp_scan_expression
(mp
);
31580 if
(mp-
>cur_exp.type
!= mp_string_type
)
31581 mp_no_string_err
(mp
,
31582 "I can\'t write to that file name. It isn't a known string");
31584 @
<Write |t| to the file named by |cur_exp|@
>;
31586 /* |delete_str_ref
(t
);|
*//* todo
: is this right?
*/
31588 set_number_to_zero
(new_expr.data.n
);
31589 mp_flush_cur_exp
(mp
, new_expr
);
31593 @ @
<Write |t| to the file named by |cur_exp|@
>=
31595 @
<Find |n| where |wr_fname
[n
]=cur_exp| and call |open_write_file| if
31596 |cur_exp| must be inserted@
>;
31597 if
(mp_str_vs_str
(mp
, t
, mp-
>eof_line
) == 0) {
31598 @
<Record the end of file on |wr_file
[n
]|@
>;
31600 old_setting
= mp-
>selector
;
31601 mp-
>selector
= n
+ write_file
;
31602 mp_print_str
(mp
, t
);
31604 mp-
>selector
= old_setting
;
31609 @ @
<Find |n| where |wr_fname
[n
]=cur_exp| and call |open_write_file| if...@
>=
31611 char
*fn
= mp_str
(mp
, cur_exp_str
());
31612 n
= mp-
>write_files
;
31613 n0
= mp-
>write_files
;
31614 while
(mp_xstrcmp
(fn
, mp-
>wr_fname
[n
]) != 0) {
31615 if
(n
== 0) { /* bottom reached
*/
31616 if
(n0
== mp-
>write_files
) {
31617 if
(mp-
>write_files
< mp-
>max_write_files
) {
31618 incr
(mp-
>write_files
);
31623 l
= mp-
>max_write_files
+ (mp-
>max_write_files
/ 4);
31624 wr_file
= xmalloc
((l
+ 1), sizeof
(void
*));
31625 wr_fname
= xmalloc
((l
+ 1), sizeof
(char
*));
31626 for
(k
= 0; k
<= l
; k
++) {
31627 if
(k
<= mp-
>max_write_files
) {
31628 wr_file
[k
] = mp-
>wr_file
[k
];
31629 wr_fname
[k
] = mp-
>wr_fname
[k
];
31632 wr_fname
[k
] = NULL;
31635 xfree
(mp-
>wr_file
);
31636 xfree
(mp-
>wr_fname
);
31637 mp-
>max_write_files
= l
;
31638 mp-
>wr_file
= wr_file
;
31639 mp-
>wr_fname
= wr_fname
;
31643 mp_open_write_file
(mp
, fn
, n
);
31646 if
(mp-
>wr_fname
[n
] == NULL)
31653 @ @
<Record the end of file on |wr_file
[n
]|@
>=
31655 (mp-
>close_file
) (mp
, mp-
>wr_file
[n
]);
31656 xfree
(mp-
>wr_fname
[n
]);
31657 if
(n
== mp-
>write_files
- 1)
31658 mp-
>write_files
= n
;
31662 @
* Writing font metric data.
31663 \TeX\ gets its knowledge about fonts from font metric files
, also called
31664 \.
{TFM
} files
; the `\.T' in `\.
{TFM
}' stands for \TeX
,
31665 but other programs know about them too. One of \MP's duties is to
31666 write \.
{TFM
} files so that the user's fonts can readily be
31667 applied to typesetting.
31668 @
:TFM files
}{\.
{TFM
} files@
>
31669 @^font metric files@
>
31671 The information in a \.
{TFM
} file appears in a sequence of
8-bit bytes.
31672 Since the number of bytes is always a multiple of~
4, we could
31673 also regard the file as a sequence of
32-bit words
, but \MP\ uses the
31674 byte interpretation. The format of \.
{TFM
} files was designed by
31675 Lyle Ramshaw in
1980. The intent is to convey a lot of different kinds
31676 @^Ramshaw
, Lyle Harold@
>
31677 of information in a compact but useful form.
31680 void
*tfm_file
; /* the font metric output goes here
*/
31681 char
*metric_file_name
; /* full name of the font metric file
*/
31683 @ The first
24 bytes
(6 words
) of a \.
{TFM
} file contain twelve
16-bit
31684 integers that give the lengths of the various subsequent portions
31685 of the file. These twelve integers are
, in order
:
31686 $$\vbox
{\halign
{\hfil#
&$\null=\null$#\hfil\cr
31687 |lf|
&length of the entire file, in words;\cr
31688 |lh|
&length of the header data, in words;\cr
31689 |bc|
&smallest character code in the font;\cr
31690 |ec|
&largest character code in the font;\cr
31691 |nw|
&number of words in the width table;\cr
31692 |nh|
&number of words in the height table;\cr
31693 |nd|
&number of words in the depth table;\cr
31694 |ni|
&number of words in the italic correction table;\cr
31695 |nl|
&number of words in the lig/kern table;\cr
31696 |nk|
&number of words in the kern table;\cr
31697 |ne|
&number of words in the extensible character table;\cr
31698 |np|
&number of font parameter words.\cr}}$$
31699 They are all nonnegative and less than $
2^
{15}$. We must have |bc-1
<=ec
<=255|
,
31701 $$\hbox
{|lf
=6+lh
+(ec-bc
+1)+nw
+nh
+nd
+ni
+nl
+nk
+ne
+np|.
}$$
31702 Note that a font may contain as many as
256 characters
(if |bc
=0| and |ec
=255|
),
31703 and as few as
0 characters
(if |bc
=ec
+1|
).
31705 Incidentally
, when two or more
8-bit bytes are combined to form an integer of
31706 16 or more bits
, the most significant bytes appear first in the file.
31707 This is called BigEndian order.
31708 @^BigEndian order@
>
31710 @ The rest of the \.
{TFM
} file may be regarded as a sequence of ten data
31713 The most important data type used here is a |fix_word|
, which is
31714 a
32-bit representation of a binary fraction. A |fix_word| is a signed
31715 quantity
, with the two's complement of the entire word used to represent
31716 negation. Of the
32 bits in a |fix_word|
, exactly
12 are to the left of the
31717 binary point
; thus
, the largest |fix_word| value is $
2048-2^
{-20}$
, and
31718 the smallest is $
-2048$. We will see below
, however
, that all but two of
31719 the |fix_word| values must lie between $
-16$ and $
+16$.
31721 @ The first data array is a block of header information
, which contains
31722 general facts about the font. The header must contain at least two words
,
31723 |header
[0]| and |header
[1]|
, whose meaning is explained below. Additional
31724 header information of use to other software routines might also be
31725 included
, and \MP\ will generate it if the \.
{headerbyte
} command occurs.
31726 For example
, 16 more words of header information are in use at the Xerox
31727 Palo Alto Research Center
; the first ten specify the character coding
31728 scheme used
(e.g.
, `\.
{XEROX
TEXT}' or `\.
{TEX MATHSY
}'
), the next five
31729 give the font family name
(e.g.
, `\.
{HELVETICA
}' or `\.
{CMSY
}'
), and the
31730 last gives the ``face byte.''
31732 \yskip\hang|header
[0]| is a
32-bit check sum that \MP\ will copy into
31733 the \.
{GF
} output file. This helps ensure consistency between files
,
31734 since \TeX\ records the check sums from the \.
{TFM
}'s it reads
, and these
31735 should match the check sums on actual fonts that are used. The actual
31736 relation between this check sum and the rest of the \.
{TFM
} file is not
31737 important
; the check sum is simply an identification number with the
31738 property that incompatible fonts almost always have distinct check sums.
31741 \yskip\hang|header
[1]| is a |fix_word| containing the design size of the
31742 font
, in units of \TeX\ points. This number must be at least
1.0; it is
31743 fairly arbitrary
, but usually the design size is
10.0 for a ``
10 point''
31744 font
, i.e.
, a font that was designed to look best at a
10-point size
,
31745 whatever that really means. When a \TeX\ user asks for a font `\.
{at
}
31746 $\delta$ \.
{pt
}'
, the effect is to override the design size and replace it
31747 by $\delta$
, and to multiply the $x$ and~$y$ coordinates of the points in
31748 the font image by a factor of $\delta$ divided by the design size.
{\sl
31749 All other dimensions in the\
/ \.
{TFM
} file are |fix_word|\kern-1pt\
31750 numbers in design-size units.
} Thus
, for example
, the value of |param
[6]|
,
31751 which defines the \.
{em
} unit
, is often the |fix_word| value $
2^
{20}=1.0$
,
31752 since many fonts have a design size equal to one em. The other dimensions
31753 must be less than
16 design-size units in absolute value
; thus
,
31754 |header
[1]| and |param
[1]| are the only |fix_word| entries in the whole
31755 \.
{TFM
} file whose first byte might be something besides
0 or
255.
31758 @ Next comes the |char_info| array
, which contains one |char_info_word|
31759 per character. Each word in this part of the file contains six fields
31760 packed into four bytes as follows.
31762 \yskip\hang first byte
: |width_index|
(8 bits
)\par
31763 \hang second byte
: |height_index|
(4 bits
) times
16, plus |depth_index|
31765 \hang third byte
: |italic_index|
(6 bits
) times
4, plus |tag|
31767 \hang fourth byte
: |remainder|
(8 bits
)\par
31769 The actual width of a character is \\
{width
}|
[width_index
]|
, in design-size
31770 units
; this is a device for compressing information
, since many characters
31771 have the same width. Since it is quite common for many characters
31772 to have the same height
, depth
, or italic correction
, the \.
{TFM
} format
31773 imposes a limit of
16 different heights
, 16 different depths
, and
31774 64 different italic corrections.
31776 Incidentally
, the relation $\\
{width
}[0]=\\
{height
}[0]=\\
{depth
}[0]=
31777 \\
{italic
}[0]=0$ should always hold
, so that an index of zero implies a
31778 value of zero. The |width_index| should never be zero unless the
31779 character does not exist in the font
, since a character is valid if and
31780 only if it lies between |bc| and |ec| and has a nonzero |width_index|.
31782 @ The |tag| field in a |char_info_word| has four values that explain how to
31783 interpret the |remainder| field.
31785 \yskip\hang|tag
=0|
(|no_tag|
) means that |remainder| is unused.\par
31786 \hang|tag
=1|
(|lig_tag|
) means that this character has a ligature
/kerning
31787 program starting at location |remainder| in the |lig_kern| array.\par
31788 \hang|tag
=2|
(|list_tag|
) means that this character is part of a chain of
31789 characters of ascending sizes
, and not the largest in the chain. The
31790 |remainder| field gives the character code of the next larger character.\par
31791 \hang|tag
=3|
(|ext_tag|
) means that this character code represents an
31792 extensible character
, i.e.
, a character that is built up of smaller pieces
31793 so that it can be made arbitrarily large. The pieces are specified in
31794 |exten
[remainder
]|.\par
31796 Characters with |tag
=2| and |tag
=3| are treated as characters with |tag
=0|
31797 unless they are used in special circumstances in math formulas. For example
,
31798 \TeX's \.
{\\sum
} operation looks for a |list_tag|
, and the \.
{\\left
}
31799 operation looks for both |list_tag| and |ext_tag|.
31801 @d no_tag
0 /* vanilla character
*/
31802 @d lig_tag
1 /* character has a ligature
/kerning program
*/
31803 @d list_tag
2 /* character has a successor in a charlist
*/
31804 @d ext_tag
3 /* character is extensible
*/
31806 @ The |lig_kern| array contains instructions in a simple programming language
31807 that explains what to do for special letter pairs. Each word in this array is a
31808 |lig_kern_command| of four bytes.
31810 \yskip\hang first byte
: |skip_byte|
, indicates that this is the final program
31811 step if the byte is
128 or more
, otherwise the next step is obtained by
31812 skipping this number of intervening steps.\par
31813 \hang second byte
: |next_char|
, ``if |next_char| follows the current character
,
31814 then perform the operation and stop
, otherwise continue.''\par
31815 \hang third byte
: |op_byte|
, indicates a ligature step if less than
~128,
31816 a kern step otherwise.\par
31817 \hang fourth byte
: |remainder|.\par
31820 additional space equal to |kern
[256*(op_byte-128
)+remainder
]| is inserted
31821 between the current character and |next_char|. This amount is
31822 often negative
, so that the characters are brought closer together
31823 by kerning
; but it might be positive.
31825 There are eight kinds of ligature steps
, having |op_byte| codes $
4a
+2b
+c$ where
31826 $
0\le a\le b
+c$ and $
0\le b
,c\le1$. The character whose code is
31827 |remainder| is inserted between the current character and |next_char|
;
31828 then the current character is deleted if $b
=0$
, and |next_char| is
31829 deleted if $c
=0$
; then we pass over $a$~characters to reach the next
31830 current character
(which may have a ligature
/kerning program of its own
).
31832 If the very first instruction of the |lig_kern| array has |skip_byte
=255|
,
31833 the |next_char| byte is the so-called right boundary character of this font
;
31834 the value of |next_char| need not lie between |bc| and~|ec|.
31835 If the very last instruction of the |lig_kern| array has |skip_byte
=255|
,
31836 there is a special ligature
/kerning program for a left boundary character
,
31837 beginning at location |
256*op_byte
+remainder|.
31838 The interpretation is that \TeX\ puts implicit boundary characters
31839 before and after each consecutive string of characters from the same font.
31840 These implicit characters do not appear in the output
, but they can affect
31841 ligatures and kerning.
31843 If the very first instruction of a character's |lig_kern| program has
31844 |skip_byte
>128|
, the program actually begins in location
31845 |
256*op_byte
+remainder|. This feature allows access to large |lig_kern|
31846 arrays
, because the first instruction must otherwise
31847 appear in a location |
<=255|.
31849 Any instruction with |skip_byte
>128| in the |lig_kern| array must satisfy
31851 $$\hbox
{|
256*op_byte
+remainder
<nl|.
}$$
31852 If such an instruction is encountered during
31853 normal program execution
, it denotes an unconditional halt
; no ligature
31854 command is performed.
31857 /* value indicating `\.
{STOP}' in a lig
/kern program
*/
31858 @d kern_flag
(128) /* op code for a kern step
*/
31859 @d skip_byte
(A
) mp-
>lig_kern
[(A
)].b0
31860 @d next_char
(A
) mp-
>lig_kern
[(A
)].b1
31861 @d op_byte
(A
) mp-
>lig_kern
[(A
)].b2
31862 @d rem_byte
(A
) mp-
>lig_kern
[(A
)].b3
31864 @ Extensible characters are specified by an |extensible_recipe|
, which
31865 consists of four bytes called |top|
, |mid|
, |bot|
, and |rep|
(in this
31866 order
). These bytes are the character codes of individual pieces used to
31867 build up a large symbol. If |top|
, |mid|
, or |bot| are zero
, they are not
31868 present in the built-up result. For example
, an extensible vertical line is
31869 like an extensible bracket
, except that the top and bottom pieces are missing.
31871 Let $T$
, $M$
, $B$
, and $R$ denote the respective pieces
, or an empty box
31872 if the piece isn't present. Then the extensible characters have the form
31873 $TR^kMR^kB$ from top to bottom
, for some |k
>=0|
, unless $M$ is absent
;
31874 in the latter case we can have $TR^kB$ for both even and odd values of~|k|.
31875 The width of the extensible character is the width of $R$
; and the
31876 height-plus-depth is the sum of the individual height-plus-depths of the
31877 components used
, since the pieces are butted together in a vertical list.
31879 @d ext_top
(A
) mp-
>exten
[(A
)].b0
/* |top| piece in a recipe
*/
31880 @d ext_mid
(A
) mp-
>exten
[(A
)].b1
/* |mid| piece in a recipe
*/
31881 @d ext_bot
(A
) mp-
>exten
[(A
)].b2
/* |bot| piece in a recipe
*/
31882 @d ext_rep
(A
) mp-
>exten
[(A
)].b3
/* |rep| piece in a recipe
*/
31884 @ The final portion of a \.
{TFM
} file is the |param| array
, which is another
31885 sequence of |fix_word| values.
31887 \yskip\hang|param
[1]=slant| is the amount of italic slant
, which is used
31888 to help position accents. For example
, |slant
=.25| means that when you go
31889 up one unit
, you also go
.25 units to the right. The |slant| is a pure
31890 number
; it is the only |fix_word| other than the design size itself that is
31891 not scaled by the design size.
31894 \hang|param
[2]=space| is the normal spacing between words in text.
31895 Note that character
040 in the font need not have anything to do with
31898 \hang|param
[3]=space_stretch| is the amount of glue stretching between words.
31900 \hang|param
[4]=space_shrink| is the amount of glue shrinking between words.
31902 \hang|param
[5]=x_height| is the size of one ex in the font
; it is also
31903 the height of letters for which accents don't have to be raised or lowered.
31905 \hang|param
[6]=quad| is the size of one em in the font.
31907 \hang|param
[7]=extra_space| is the amount added to |param
[2]| at the
31911 If fewer than seven parameters are present
, \TeX\ sets the missing parameters
31916 @d space_stretch_code
3
31917 @d space_shrink_code
4
31920 @d extra_space_code
7
31922 @ So that is what \.
{TFM
} files hold. One of \MP's duties is to output such
31923 information
, and it does this all at once at the end of a job.
31924 In order to prepare for such frenetic activity
, it squirrels away the
31925 necessary facts in various arrays as information becomes available.
31927 Character dimensions
(\
&{charwd}, \&{charht}, \&{chardp}, and \&{charic})
31928 are stored respectively in |tfm_width|
, |tfm_height|
, |tfm_depth|
, and
31929 |tfm_ital_corr|. Other information about a character
(e.g.
, about
31930 its ligatures or successors
) is accessible via the |char_tag| and
31931 |char_remainder| arrays. Other information about the font as a whole
31932 is kept in additional arrays called |header_byte|
, |lig_kern|
,
31933 |kern|
, |exten|
, and |param|.
31935 @d max_tfm_int
32510
31936 @d undefined_label max_tfm_int
/* an undefined local label
*/
31939 #define TFM_ITEMS
257
31941 eight_bits ec
; /* smallest and largest character codes shipped out
*/
31942 mp_node tfm_width
[TFM_ITEMS
]; /* \
&{charwd} values */
31943 mp_node tfm_height
[TFM_ITEMS
]; /* \
&{charht} values */
31944 mp_node tfm_depth
[TFM_ITEMS
]; /* \
&{chardp} values */
31945 mp_node tfm_ital_corr
[TFM_ITEMS
]; /* \
&{charic} values */
31946 boolean char_exists
[TFM_ITEMS
]; /* has this code been shipped out?
*/
31947 int char_tag
[TFM_ITEMS
]; /* |remainder| category
*/
31948 int char_remainder
[TFM_ITEMS
]; /* the |remainder| byte
*/
31949 char
*header_byte
; /* bytes of the \.
{TFM
} header
*/
31950 int header_last
; /* last initialized \.
{TFM
} header byte
*/
31951 int header_size
; /* size of the \.
{TFM
} header
*/
31952 four_quarters
*lig_kern
; /* the ligature
/kern table
*/
31953 short nl
; /* the number of ligature
/kern steps so far
*/
31954 mp_number
*kern
; /* distinct kerning amounts
*/
31955 short nk
; /* the number of distinct kerns so far
*/
31956 four_quarters exten
[TFM_ITEMS
]; /* extensible character recipes
*/
31957 short ne
; /* the number of extensible characters so far
*/
31958 mp_number
*param
; /* \
&{fontinfo} parameters */
31959 short np
; /* the largest \
&{fontinfo} parameter specified so far */
31963 short ni
; /* sizes of \.
{TFM
} subtables
*/
31964 short skip_table
[TFM_ITEMS
]; /* local label status
*/
31965 boolean lk_started
; /* has there been a lig
/kern step in this command yet?
*/
31966 integer bchar
; /* right boundary character
*/
31967 short bch_label
; /* left boundary starting location
*/
31969 short lll
; /* registers used for lig
/kern processing
*/
31970 short label_loc
[257]; /* lig
/kern starting addresses
*/
31971 eight_bits label_char
[257]; /* characters for |label_loc|
*/
31972 short label_ptr
; /* highest position occupied in |label_loc|
*/
31974 @ @
<Allocate or initialize ...@
>=
31975 mp-
>header_last
= 7;
31976 mp-
>header_size
= 128; /* just for init
*/
31977 mp-
>header_byte
= xmalloc
(mp-
>header_size
, sizeof
(char
));
31979 @ @
<Dealloc variables@
>=
31980 xfree
(mp-
>header_byte
);
31981 xfree
(mp-
>lig_kern
);
31984 for
(i
=0;i
<(max_tfm_int
+ 1);i
++) {
31985 free_number
(mp-
>kern
[i
]);
31991 for
(i
=0;i
<(max_tfm_int
+ 1);i
++) {
31992 free_number
(mp-
>param
[i
]);
31998 for
(k
= 0; k
<= 255; k
++) {
31999 mp-
>tfm_width
[k
] = 0;
32000 mp-
>tfm_height
[k
] = 0;
32001 mp-
>tfm_depth
[k
] = 0;
32002 mp-
>tfm_ital_corr
[k
] = 0;
32003 mp-
>char_exists
[k
] = false
;
32004 mp-
>char_tag
[k
] = no_tag
;
32005 mp-
>char_remainder
[k
] = 0;
32006 mp-
>skip_table
[k
] = undefined_label
;
32008 memset
(mp-
>header_byte
, 0, (size_t
) mp-
>header_size
);
32015 set_internal_from_number
(mp_boundary_char
, unity_t
);
32016 number_negate
(internal_value
(mp_boundary_char
));
32017 mp-
>bch_label
= undefined_label
;
32018 mp-
>label_loc
[0] = -1;
32021 @ @
<Declarations@
>=
32022 static mp_node mp_tfm_check
(MP mp
, quarterword m
);
32025 static mp_node mp_tfm_check
(MP mp
, quarterword m
) {
32027 mp_node p
= mp_get_value_node
(mp
);
32029 number_clone
(absm
, internal_value
(m
));
32031 if
(number_greaterequal
(absm
, fraction_half_t
)) {
32033 const char
*hlp
[] = {
32034 "Font metric dimensions must be less than 2048pt.",
32036 mp_snprintf
(msg
, 256, "Enormous %s has been reduced", internal_name
(m
));
32037 @.Enormous charwd...@
>
32038 @.Enormous chardp...@
>
32039 @.Enormous charht...@
>
32040 @.Enormous charic...@
>
32041 @.Enormous designsize...@
>;
32042 mp_back_error
(mp
, msg
, hlp
, true
);
32043 mp_get_x_next
(mp
);
32044 if
(number_positive
(internal_value
(m
))) {
32045 set_value_number
(p
, fraction_half_t
);
32046 number_add_scaled
(value_number
(p
), -1);
32048 set_value_number
(p
, fraction_half_t
);
32049 number_negate
(value_number
(p
));
32050 number_add_scaled
(value_number
(p
), 1);
32053 set_value_number
(p
, internal_value
(m
));
32055 free_number
(absm
);
32059 @ @
<Store the width information for character code~|c|@
>=
32061 mp-
>bc
= (eight_bits
) c
;
32063 mp-
>ec
= (eight_bits
) c
;
32064 mp-
>char_exists
[c
] = true
;
32065 mp_free_value_node
(mp
, mp-
>tfm_width
[c
]);
32066 mp-
>tfm_width
[c
] = mp_tfm_check
(mp
, mp_char_wd
);
32067 mp_free_value_node
(mp
, mp-
>tfm_height
[c
]);
32068 mp-
>tfm_height
[c
] = mp_tfm_check
(mp
, mp_char_ht
);
32069 mp_free_value_node
(mp
, mp-
>tfm_depth
[c
]);
32070 mp-
>tfm_depth
[c
] = mp_tfm_check
(mp
, mp_char_dp
);
32071 mp_free_value_node
(mp
, mp-
>tfm_ital_corr
[c
]);
32072 mp-
>tfm_ital_corr
[c
] = mp_tfm_check
(mp
, mp_char_ic
)
32075 @ Now let's consider \MP's special \.
{TFM
}-oriented commands.
32078 @ @d char_list_code
0
32079 @d lig_table_code
1
32080 @d extensible_code
2
32081 @d header_byte_code
3
32082 @d font_dimen_code
4
32085 mp_primitive
(mp
, "charlist", mp_tfm_command
, char_list_code
);
32086 @
:char_list_
}{\
&{charlist} primitive@>;
32087 mp_primitive
(mp
, "ligtable", mp_tfm_command
, lig_table_code
);
32088 @
:lig_table_
}{\
&{ligtable} primitive@>;
32089 mp_primitive
(mp
, "extensible", mp_tfm_command
, extensible_code
);
32090 @
:extensible_
}{\
&{extensible} primitive@>;
32091 mp_primitive
(mp
, "headerbyte", mp_tfm_command
, header_byte_code
);
32092 @
:header_byte_
}{\
&{headerbyte} primitive@>;
32093 mp_primitive
(mp
, "fontdimen", mp_tfm_command
, font_dimen_code
);
32094 @
:font_dimen_
}{\
&{fontdimen} primitive@>
32097 @ @
<Cases of |print_cmd...@
>=
32098 case mp_tfm_command
:
32100 case char_list_code
:
32101 mp_print
(mp
, "charlist");
32103 case lig_table_code
:
32104 mp_print
(mp
, "ligtable");
32106 case extensible_code
:
32107 mp_print
(mp
, "extensible");
32109 case header_byte_code
:
32110 mp_print
(mp
, "headerbyte");
32113 mp_print
(mp
, "fontdimen");
32118 @ @
<Declare action procedures for use by |do_statement|@
>=
32119 static eight_bits mp_get_code
(MP mp
);
32122 eight_bits mp_get_code
(MP mp
) { /* scans a character code value
*/
32123 integer c
; /* the code value found
*/
32125 const char
*hlp
[] = {
32126 "I was looking for a number between 0 and 255, or for a",
32127 "string of length 1. Didn't find it; will use 0 instead.",
32129 memset
(&new_expr,0,sizeof(mp_value));
32130 new_number
(new_expr.data.n
);
32131 mp_get_x_next
(mp
);
32132 mp_scan_expression
(mp
);
32133 if
(mp-
>cur_exp.type
== mp_known
) {
32134 c
= round_unscaled
(cur_exp_value_number
());
32137 return
(eight_bits
) c
;
32138 } else if
(mp-
>cur_exp.type
== mp_string_type
) {
32139 if
(cur_exp_str
()->len
== 1) {
32140 c
= (integer
) (*(cur_exp_str
()->str
));
32141 return
(eight_bits
) c
;
32144 mp_disp_err
(mp
, NULL);
32145 set_number_to_zero
(new_expr.data.n
);
32146 mp_back_error
(mp
, "Invalid code has been replaced by 0", hlp
, true
);
32147 @.Invalid code...@
>;
32148 mp_get_x_next
(mp
);
32149 mp_flush_cur_exp
(mp
, new_expr
);
32151 return
(eight_bits
) c
;
32155 @ @
<Declare action procedures for use by |do_statement|@
>=
32156 static void mp_set_tag
(MP mp
, halfword c
, quarterword t
, halfword r
);
32159 void mp_set_tag
(MP mp
, halfword c
, quarterword t
, halfword r
) {
32160 if
(mp-
>char_tag
[c
] == no_tag
) {
32161 mp-
>char_tag
[c
] = t
;
32162 mp-
>char_remainder
[c
] = r
;
32163 if
(t
== lig_tag
) {
32165 mp-
>label_loc
[mp-
>label_ptr
] = (short
) r
;
32166 mp-
>label_char
[mp-
>label_ptr
] = (eight_bits
) c
;
32169 @
<Complain about a character tag conflict@
>;
32174 @ @
<Complain about a character tag conflict@
>=
32176 const char
*xtra
= NULL;
32178 const char
*hlp
[] = {
32179 "It's not legal to label a character more than once.",
32180 "So I'll not change anything just now.",
32182 switch
(mp-
>char_tag
[c
]) {
32183 case lig_tag
: xtra
= "in a ligtable"; break
;
32184 case list_tag
: xtra
= "in a charlist"; break
;
32185 case ext_tag
: xtra
= "extensible"; break
;
32186 default
: xtra
= ""; break
;
32188 if
((c
> ' '
) && (c < 127)) {
32189 mp_snprintf
(msg
, 256, "Character %c is already %s", xord
(c
), xtra
);
32190 } else if
(c
== 256) {
32191 mp_snprintf
(msg
, 256, "Character || is already %s", xtra
);
32193 mp_snprintf
(msg
, 256, "Character code %d is already %s", c
, xtra
);
32195 @.Character c is already...@
>;
32196 mp_back_error
(mp
, msg
, hlp
, true
);
32197 mp_get_x_next
(mp
);
32201 @ @
<Declare action procedures for use by |do_statement|@
>=
32202 static void mp_do_tfm_command
(MP mp
);
32205 void mp_do_tfm_command
(MP mp
) {
32206 int c
, cc
; /* character codes
*/
32207 int k
; /* index into the |kern| array
*/
32208 int j
; /* index into |header_byte| or |param|
*/
32210 memset
(&new_expr,0,sizeof(mp_value));
32211 new_number
(new_expr.data.n
);
32212 switch
(cur_mod
()) {
32213 case char_list_code
:
32214 c
= mp_get_code
(mp
);
32215 /* we will store a list of character successors
*/
32216 while
(cur_cmd
() == mp_colon
) {
32217 cc
= mp_get_code
(mp
);
32218 mp_set_tag
(mp
, c
, list_tag
, cc
);
32222 case lig_table_code
:
32223 if
(mp-
>lig_kern
== NULL)
32224 mp-
>lig_kern
= xmalloc
((max_tfm_int
+ 1), sizeof
(four_quarters
));
32225 if
(mp-
>kern
== NULL) {
32227 mp-
>kern
= xmalloc
((max_tfm_int
+ 1), sizeof
(mp_number
));
32228 for
(i
=0;i
<(max_tfm_int
+ 1);i
++)
32229 new_number
(mp-
>kern
[i
]);
32231 @
<Store a list of ligature
/kern steps@
>;
32233 case extensible_code
:
32234 @
<Define an extensible recipe@
>;
32236 case header_byte_code
:
32237 case font_dimen_code
:
32239 mp_get_x_next
(mp
);
32240 mp_scan_expression
(mp
);
32241 if
((mp-
>cur_exp.type
!= mp_known
) || number_less
(cur_exp_value_number
(), half_unit_t
)) {
32242 const char
*hlp
[] = {
32243 "I was looking for a known, positive number.",
32244 "For safety's sake I'll ignore the present command.",
32246 mp_disp_err
(mp
, NULL);
32247 mp_back_error
(mp
, "Improper location", hlp
, true
);
32248 @.Improper location@
>;
32249 mp_get_x_next
(mp
);
32251 j
= round_unscaled
(cur_exp_value_number
());
32252 if
(cur_cmd
() != mp_colon
) {
32253 const char
*hlp
[] = {
32254 "A colon should follow a headerbyte or fontinfo location.",
32256 mp_back_error
(mp
, "Missing `:' has been inserted", hlp
, true
);
32259 if
(c
== header_byte_code
) {
32260 @
<Store a list of header bytes@
>;
32262 if
(mp-
>param
== NULL) {
32264 mp-
>param
= xmalloc
((max_tfm_int
+ 1), sizeof
(mp_number
));
32265 for
(i
=0;i
<(max_tfm_int
+ 1);i
++)
32266 new_number
(mp-
>param
[i
]);
32268 @
<Store a list of font dimensions@
>;
32272 } /* there are no other cases
*/
32276 @ @
<Store a list of ligature
/kern steps@
>=
32278 mp-
>lk_started
= false
;
32280 mp_get_x_next
(mp
);
32281 if
((cur_cmd
() == mp_skip_to
) && mp->lk_started)
32282 @
<Process a |skip_to| command and |goto done|@
>;
32283 if
(cur_cmd
() == mp_bchar_label
) {
32285 set_cur_cmd
((mp_variable_type
)mp_colon
);
32287 mp_back_input
(mp
);
32288 c
= mp_get_code
(mp
);
32290 if
((cur_cmd
() == mp_colon
) ||
(cur_cmd
() == mp_double_colon
)) {
32291 @
<Record a label in a lig
/kern subprogram and |goto continue|@
>;
32293 if
(cur_cmd
() == mp_lig_kern_token
) {
32294 @
<Compile a ligature
/kern command@
>;
32296 const char
*hlp
[] = { "I was looking for `=:' or `kern' here.", NULL };
32297 mp_back_error
(mp
, "Illegal ligtable step", hlp
, true
);
32298 @.Illegal ligtable step@
>;
32299 next_char
(mp-
>nl
) = qi
(0);
32300 op_byte
(mp-
>nl
) = qi
(0);
32301 rem_byte
(mp-
>nl
) = qi
(0);
32302 skip_byte
(mp-
>nl
) = stop_flag
+ 1; /* this specifies an unconditional stop
*/
32304 if
(mp-
>nl
== max_tfm_int
)
32305 mp_fatal_error
(mp
, "ligtable too large");
32307 if
(cur_cmd
() == mp_comma
)
32309 if
(skip_byte
(mp-
>nl
- 1) < stop_flag
)
32310 skip_byte
(mp-
>nl
- 1) = stop_flag
;
32315 mp_primitive
(mp
, "=:", mp_lig_kern_token
, 0);
32316 @
:=:_
}{\.
{=:} primitive@
>;
32317 mp_primitive
(mp
, "=:|", mp_lig_kern_token
, 1);
32318 @
:=:/_
}{\.
{=:\char'
174} primitive@
>;
32319 mp_primitive
(mp
, "=:|>", mp_lig_kern_token
, 5);
32320 @
:=:/>_
}{\.
{=:\char'
174>} primitive@
>;
32321 mp_primitive
(mp
, "|=:", mp_lig_kern_token
, 2);
32322 @
:=:/_
}{\.
{\char'
174=:} primitive@
>;
32323 mp_primitive
(mp
, "|=:>", mp_lig_kern_token
, 6);
32324 @
:=:/>_
}{\.
{\char'
174=:>} primitive@
>;
32325 mp_primitive
(mp
, "|=:|", mp_lig_kern_token
, 3);
32326 @
:=:/_
}{\.
{\char'
174=:\char'
174} primitive@
>;
32327 mp_primitive
(mp
, "|=:|>", mp_lig_kern_token
, 7);
32328 @
:=:/>_
}{\.
{\char'
174=:\char'
174>} primitive@
>;
32329 mp_primitive
(mp
, "|=:|>>", mp_lig_kern_token
, 11);
32330 @
:=:/>_
}{\.
{\char'
174=:\char'
174>>} primitive@
>;
32331 mp_primitive
(mp
, "kern", mp_lig_kern_token
, mp_kern_flag
);
32332 @
:kern_
}{\
&{kern} primitive@>
32335 @ @
<Cases of |print_cmd...@
>=
32336 case mp_lig_kern_token
:
32339 mp_print
(mp
, "=:");
32342 mp_print
(mp
, "=:|");
32345 mp_print
(mp
, "|=:");
32348 mp_print
(mp
, "|=:|");
32351 mp_print
(mp
, "=:|>");
32354 mp_print
(mp
, "|=:>");
32357 mp_print
(mp
, "|=:|>");
32360 mp_print
(mp
, "|=:|>>");
32363 mp_print
(mp
, "kern");
32368 @ Local labels are implemented by maintaining the |skip_table| array
,
32369 where |skip_table
[c
]| is either |undefined_label| or the address of the
32370 most recent lig
/kern instruction that skips to local label~|c|. In the
32371 latter case
, the |skip_byte| in that instruction will
(temporarily
)
32372 be zero if there were no prior skips to this label
, or it will be the
32373 distance to the prior skip.
32375 We may need to cancel skips that span more than
127 lig
/kern steps.
32377 @d cancel_skips
(A
) mp-
>ll
=(A
);
32379 mp-
>lll
=qo
(skip_byte
(mp-
>ll
));
32380 skip_byte
(mp-
>ll
)=stop_flag
; mp-
>ll
=(short
)(mp-
>ll-mp-
>lll
);
32381 } while
(mp-
>lll
!=0)
32384 const char
*hlp
[] = { "At most 127 lig/kern steps can separate skipto1 from 1::.", NULL};
32385 mp_error
(mp
, "Too far to skip", hlp
, true
);
32386 @.Too far to skip@
>
32390 @
<Process a |skip_to| command and |goto done|@
>=
32392 c
= mp_get_code
(mp
);
32393 if
(mp-
>nl
- mp-
>skip_table
[c
] > 128) {
32394 skip_error
(mp-
>skip_table
[c
]);
32395 mp-
>skip_table
[c
] = (short
) undefined_label
;
32397 if
(mp-
>skip_table
[c
] == undefined_label
)
32398 skip_byte
(mp-
>nl
- 1) = qi
(0);
32400 skip_byte
(mp-
>nl
- 1) = qi
(mp-
>nl
- mp-
>skip_table
[c
] - 1);
32401 mp-
>skip_table
[c
] = (short
) (mp-
>nl
- 1);
32406 @ @
<Record a label in a lig
/kern subprogram and |goto continue|@
>=
32408 if
(cur_cmd
() == mp_colon
) {
32410 mp-
>bch_label
= mp-
>nl
;
32412 mp_set_tag
(mp
, c
, lig_tag
, mp-
>nl
);
32413 } else if
(mp-
>skip_table
[c
] < undefined_label
) {
32414 mp-
>ll
= mp-
>skip_table
[c
];
32415 mp-
>skip_table
[c
] = undefined_label
;
32417 mp-
>lll
= qo
(skip_byte
(mp-
>ll
));
32418 if
(mp-
>nl
- mp-
>ll
> 128) {
32419 skip_error
(mp-
>ll
);
32422 skip_byte
(mp-
>ll
) = qi
(mp-
>nl
- mp-
>ll
- 1);
32423 mp-
>ll
= (short
) (mp-
>ll
- mp-
>lll
);
32424 } while
(mp-
>lll
!= 0);
32430 @ @
<Compile a ligature
/kern...@
>=
32432 next_char
(mp-
>nl
) = qi
(c
);
32433 skip_byte
(mp-
>nl
) = qi
(0);
32434 if
(cur_mod
() < 128) { /* ligature op
*/
32435 op_byte
(mp-
>nl
) = qi
(cur_mod
());
32436 rem_byte
(mp-
>nl
) = qi
(mp_get_code
(mp
));
32438 mp_get_x_next
(mp
);
32439 mp_scan_expression
(mp
);
32440 if
(mp-
>cur_exp.type
!= mp_known
) {
32441 const char
*hlp
[] = {
32442 "The amount of kern should be a known numeric value.",
32443 "I'm zeroing this one. Proceed, with fingers crossed.",
32445 mp_disp_err
(mp
, NULL);
32446 set_number_to_zero
(new_expr.data.n
);
32447 mp_back_error
(mp
, "Improper kern", hlp
, true
);
32449 mp_get_x_next
(mp
);
32450 mp_flush_cur_exp
(mp
, new_expr
);
32452 number_clone
(mp-
>kern
[mp-
>nk
], cur_exp_value_number
());
32454 while
(!number_equal
(mp-
>kern
[k
], cur_exp_value_number
()))
32457 if
(mp-
>nk
== max_tfm_int
)
32458 mp_fatal_error
(mp
, "too many TFM kerns");
32461 op_byte
(mp-
>nl
) = qi
(kern_flag
+ (k
/ 256));
32462 rem_byte
(mp-
>nl
) = qi
((k
% 256));
32464 mp-
>lk_started
= true
;
32468 @ @d missing_extensible_punctuation
(A
)
32471 const char
*hlp
[] = { "I'm processing `extensible c: t,m,b,r'.", NULL };
32472 mp_snprintf
(msg
, 256, "Missing %s has been inserted", (A
));
32473 mp_back_error
(mp
, msg
, hlp
, true
);
32474 @.Missing `\char`\#'@
>
32477 @
<Define an extensible recipe@
>=
32480 mp_fatal_error
(mp
, "too many extensible recipies");
32481 c
= mp_get_code
(mp
);
32482 mp_set_tag
(mp
, c
, ext_tag
, mp-
>ne
);
32483 if
(cur_cmd
() != mp_colon
)
32484 missing_extensible_punctuation
(":");
32485 ext_top
(mp-
>ne
) = qi
(mp_get_code
(mp
));
32486 if
(cur_cmd
() != mp_comma
)
32487 missing_extensible_punctuation
(",");
32488 ext_mid
(mp-
>ne
) = qi
(mp_get_code
(mp
));
32489 if
(cur_cmd
() != mp_comma
)
32490 missing_extensible_punctuation
(",");
32491 ext_bot
(mp-
>ne
) = qi
(mp_get_code
(mp
));
32492 if
(cur_cmd
() != mp_comma
)
32493 missing_extensible_punctuation
(",");
32494 ext_rep
(mp-
>ne
) = qi
(mp_get_code
(mp
));
32499 @ The header could contain ASCII zeroes
, so can't use |strdup|.
32501 @
<Store a list of header bytes@
>=
32504 if
(j
>= mp-
>header_size
) {
32505 size_t l
= (size_t
) (mp-
>header_size
+ (mp-
>header_size
/ 4));
32506 char
*t
= xmalloc
(l
, 1);
32508 (void
) memcpy
(t
, mp-
>header_byte
, (size_t
) mp-
>header_size
);
32509 xfree
(mp-
>header_byte
);
32510 mp-
>header_byte
= t
;
32511 mp-
>header_size
= (int
) l
;
32513 mp-
>header_byte
[j
] = (char
) mp_get_code
(mp
);
32515 incr
(mp-
>header_last
);
32516 } while
(cur_cmd
() == mp_comma
)
32518 @ @
<Store a list of font dimensions@
>=
32520 if
(j
> max_tfm_int
)
32521 mp_fatal_error
(mp
, "too many fontdimens");
32522 while
(j
> mp-
>np
) {
32524 set_number_to_zero
(mp-
>param
[mp-
>np
]);
32526 mp_get_x_next
(mp
);
32527 mp_scan_expression
(mp
);
32528 if
(mp-
>cur_exp.type
!= mp_known
) {
32529 const char
*hlp
[] = { "I'm zeroing this one. Proceed, with fingers crossed.", NULL };
32530 mp_disp_err
(mp
, NULL);
32531 set_number_to_zero
(new_expr.data.n
);
32532 mp_back_error
(mp
, "Improper font parameter", hlp
, true
);
32533 @.Improper font parameter@
>;
32534 mp_get_x_next
(mp
);
32535 mp_flush_cur_exp
(mp
, new_expr
);
32537 number_clone
(mp-
>param
[j
], cur_exp_value_number
());
32539 } while
(cur_cmd
() == mp_comma
)
32541 @
OK: We've stored all the data that is needed for the \.
{TFM
} file.
32542 All that remains is to output it in the correct format.
32544 An interesting problem needs to be solved in this connection
, because
32545 the \.
{TFM
} format allows at most
256~widths
, 16~heights
, 16~depths
,
32546 and
64~italic corrections. If the data has more distinct values than
32547 this
, we want to meet the necessary restrictions by perturbing the
32548 given values as little as possible.
32550 \MP\ solves this problem in two steps. First the values of a given
32551 kind
(widths
, heights
, depths
, or italic corrections
) are sorted
;
32552 then the list of sorted values is perturbed
, if necessary.
32554 The sorting operation is facilitated by having a special node of
32555 essentially infinite |value| at the end of the current list.
32557 @
<Initialize table entries@
>=
32558 mp-
>inf_val
= mp_get_value_node
(mp
);
32559 set_value_number
(mp-
>inf_val
, fraction_four_t
);
32561 @ @
<Free table entries@
>=
32562 mp_free_value_node
(mp
, mp-
>inf_val
);
32564 @ Straight linear insertion is good enough for sorting
, since the lists
32565 are usually not terribly long. As we work on the data
, the current list
32566 will start at |mp_link
(temp_head
)| and end at |inf_val|
; the nodes in this
32567 list will be in increasing order of their |value| fields.
32569 Given such a list
, the |sort_in| function takes a value and returns a pointer
32570 to where that value can be found in the list. The value is inserted in
32571 the proper place
, if necessary.
32573 At the time we need to do these operations
, most of \MP's work has been
32574 completed
, so we will have plenty of memory to play with. The value nodes
32575 that are allocated for sorting will never be returned to free storage.
32577 @d clear_the_list mp_link
(mp-
>temp_head
)=mp-
>inf_val
32580 static mp_node mp_sort_in
(MP mp
, mp_number v
) {
32581 mp_node p
, q
, r
; /* list manipulation registers
*/
32585 if
(number_lessequal
(v
, value_number
(q
)))
32589 if
(number_less
(v
, value_number
(q
))) {
32590 r
= mp_get_value_node
(mp
);
32591 set_value_number
(r
, v
);
32595 return mp_link
(p
);
32599 @ Now we come to the interesting part
, where we reduce the list if necessary
32600 until it has the required size. The |min_cover| routine is basic to this
32601 process
; it computes the minimum number~|m| such that the values of the
32602 current sorted list can be covered by |m|~intervals of width~|d|. It
32603 also sets the global value |perturbation| to the smallest value $d'
>d$
32604 such that the covering found by this algorithm would be different.
32606 In particular
, |min_cover
(0)| returns the number of distinct values in the
32607 current list and sets |perturbation| to the minimum distance between
32611 static integer mp_min_cover
(MP mp
, mp_number d
) {
32612 mp_node p
; /* runs through the current list
*/
32613 mp_number l
; /* the least element covered by the current interval
*/
32615 integer m
; /* lower bound on the size of the minimum cover
*/
32619 p
= mp_link
(mp-
>temp_head
);
32620 set_number_to_inf
(mp-
>perturbation
);
32621 while
(p
!= mp-
>inf_val
) {
32623 number_clone
(l
, value_number
(p
));
32626 set_number_from_addition
(test
, l
, d
);
32627 } while
(number_lessequal
(value_number
(p
), test
));
32629 set_number_from_substraction
(test
, value_number
(p
), l
);
32630 if
(number_less
(test
, mp-
>perturbation
)) {
32631 number_clone
(mp-
>perturbation
, value_number
(p
));
32632 number_substract
(mp-
>perturbation
, l
);
32635 free_number
(test
);
32642 mp_number perturbation
; /* quantity related to \.
{TFM
} rounding
*/
32643 integer excess
; /* the list is this much too long
*/
32645 @ @
<Initialize table...@
>=
32646 new_number
(mp-
>perturbation
);
32649 free_number
(mp-
>perturbation
);
32651 @ The smallest |d| such that a given list can be covered with |m| intervals
32652 is determined by the |threshold| routine
, which is sort of an inverse
32653 to |min_cover|. The idea is to increase the interval size rapidly until
32654 finding the range
, then to go sequentially until the exact borderline has
32658 static void mp_threshold
(MP mp
, mp_number ret
, integer m
) {
32659 mp_number d
, arg1
; /* lower bound on the smallest interval size
*/
32662 mp-
>excess
= mp_min_cover
(mp
, zero_t
) - m
;
32663 if
(mp-
>excess
<= 0) {
32664 number_clone
(ret
, zero_t
);
32667 number_clone
(d
, mp-
>perturbation
);
32668 set_number_from_addition
(arg1
, d
, d
);
32669 } while
(mp_min_cover
(mp
, arg1
) > m
);
32670 while
(mp_min_cover
(mp
, d
) > m
) {
32671 number_clone
(d
, mp-
>perturbation
);
32673 number_clone
(ret
, d
);
32676 free_number
(arg1
);
32680 @ The |skimp| procedure reduces the current list to at most |m| entries
,
32681 by changing values if necessary. It also sets |indep_value
(p
):=k| if |value
(p
)|
32682 is the |k|th distinct value on the resulting list
, and it sets
32683 |perturbation| to the maximum amount by which a |value| field has
32684 been changed. The size of the resulting list is returned as the
32688 static integer mp_skimp
(MP mp
, integer m
) {
32689 mp_number d
; /* the size of intervals being coalesced
*/
32690 mp_node p
, q
, r
; /* list manipulation registers
*/
32691 mp_number l
; /* the least value in the current interval
*/
32692 mp_number v
; /* a compromise value
*/
32695 mp_threshold
(mp
, d
, m
);
32699 set_number_to_zero
(mp-
>perturbation
);
32702 p
= mp_link
(mp-
>temp_head
);
32703 while
(p
!= mp-
>inf_val
) {
32705 number_clone
(l
, value_number
(p
));
32706 set_indep_value
(p
,m
);
32707 set_number_from_addition
(l_d
, l
, d
);
32708 if
(number_lessequal
(value_number
(mp_link
(p
)), l_d
)) {
32709 @
<Replace an interval of values by its midpoint@
>;
32722 @ @
<Replace an interval...@
>=
32728 set_indep_value
(p
, m
);
32730 if
(mp-
>excess
== 0) {
32731 number_clone
(l_d
, l
);
32733 } while
(number_lessequal
(value_number
(mp_link
(p
)), l_d
));
32734 set_number_from_substraction
(test
, value_number
(p
), l
);
32735 number_halfp
(test
);
32736 set_number_from_addition
(v
, l
, test
);
32737 set_number_from_substraction
(test
, value_number
(p
), v
);
32738 if
(number_greater
(test
, mp-
>perturbation
))
32739 number_clone
(mp-
>perturbation
, test
);
32743 set_value_number
(r
, v
);
32745 mp_link
(q
) = p
; /* remove duplicate values from the current list
*/
32746 free_number
(test
);
32750 @ A warning message is issued whenever something is perturbed by
32751 more than
1/16\thinspace pt.
32754 static void mp_tfm_warning
(MP mp
, quarterword m
) {
32755 mp_print_nl
(mp
, "(some ");
32756 mp_print
(mp
, internal_name
(m
));
32757 @.some charwds...@
>
32758 @.some chardps...@
>
32759 @.some charhts...@
>
32760 @.some charics...@
>;
32761 mp_print
(mp
, " values had to be adjusted by as much as ");
32762 print_number
(mp-
>perturbation
);
32763 mp_print
(mp
, "pt)");
32767 @ Here's an example of how we use these routines.
32768 The width data needs to be perturbed only if there are
256 distinct
32769 widths
, but \MP\ must check for this case even though it is
32772 An integer variable |k| will be defined when we use this code.
32773 The |dimen_head| array will contain pointers to the sorted
32774 lists of dimensions.
32776 @d tfm_warn_threshold_k
((math_data
*)mp-
>math
)->tfm_warn_threshold_t
32778 @
<Massage the \.
{TFM
} widths@
>=
32780 for
(k
= mp-
>bc
; k
<= mp-
>ec
; k
++) {
32781 if
(mp-
>char_exists
[k
])
32782 mp-
>tfm_width
[k
] = mp_sort_in
(mp
, value_number
(mp-
>tfm_width
[k
]));
32784 mp-
>nw
= (short
) (mp_skimp
(mp
, 255) + 1);
32785 mp-
>dimen_head
[1] = mp_link
(mp-
>temp_head
);
32786 if
(number_greaterequal
(mp-
>perturbation
, tfm_warn_threshold_k
))
32787 mp_tfm_warning
(mp
, mp_char_wd
)
32791 mp_node dimen_head
[5]; /* lists of \.
{TFM
} dimensions
*/
32793 @ Heights
, depths
, and italic corrections are different from widths
32794 not only because their list length is more severely restricted
, but
32795 also because zero values do not need to be put into the lists.
32797 @
<Massage the \.
{TFM
} heights
, depths
, and italic corrections@
>=
32799 for
(k
= mp-
>bc
; k
<= mp-
>ec
; k
++) {
32800 if
(mp-
>char_exists
[k
]) {
32801 if
(mp-
>tfm_height
[k
] == 0)
32802 mp-
>tfm_height
[k
] = mp-
>zero_val
;
32804 mp-
>tfm_height
[k
] = mp_sort_in
(mp
, value_number
(mp-
>tfm_height
[k
]));
32807 mp-
>nh
= (short
) (mp_skimp
(mp
, 15) + 1);
32808 mp-
>dimen_head
[2] = mp_link
(mp-
>temp_head
);
32809 if
(number_greaterequal
(mp-
>perturbation
, tfm_warn_threshold_k
))
32810 mp_tfm_warning
(mp
, mp_char_ht
);
32812 for
(k
= mp-
>bc
; k
<= mp-
>ec
; k
++) {
32813 if
(mp-
>char_exists
[k
]) {
32814 if
(mp-
>tfm_depth
[k
] == 0)
32815 mp-
>tfm_depth
[k
] = mp-
>zero_val
;
32817 mp-
>tfm_depth
[k
] = mp_sort_in
(mp
, value_number
(mp-
>tfm_depth
[k
]));
32820 mp-
>nd
= (short
) (mp_skimp
(mp
, 15) + 1);
32821 mp-
>dimen_head
[3] = mp_link
(mp-
>temp_head
);
32822 if
(number_greaterequal
(mp-
>perturbation
, tfm_warn_threshold_k
))
32823 mp_tfm_warning
(mp
, mp_char_dp
);
32825 for
(k
= mp-
>bc
; k
<= mp-
>ec
; k
++) {
32826 if
(mp-
>char_exists
[k
]) {
32827 if
(mp-
>tfm_ital_corr
[k
] == 0)
32828 mp-
>tfm_ital_corr
[k
] = mp-
>zero_val
;
32830 mp-
>tfm_ital_corr
[k
] = mp_sort_in
(mp
, value_number
(mp-
>tfm_ital_corr
[k
]));
32833 mp-
>ni
= (short
) (mp_skimp
(mp
, 63) + 1);
32834 mp-
>dimen_head
[4] = mp_link
(mp-
>temp_head
);
32835 if
(number_greaterequal
(mp-
>perturbation
, tfm_warn_threshold_k
))
32836 mp_tfm_warning
(mp
, mp_char_ic
)
32839 @ @
<Initialize table entries@
>=
32840 mp-
>zero_val
= mp_get_value_node
(mp
);
32841 set_value_number
(mp-
>zero_val
, zero_t
);
32843 @ @
<Free table entries@
>=
32844 mp_free_value_node
(mp
, mp-
>zero_val
);
32846 @ Bytes
5--8 of the header are set to the design size
, unless the user has
32847 some crazy reason for specifying them differently.
32850 Error messages are not allowed at the time this procedure is called
,
32851 so a warning is printed instead.
32853 The value of |max_tfm_dimen| is calculated so that
32854 $$\hbox
{|make_scaled
(16*max_tfm_dimen
,internal_value
(mp_design_size
))|
}
32855 < \\
{three\_bytes
}.$$
32857 @d three_bytes
0100000000 /* $
2^
{24}$
*/
32860 static void mp_fix_design_size
(MP mp
) {
32861 mp_number d
; /* the design size
*/
32863 number_clone
(d
, internal_value
(mp_design_size
));
32864 if
(number_less
(d
, unity_t
) || number_greaterequal
(d
, fraction_half_t
)) {
32865 if
(!number_zero
(d
))
32866 mp_print_nl
(mp
, "(illegal design size has been changed to 128pt)");
32867 @.illegal design size...@
>;
32868 set_number_from_scaled
(d
, 040000000);
32869 number_clone
(internal_value
(mp_design_size
), d
);
32871 if
(mp-
>header_byte
[4] == 0 && mp->header_byte[5] == 0 &&
32872 mp-
>header_byte
[6] == 0 && mp->header_byte[7] == 0) {
32873 integer dd
= number_to_scaled
(d
);
32874 mp-
>header_byte
[4] = (char
) (dd
/ 04000000);
32875 mp-
>header_byte
[5] = (char
) ((dd
/ 4096) % 256);
32876 mp-
>header_byte
[6] = (char
) ((dd
/ 16) % 256);
32877 mp-
>header_byte
[7] = (char
) ((dd
% 16) * 16);
32879 /* |mp-
>max_tfm_dimen
= 16 * internal_value
(mp_design_size
) - 1 - internal_value
(mp_design_size
) / 010000000|
*/
32881 mp_number secondpart
;
32882 new_number
(secondpart
);
32883 number_clone
(secondpart
, internal_value
(mp_design_size
));
32884 number_clone
(mp-
>max_tfm_dimen
, secondpart
);
32885 number_divide_int
(secondpart
, 010000000);
32886 number_multiply_int
(mp-
>max_tfm_dimen
, 16);
32887 number_add_scaled
(mp-
>max_tfm_dimen
, -1);
32888 number_substract
(mp-
>max_tfm_dimen
, secondpart
);
32889 free_number
(secondpart
);
32891 if
(number_greaterequal
(mp-
>max_tfm_dimen
, fraction_half_t
)) {
32892 number_clone
(mp-
>max_tfm_dimen
, fraction_half_t
);
32893 number_add_scaled
(mp-
>max_tfm_dimen
, -1);
32899 @ The |dimen_out| procedure computes a |fix_word| relative to the
32900 design size. If the data was out of range
, it is corrected and the
32901 global variable |tfm_changed| is increased by~one.
32904 static integer mp_dimen_out
(MP mp
, mp_number x_orig
) {
32908 new_number
(abs_x
);
32910 number_clone
(x
, x_orig
);
32911 number_clone
(abs_x
, x_orig
);
32912 number_abs
(abs_x
);
32913 if
(number_greater
(abs_x
, mp-
>max_tfm_dimen
)) {
32914 incr
(mp-
>tfm_changed
);
32915 if
(number_positive
(x
))
32916 number_clone
(x
, mp-
>max_tfm_dimen
);
32918 number_clone
(x
, mp-
>max_tfm_dimen
);
32925 number_clone
(arg1
, x
);
32926 number_multiply_int
(arg1
, 16);
32927 make_scaled
(x
, arg1
, internal_value
(mp_design_size
));
32928 free_number
(arg1
);
32930 free_number
(abs_x
);
32931 ret
= number_to_scaled
(x
);
32938 mp_number max_tfm_dimen
; /* bound on widths
, heights
, kerns
, etc.
*/
32939 integer tfm_changed
; /* the number of data entries that were out of bounds
*/
32941 @ @
<Initialize table...@
>=
32942 new_number
(mp-
>max_tfm_dimen
);
32945 free_number
(mp-
>max_tfm_dimen
);
32948 @ If the user has not specified any of the first four header bytes
,
32949 the |fix_check_sum| procedure replaces them by a ``check sum'' computed
32950 from the |tfm_width| data relative to the design size.
32954 static void mp_fix_check_sum
(MP mp
) {
32955 eight_bits k
; /* runs through character codes
*/
32956 eight_bits B1
, B2
, B3
, B4
; /* bytes of the check sum
*/
32957 integer x
; /* hash value used in check sum computation
*/
32958 if
(mp-
>header_byte
[0] == 0 && mp->header_byte[1] == 0 &&
32959 mp-
>header_byte
[2] == 0 && mp->header_byte[3] == 0) {
32960 @
<Compute a check sum in |
(b1
,b2
,b3
,b4
)|@
>;
32961 mp-
>header_byte
[0] = (char
) B1
;
32962 mp-
>header_byte
[1] = (char
) B2
;
32963 mp-
>header_byte
[2] = (char
) B3
;
32964 mp-
>header_byte
[3] = (char
) B4
;
32970 @ @
<Compute a check sum in |
(b1
,b2
,b3
,b4
)|@
>=
32975 mp-
>tfm_changed
= 0;
32976 for
(k
= mp-
>bc
; k
<= mp-
>ec
; k
++) {
32977 if
(mp-
>char_exists
[k
]) {
32978 x
= mp_dimen_out
(mp
, value_number
(mp-
>tfm_width
[k
])) + (k
+ 4) * 020000000; /* this is positive
*/
32979 B1
= (eight_bits
) ((B1
+ B1
+ x
) % 255);
32980 B2
= (eight_bits
) ((B2
+ B2
+ x
) % 253);
32981 B3
= (eight_bits
) ((B3
+ B3
+ x
) % 251);
32982 B4
= (eight_bits
) ((B4
+ B4
+ x
) % 247);
32989 @ Finally we're ready to actually write the \.
{TFM
} information.
32990 Here are some utility routines for this purpose.
32992 @d tfm_out
(A
) do
{ /* output one byte to |tfm_file|
*/
32993 unsigned char s
=(unsigned char
)(A
);
32994 (mp-
>write_binary_file
)(mp
,mp-
>tfm_file
,(void
*)&s,1);
32998 static void mp_tfm_two
(MP mp
, integer x
) { /* output two bytes to |tfm_file|
*/
33002 static void mp_tfm_four
(MP mp
, integer x
) { /* output four bytes to |tfm_file|
*/
33004 tfm_out
(x
/ three_bytes
);
33006 x
= x
+ 010000000000; /* use two's complement for negative values
*/
33007 x
= x
+ 010000000000;
33008 tfm_out
((x
/ three_bytes
) + 128);
33010 x
= x
% three_bytes
;
33011 tfm_out
(x
/ number_to_scaled
(unity_t
));
33012 x
= x
% number_to_scaled
(unity_t
);
33013 tfm_out
(x
/ 0400);
33014 tfm_out
(x
% 0400);
33016 static void mp_tfm_qqqq
(MP mp
, four_quarters x
) { /* output four quarterwords to |tfm_file|
*/
33017 tfm_out
(qo
(x.b0
));
33018 tfm_out
(qo
(x.b1
));
33019 tfm_out
(qo
(x.b2
));
33020 tfm_out
(qo
(x.b3
));
33024 @ @
<Finish the \.
{TFM
} file@
>=
33025 if
(mp-
>job_name
== NULL)
33026 mp_open_log_file
(mp
);
33027 mp_pack_job_name
(mp
, ".tfm");
33028 while
(!mp_open_out
(mp
, &mp->tfm_file, mp_filetype_metrics))
33029 mp_prompt_file_name
(mp
, "file name for font metrics", ".tfm");
33030 mp-
>metric_file_name
= xstrdup
(mp-
>name_of_file
);
33031 @
<Output the subfile sizes and header bytes@
>;
33032 @
<Output the character information bytes
, then
33033 output the dimensions themselves@
>;
33034 @
<Output the ligature
/kern program@
>;
33035 @
<Output the extensible character recipes and the font metric parameters@
>;
33036 if
(number_positive
(internal_value
(mp_tracing_stats
)))
33037 @
<Log the subfile sizes of the \.
{TFM
} file@
>;
33038 mp_print_nl
(mp
, "Font metrics written on ");
33039 mp_print
(mp
, mp-
>metric_file_name
);
33040 mp_print_char
(mp
, xord
('.'
));
33041 @.Font metrics written...@
>;
33042 (mp-
>close_file
) (mp
, mp-
>tfm_file
)
33045 @ Integer variables |lh|
, |k|
, and |lk_offset| will be defined when we use
33048 @
<Output the subfile sizes and header bytes@
>=
33049 k
= mp-
>header_last
;
33050 LH
= (k
+ 4) / 4; /* this is the number of header words
*/
33051 if
(mp-
>bc
> mp-
>ec
)
33052 mp-
>bc
= 1; /* if there are no characters
, |ec
=0| and |bc
=1|
*/
33053 @
<Compute the ligature
/kern program offset and implant the
33054 left boundary label@
>;
33056 6 + LH
+ (mp-
>ec
- mp-
>bc
+ 1) + mp-
>nw
+ mp-
>nh
+ mp-
>nd
+ mp-
>ni
+
33057 mp-
>nl
+ lk_offset
+ mp-
>nk
+ mp-
>ne
+ mp-
>np
);
33058 /* this is the total number of file words that will be output
*/
33059 mp_tfm_two
(mp
, LH
);
33060 mp_tfm_two
(mp
, mp-
>bc
);
33061 mp_tfm_two
(mp
, mp-
>ec
);
33062 mp_tfm_two
(mp
, mp-
>nw
);
33063 mp_tfm_two
(mp
, mp-
>nh
);
33064 mp_tfm_two
(mp
, mp-
>nd
);
33065 mp_tfm_two
(mp
, mp-
>ni
);
33066 mp_tfm_two
(mp
, mp-
>nl
+ lk_offset
);
33067 mp_tfm_two
(mp
, mp-
>nk
);
33068 mp_tfm_two
(mp
, mp-
>ne
);
33069 mp_tfm_two
(mp
, mp-
>np
);
33070 for
(k
= 0; k
< 4 * LH
; k
++) {
33071 tfm_out
(mp-
>header_byte
[k
]);
33075 @ @
<Output the character information bytes...@
>=
33076 for
(k
= mp-
>bc
; k
<= mp-
>ec
; k
++) {
33077 if
(!mp-
>char_exists
[k
]) {
33078 mp_tfm_four
(mp
, 0);
33080 tfm_out
(indep_value
(mp-
>tfm_width
[k
])); /* the width index
*/
33081 tfm_out
((indep_value
(mp-
>tfm_height
[k
])) * 16 + indep_value
(mp-
>tfm_depth
[k
]));
33082 tfm_out
((indep_value
(mp-
>tfm_ital_corr
[k
])) * 4 + mp-
>char_tag
[k
]);
33083 tfm_out
(mp-
>char_remainder
[k
]);
33086 mp-
>tfm_changed
= 0;
33087 for
(k
= 1; k
<= 4; k
++) {
33088 mp_tfm_four
(mp
, 0);
33089 p
= mp-
>dimen_head
[k
];
33090 while
(p
!= mp-
>inf_val
) {
33091 mp_tfm_four
(mp
, mp_dimen_out
(mp
, value_number
(p
)));
33097 @ We need to output special instructions at the beginning of the
33098 |lig_kern| array in order to specify the right boundary character
33099 and
/or to handle starting addresses that exceed
255. The |label_loc|
33100 and |label_char| arrays have been set up to record all the
33101 starting addresses
; we have $
-1=|label_loc|
[0]<|label_loc|
[1]\le\cdots
33102 \le|label_loc|
[|label_ptr
]|$.
33104 @
<Compute the ligature
/kern program offset...@
>=
33105 mp-
>bchar
= round_unscaled
(internal_value
(mp_boundary_char
));
33106 if
((mp-
>bchar
< 0) ||
(mp-
>bchar
> 255)) {
33108 mp-
>lk_started
= false
;
33111 mp-
>lk_started
= true
;
33114 @
<Find the minimum |lk_offset| and adjust all remainders@
>;
33115 if
(mp-
>bch_label
< undefined_label
) {
33116 skip_byte
(mp-
>nl
) = qi
(255);
33117 next_char
(mp-
>nl
) = qi
(0);
33118 op_byte
(mp-
>nl
) = qi
(((mp-
>bch_label
+ lk_offset
) / 256));
33119 rem_byte
(mp-
>nl
) = qi
(((mp-
>bch_label
+ lk_offset
) % 256));
33120 mp-
>nl
++; /* possibly |nl
=lig_table_size
+1|
*/
33123 @ @
<Find the minimum |lk_offset|...@
>=
33124 k
= mp-
>label_ptr
; /* pointer to the largest unallocated label
*/
33125 if
(mp-
>label_loc
[k
] + lk_offset
> 255) {
33127 mp-
>lk_started
= false
; /* location
0 can do double duty
*/
33129 mp-
>char_remainder
[mp-
>label_char
[k
]] = lk_offset
;
33130 while
(mp-
>label_loc
[k
- 1] == mp-
>label_loc
[k
]) {
33132 mp-
>char_remainder
[mp-
>label_char
[k
]] = lk_offset
;
33136 } while
(!(lk_offset
+ mp-
>label_loc
[k
] < 256));
33137 /* N.B.
: |lk_offset
=256| satisfies this when |k
=0|
*/
33139 if
(lk_offset
> 0) {
33141 mp-
>char_remainder
[mp-
>label_char
[k
]]
33142 = mp-
>char_remainder
[mp-
>label_char
[k
]] + lk_offset
;
33147 @ @
<Output the ligature
/kern program@
>=
33148 for
(k
= 0; k
<= 255; k
++) {
33149 if
(mp-
>skip_table
[k
] < undefined_label
) {
33150 mp_print_nl
(mp
, "(local label ");
33151 mp_print_int
(mp
, k
);
33152 mp_print
(mp
, ":: was missing)");
33153 @.local label l
:: was missing@
>;
33154 cancel_skips
(mp-
>skip_table
[k
]);
33157 if
(mp-
>lk_started
) { /* |lk_offset
=1| for the special |bchar|
*/
33159 tfm_out
(mp-
>bchar
);
33160 mp_tfm_two
(mp
, 0);
33162 for
(k
= 1; k
<= lk_offset
; k
++) { /* output the redirection specs
*/
33163 mp-
>ll
= mp-
>label_loc
[mp-
>label_ptr
];
33164 if
(mp-
>bchar
< 0) {
33169 tfm_out
(mp-
>bchar
);
33171 mp_tfm_two
(mp
, mp-
>ll
+ lk_offset
);
33174 } while
(!(mp-
>label_loc
[mp-
>label_ptr
] < mp-
>ll
));
33177 for
(k
= 0; k
< mp-
>nl
; k
++)
33178 mp_tfm_qqqq
(mp
, mp-
>lig_kern
[k
]);
33182 for
(k
= 0; k
< mp-
>nk
; k
++) {
33183 number_clone
(arg
, mp-
>kern
[k
]);
33184 mp_tfm_four
(mp
, mp_dimen_out
(mp
, arg
));
33189 @ @
<Output the extensible character recipes...@
>=
33190 for
(k
= 0; k
< mp-
>ne
; k
++)
33191 mp_tfm_qqqq
(mp
, mp-
>exten
[k
]);
33195 for
(k
= 1; k
<= mp-
>np
; k
++) {
33197 number_clone
(arg
, mp-
>param
[1]);
33199 if
(number_less
(arg
, fraction_half_t
)) {
33200 mp_tfm_four
(mp
, number_to_scaled
(mp-
>param
[1]) * 16);
33202 incr
(mp-
>tfm_changed
);
33203 if
(number_positive
(mp-
>param
[1]))
33204 mp_tfm_four
(mp
, max_integer
);
33206 mp_tfm_four
(mp
, -max_integer
);
33209 number_clone
(arg
, mp-
>param
[k
]);
33210 mp_tfm_four
(mp
, mp_dimen_out
(mp
, arg
));
33215 if
(mp-
>tfm_changed
> 0) {
33216 if
(mp-
>tfm_changed
== 1) {
33217 mp_print_nl
(mp
, "(a font metric dimension");
33218 @.a font metric dimension...@
>
33220 mp_print_nl
(mp
, "(");
33221 mp_print_int
(mp
, mp-
>tfm_changed
);
33222 @.font metric dimensions...@
>;
33223 mp_print
(mp
, " font metric dimensions");
33225 mp_print
(mp
, " had to be decreased)");
33228 @ @
<Log the subfile sizes of the \.
{TFM
} file@
>=
33232 if
(mp-
>bch_label
< undefined_label
)
33234 mp_snprintf
(s
, 128,
33235 "(You used %iw,%ih,%id,%ii,%il,%ik,%ie,%ip metric file positions)",
33236 mp-
>nw
, mp-
>nh
, mp-
>nd
, mp-
>ni
, mp-
>nl
, mp-
>nk
, mp-
>ne
, mp-
>np
);
33241 @
* Reading font metric data.
33243 \MP\ isn't a typesetting program but it does need to find the bounding box
33244 of a sequence of typeset characters. Thus it needs to read \.
{TFM
} files as
33245 well as write them.
33250 @ All the width
, height
, and depth information is stored in an array called
33251 |font_info|. This array is allocated sequentially and each font is stored
33252 as a series of |char_info| words followed by the width
, height
, and depth
33253 tables. Since |font_name| entries are permanent
, their |str_ref| values are
33254 set to |MAX_STR_REF|.
33257 typedef unsigned int font_number
; /* |
0..font_max|
*/
33259 @ The |font_info| array is indexed via a group directory arrays.
33260 For example
, the |char_info| data for character~|c| in font~|f| will be
33261 in |font_info
[char_base
[f
]+c
].qqqq|.
33264 font_number font_max
; /* maximum font number for included text fonts
*/
33265 size_t font_mem_size
; /* number of words for \.
{TFM
} information for text fonts
*/
33266 font_data
*font_info
; /* height
, width
, and depth data
*/
33267 char
**font_enc_name
; /* encoding names
, if any
*/
33268 boolean
*font_ps_name_fixed
; /* are the postscript names fixed already?
*/
33269 size_t next_fmem
; /* next unused entry in |font_info|
*/
33270 font_number last_fnum
; /* last font number used so far
*/
33271 integer
*font_dsize
; /* 16 times the ``design'' size in \ps\ points
*/
33272 char
**font_name
; /* name as specified in the \
&{infont} command */
33273 char
**font_ps_name
; /* PostScript name for use when |internal
[mp_prologues
]>0|
*/
33274 font_number last_ps_fnum
; /* last valid |font_ps_name| index
*/
33275 eight_bits
*font_bc
;
33276 eight_bits
*font_ec
; /* first and last character code
*/
33277 int
*char_base
; /* base address for |char_info|
*/
33278 int
*width_base
; /* index for zeroth character width
*/
33279 int
*height_base
; /* index for zeroth character height
*/
33280 int
*depth_base
; /* index for zeroth character depth
*/
33281 mp_node
*font_sizes
;
33283 @ @
<Allocate or initialize ...@
>=
33284 mp-
>font_mem_size
= 10000;
33285 mp-
>font_info
= xmalloc
((mp-
>font_mem_size
+ 1), sizeof
(font_data
));
33286 memset
(mp-
>font_info
, 0, sizeof
(font_data
) * (mp-
>font_mem_size
+ 1));
33287 mp-
>last_fnum
= null_font
;
33289 @ @
<Dealloc variables@
>=
33290 for
(k
= 1; k
<= (int
) mp-
>last_fnum
; k
++) {
33291 xfree
(mp-
>font_enc_name
[k
]);
33292 xfree
(mp-
>font_name
[k
]);
33293 xfree
(mp-
>font_ps_name
[k
]);
33295 for
(k
= 0; k
<= 255; k
++) {
33296 /* These are disabled for now following a bug-report about double free
33297 errors.
TO BE FIXED
, bug tracker id
831 */
33299 mp_free_value_node
(mp
, mp-
>tfm_width
[k
]);
33300 mp_free_value_node
(mp
, mp-
>tfm_height
[k
]);
33301 mp_free_value_node
(mp
, mp-
>tfm_depth
[k
]);
33302 mp_free_value_node
(mp
, mp-
>tfm_ital_corr
[k
]);
33306 xfree
(mp-
>font_info
);
33307 xfree
(mp-
>font_enc_name
);
33308 xfree
(mp-
>font_ps_name_fixed
);
33309 xfree
(mp-
>font_dsize
);
33310 xfree
(mp-
>font_name
);
33311 xfree
(mp-
>font_ps_name
);
33312 xfree
(mp-
>font_bc
);
33313 xfree
(mp-
>font_ec
);
33314 xfree
(mp-
>char_base
);
33315 xfree
(mp-
>width_base
);
33316 xfree
(mp-
>height_base
);
33317 xfree
(mp-
>depth_base
);
33318 xfree
(mp-
>font_sizes
);
33322 void mp_reallocate_fonts
(MP mp
, font_number l
) {
33324 XREALLOC
(mp-
>font_enc_name
, l
, char
*);
33325 XREALLOC
(mp-
>font_ps_name_fixed
, l
, boolean
);
33326 XREALLOC
(mp-
>font_dsize
, l
, integer
);
33327 XREALLOC
(mp-
>font_name
, l
, char
*);
33328 XREALLOC
(mp-
>font_ps_name
, l
, char
*);
33329 XREALLOC
(mp-
>font_bc
, l
, eight_bits
);
33330 XREALLOC
(mp-
>font_ec
, l
, eight_bits
);
33331 XREALLOC
(mp-
>char_base
, l
, int
);
33332 XREALLOC
(mp-
>width_base
, l
, int
);
33333 XREALLOC
(mp-
>height_base
, l
, int
);
33334 XREALLOC
(mp-
>depth_base
, l
, int
);
33335 XREALLOC
(mp-
>font_sizes
, l
, mp_node
);
33336 for
(f
= (mp-
>last_fnum
+ 1); f
<= l
; f
++) {
33337 mp-
>font_enc_name
[f
] = NULL;
33338 mp-
>font_ps_name_fixed
[f
] = false
;
33339 mp-
>font_name
[f
] = NULL;
33340 mp-
>font_ps_name
[f
] = NULL;
33341 mp-
>font_sizes
[f
] = NULL;
33347 @ @
<Internal library declarations@
>=
33348 void mp_reallocate_fonts
(MP mp
, font_number l
);
33351 @ A |null_font| containing no characters is useful for error recovery. Its
33352 |font_name| entry starts out empty but is reset each time an erroneous font is
33353 found. This helps to cut down on the number of duplicate error messages without
33354 wasting a lot of space.
33356 @d null_font
0 /* the |font_number| for an empty font
*/
33358 @
<Set initial...@
>=
33359 mp-
>font_dsize
[null_font
] = 0;
33360 mp-
>font_bc
[null_font
] = 1;
33361 mp-
>font_ec
[null_font
] = 0;
33362 mp-
>char_base
[null_font
] = 0;
33363 mp-
>width_base
[null_font
] = 0;
33364 mp-
>height_base
[null_font
] = 0;
33365 mp-
>depth_base
[null_font
] = 0;
33367 mp-
>last_fnum
= null_font
;
33368 mp-
>last_ps_fnum
= null_font
;
33370 static char nullfont_name
[] = "nullfont";
33371 static char nullfont_psname
[] = "";
33372 mp-
>font_name
[null_font
] = nullfont_name
;
33373 mp-
>font_ps_name
[null_font
] = nullfont_psname
;
33375 mp-
>font_ps_name_fixed
[null_font
] = false
;
33376 mp-
>font_enc_name
[null_font
] = NULL;
33377 mp-
>font_sizes
[null_font
] = NULL;
33379 @ Each |char_info| word is of type |four_quarters|. The |b0| field contains
33380 the |width index|
; the |b1| field contains the height
33381 index
; the |b2| fields contains the depth index
, and the |b3| field used only
33382 for temporary storage.
(It is used to keep track of which characters occur in
33383 an edge structure that is being shipped out.
)
33384 The corresponding words in the width
, height
, and depth tables are stored as
33385 |scaled| values in units of \ps\ points.
33387 With the macros below
, the |char_info| word for character~|c| in font~|f| is
33388 |char_mp_info
(f
,c
)| and the width is
33389 $$\hbox
{|char_width
(f
,char_mp_info
(f
,c
)).sc|.
}$$
33391 @d char_mp_info
(A
,B
) mp-
>font_info
[mp-
>char_base
[(A
)]+(B
)].qqqq
33392 @d char_width
(A
,B
) mp-
>font_info
[mp-
>width_base
[(A
)]+(B
).b0
].sc
33393 @d char_height
(A
,B
) mp-
>font_info
[mp-
>height_base
[(A
)]+(B
).b1
].sc
33394 @d char_depth
(A
,B
) mp-
>font_info
[mp-
>depth_base
[(A
)]+(B
).b2
].sc
33395 @d ichar_exists
(A
) ((A
).b0
>0)
33397 @ When we have a font name and we don't know whether it has been loaded yet
,
33398 we scan the |font_name| array before calling |read_font_info|.
33401 static font_number mp_find_font
(MP mp
, char
*f
);
33404 font_number mp_find_font
(MP mp
, char
*f
) {
33406 for
(n
= 0; n
<= mp-
>last_fnum
; n
++) {
33407 if
(mp_xstrcmp
(f
, mp-
>font_name
[n
]) == 0) {
33411 n
= mp_read_font_info
(mp
, f
);
33416 @ This is an interface function for getting the width of character
,
33417 as a double in ps units
33420 double mp_get_char_dimension
(MP mp
, char
*fname
, int c
, int t
) {
33425 for
(n
= 0; n
<= mp-
>last_fnum
; n
++) {
33426 if
(mp_xstrcmp
(fname
, mp-
>font_name
[n
]) == 0) {
33433 cc
= char_mp_info
(f
, c
);
33434 if
(!ichar_exists
(cc
))
33437 w
= (double
) char_width
(f
, cc
);
33439 w
= (double
) char_height
(f
, cc
);
33441 w
= (double
) char_depth
(f
, cc
);
33442 return w
/ 655.35 * (72.27 / 72);
33446 @ @
<Exported function ...@
>=
33447 double mp_get_char_dimension
(MP mp
, char
*fname
, int n
, int t
);
33450 @ If we discover that the font doesn't have a requested character
, we omit it
33451 from the bounding box computation and expect the \ps\ interpreter to drop it.
33452 This routine issues a warning message if the user has asked for it.
33455 static void mp_lost_warning
(MP mp
, font_number f
, int k
);
33458 void mp_lost_warning
(MP mp
, font_number f
, int k
) {
33459 if
(number_positive
(internal_value
(mp_tracing_lost_chars
))) {
33460 mp_begin_diagnostic
(mp
);
33461 if
(mp-
>selector
== log_only
)
33462 incr
(mp-
>selector
);
33463 mp_print_nl
(mp
, "Missing character: There is no ");
33464 @.Missing character@
>;
33465 mp_print_int
(mp
, k
);
33466 mp_print
(mp
, " in font ");
33467 mp_print
(mp
, mp-
>font_name
[f
]);
33468 mp_print_char
(mp
, xord
('
!'
));
33469 mp_end_diagnostic
(mp
, false
);
33474 @ The whole purpose of saving the height
, width
, and depth information is to be
33475 able to find the bounding box of an item of text in an edge structure. The
33476 |set_text_box| procedure takes a text node and adds this information.
33479 static void mp_set_text_box
(MP mp
, mp_text_node p
);
33482 void mp_set_text_box
(MP mp
, mp_text_node p
) {
33483 font_number f
; /* |mp_font_n
(p
)|
*/
33484 ASCII_code bc
, ec
; /* range of valid characters for font |f|
*/
33485 size_t k
, kk
; /* current character and character to stop at
*/
33486 four_quarters cc
; /* the |char_info| for the current character
*/
33487 mp_number h
, d
; /* dimensions of the current character
*/
33490 set_number_to_zero
(p-
>width
);
33491 set_number_to_neg_inf
(p-
>height
);
33492 set_number_to_neg_inf
(p-
>depth
);
33493 f
= (font_number
) mp_font_n
(p
);
33494 bc
= mp-
>font_bc
[f
];
33495 ec
= mp-
>font_ec
[f
];
33496 kk
= mp_text_p
(p
)->len
;
33499 @
<Adjust |p|'s bounding box to contain |str_pool
[k
]|
; advance |k|@
>;
33501 @
<Set the height and depth to zero if the bounding box is empty@
>;
33507 @ @
<Adjust |p|'s bounding box to contain |str_pool
[k
]|
; advance |k|@
>=
33509 if
((*(mp_text_p
(p
)->str
+ k
) < bc
) ||
(*(mp_text_p
(p
)->str
+ k
) > ec
)) {
33510 mp_lost_warning
(mp
, f
, *(mp_text_p
(p
)->str
+ k
));
33512 cc
= char_mp_info
(f
, *(mp_text_p
(p
)->str
+ k
));
33513 if
(!ichar_exists
(cc
)) {
33514 mp_lost_warning
(mp
, f
, *(mp_text_p
(p
)->str
+ k
));
33516 set_number_from_scaled
(p-
>width
, number_to_scaled
(p-
>width
) + char_width
(f
, cc
));
33517 set_number_from_scaled
(h
, char_height
(f
, cc
));
33518 set_number_from_scaled
(d
, char_depth
(f
, cc
));
33519 if
(number_greater
(h
, p-
>height
))
33520 number_clone
(p-
>height
, h
);
33521 if
(number_greater
(d
, p-
>depth
))
33522 number_clone
(p-
>depth
, d
);
33529 @ Let's hope modern compilers do comparisons correctly when the difference would
33532 @
<Set the height and depth to zero if the bounding box is empty@
>=
33533 if
(number_to_scaled
(p-
>height
) < -number_to_scaled
(p-
>depth
)) {
33534 set_number_to_zero
(p-
>height
);
33535 set_number_to_zero
(p-
>depth
);
33538 @ The new primitives fontmapfile and fontmapline.
33540 @
<Declare action procedures for use by |do_statement|@
>=
33541 static void mp_do_mapfile
(MP mp
);
33542 static void mp_do_mapline
(MP mp
);
33545 static void mp_do_mapfile
(MP mp
) {
33546 mp_get_x_next
(mp
);
33547 mp_scan_expression
(mp
);
33548 if
(mp-
>cur_exp.type
!= mp_string_type
) {
33549 @
<Complain about improper map operation@
>;
33551 mp_map_file
(mp
, cur_exp_str
());
33554 static void mp_do_mapline
(MP mp
) {
33555 mp_get_x_next
(mp
);
33556 mp_scan_expression
(mp
);
33557 if
(mp-
>cur_exp.type
!= mp_string_type
) {
33558 @
<Complain about improper map operation@
>;
33560 mp_map_line
(mp
, cur_exp_str
());
33565 @ @
<Complain about improper map operation@
>=
33567 const char
*hlp
[] = { "Only known strings can be map files or map lines.", NULL };
33568 mp_disp_err
(mp
, NULL);
33569 mp_back_error
(mp
, "Unsuitable expression", hlp
, true
);
33570 mp_get_x_next
(mp
);
33574 @ To print |scaled| value to PDF output we need some subroutines to ensure
33577 @d max_integer
0x7FFFFFFF /* $
2^
{31}-1$
*/
33580 integer ten_pow
[10]; /* $
10^
0.
.10^
9$
*/
33581 integer scaled_out
; /* amount of |scaled| that was taken out in |divide_scaled|
*/
33584 mp-
>ten_pow
[0] = 1;
33585 for
(i
= 1; i
<= 9; i
++) {
33586 mp-
>ten_pow
[i
] = 10 * mp-
>ten_pow
[i
- 1];
33590 @
* Shipping pictures out.
33591 The |ship_out| procedure
, to be described below
, is given a pointer to
33592 an edge structure. Its mission is to output a file containing the \ps\
33593 description of an edge structure.
33595 @ Each time an edge structure is shipped out we write a new \ps\ output
33596 file named according to the current \
&{charcode}.
33597 @
:char_code_
}{\
&{charcode} primitive@>
33599 This is the only backend function that remains in the main |mpost.w| file.
33600 There are just too many variable accesses needed for status reporting
33601 etcetera to make it worthwile to move the code to |psout.w|.
33603 @
<Internal library declarations@
>=
33604 void mp_open_output_file
(MP mp
);
33605 char
*mp_get_output_file_name
(MP mp
);
33606 char
*mp_set_output_file_name
(MP mp
, integer c
);
33609 static void mp_append_to_template
(MP mp
, integer ff
, integer c
, boolean rounding
) {
33610 if
(internal_type
(c
) == mp_string_type
) {
33611 char
*ss
= mp_str
(mp
, internal_string
(c
));
33613 } else if
(internal_type
(c
) == mp_known
) {
33615 int cc
= round_unscaled
(internal_value
(c
));
33616 print_with_leading_zeroes
(cc
, ff
);
33618 print_number
(internal_value
(c
));
33622 char
*mp_set_output_file_name
(MP mp
, integer c
) {
33623 char
*ss
= NULL; /* filename extension proposal
*/
33624 char
*nn
= NULL; /* temp string for str
() */
33625 unsigned old_setting
; /* previous |selector| setting
*/
33626 size_t i
; /* indexes into |filename_template|
*/
33627 integer f
; /* field width
*/
33629 if
(mp-
>job_name
== NULL)
33630 mp_open_log_file
(mp
);
33631 if
(internal_string
(mp_output_template
) == NULL) {
33632 char
*s
; /* a file extension derived from |c|
*/
33634 s
= xstrdup
(".ps");
33636 @
<Use |c| to compute the file extension |s|@
>;
33637 mp_pack_job_name
(mp
, s
);
33639 ss
= xstrdup
(mp-
>name_of_file
);
33640 } else
{ /* initializations
*/
33641 mp_string s
, n
, ftemplate
; /* a file extension derived from |c|
*/
33642 mp_number saved_char_code
;
33643 new_number
(saved_char_code
);
33644 number_clone
(saved_char_code
, internal_value
(mp_char_code
));
33645 set_internal_from_number
(mp_char_code
, unity_t
);
33646 number_multiply_int
(internal_value
(mp_char_code
), c
);
33647 if
(internal_string
(mp_job_name
) == NULL) {
33648 if
(mp-
>job_name
== NULL) {
33649 mp-
>job_name
= xstrdup
("mpout");
33651 @
<Fix up |mp-
>internal
[mp_job_name
]|@
>;
33653 old_setting
= mp-
>selector
;
33654 mp-
>selector
= new_string
;
33656 n
= mp_rts
(mp
,""); /* initialize
*/
33657 ftemplate
= internal_string
(mp_output_template
);
33658 while
(i
< ftemplate-
>len
) {
33660 if
(*(ftemplate-
>str
+ i
) == '
%'
) {
33663 if
(i
< ftemplate-
>len
) {
33664 switch
(*(ftemplate-
>str
+ i
)) {
33666 mp_append_to_template
(mp
, f
, mp_job_name
, true
);
33669 if
(number_negative
(internal_value
(mp_char_code
))) {
33670 mp_print
(mp
, "ps");
33672 mp_append_to_template
(mp
, f
, mp_char_code
, true
);
33676 mp_append_to_template
(mp
, f
, mp_output_format
, true
);
33679 mp_append_to_template
(mp
, f
, mp_day
, true
);
33682 mp_append_to_template
(mp
, f
, mp_month
, true
);
33685 mp_append_to_template
(mp
, f
, mp_year
, true
);
33688 mp_append_to_template
(mp
, f
, mp_hour
, true
);
33691 mp_append_to_template
(mp
, f
, mp_minute
, true
);
33695 /* look up a name
*/
33697 size_t frst
= i
+ 1;
33698 while
(i
< ftemplate-
>len
) {
33700 if
(*(ftemplate-
>str
+ i
) == '
}'
)
33706 mp_id_lookup
(mp
, (char
*) (ftemplate-
>str
+ frst
), l
, false
);
33707 char
*id
= xmalloc
((l
+ 1), 1);
33708 (void
) memcpy
(id
, (char
*) (ftemplate-
>str
+ frst
), (size_t
) l
);
33712 mp_snprintf
(err
, 256,
33713 "requested identifier (%s) in outputtemplate not found.",
33717 if
(eq_type
(p
) == mp_internal_quantity
) {
33718 if
(equiv
(p
) == mp_output_template
) {
33720 mp_snprintf
(err
, 256,
33721 "The appearance of outputtemplate inside outputtemplate is ignored.");
33724 mp_append_to_template
(mp
, f
, equiv
(p
), false
);
33728 mp_snprintf
(err
, 256,
33729 "requested identifier (%s) in outputtemplate is not an internal.",
33749 f
= (f
* 10) + ftemplate-
>str
[i
] - '
0'
;
33753 mp_print_char
(mp
, '
%'
);
33758 mp_snprintf
(err
, 256,
33759 "requested format (%c) in outputtemplate is unknown.",
33760 *(ftemplate-
>str
+ i
));
33763 mp_print_char
(mp
, *(ftemplate-
>str
+ i
));
33767 if
(*(ftemplate-
>str
+ i
) == '.'
)
33769 n
= mp_make_string
(mp
);
33770 mp_print_char
(mp
, *(ftemplate-
>str
+ i
));
33774 s
= mp_make_string
(mp
);
33775 number_clone
(internal_value
(mp_char_code
), saved_char_code
);
33776 free_number
(saved_char_code
);
33777 mp-
>selector
= old_setting
;
33782 ss
= mp_str
(mp
, s
);
33783 nn
= mp_str
(mp
, n
);
33784 mp_pack_file_name
(mp
, nn
, "", ss
);
33785 delete_str_ref
(n
);
33786 delete_str_ref
(s
);
33790 char
*mp_get_output_file_name
(MP mp
) {
33792 char
*saved_name
; /* saved |name_of_file|
*/
33793 saved_name
= xstrdup
(mp-
>name_of_file
);
33794 (void
) mp_set_output_file_name
(mp
, round_unscaled
(internal_value
(mp_char_code
)));
33795 f
= xstrdup
(mp-
>name_of_file
);
33796 mp_pack_file_name
(mp
, saved_name
, NULL, NULL);
33800 void mp_open_output_file
(MP mp
) {
33801 char
*ss
; /* filename extension proposal
*/
33802 int c
; /* \
&{charcode} rounded to the nearest integer */
33803 c
= round_unscaled
(internal_value
(mp_char_code
));
33804 ss
= mp_set_output_file_name
(mp
, c
);
33805 while
(!mp_open_out
(mp
, (void
*) &mp->output_file, mp_filetype_postscript))
33806 mp_prompt_file_name
(mp
, "file name for output", ss
);
33807 mp_store_true_output_filename
(mp
, c
);
33811 @ The file extension created here could be up to five characters long in
33812 extreme cases so it may have to be shortened on some systems.
33813 @^system dependencies@
>
33815 @
<Use |c| to compute the file extension |s|@
>=
33817 s
= xmalloc
(7, 1);
33818 mp_snprintf
(s
, 7, ".%i", (int
) c
);
33822 @ The user won't want to see all the output file names so we only save the
33823 first and last ones and a count of how many there were. For this purpose
33824 files are ordered primarily by \
&{charcode} and secondarily by order of
33826 @
:char_code_
}{\
&{charcode} primitive@>
33828 @
<Internal library ...@
>=
33829 void mp_store_true_output_filename
(MP mp
, int c
);
33832 void mp_store_true_output_filename
(MP mp
, int c
)
33834 if
((c
< mp-
>first_output_code
) && (mp->first_output_code >= 0)) {
33835 mp-
>first_output_code
= c
;
33836 xfree
(mp-
>first_file_name
);
33837 mp-
>first_file_name
= xstrdup
(mp-
>name_of_file
);
33839 if
(c
>= mp-
>last_output_code
) {
33840 mp-
>last_output_code
= c
;
33841 xfree
(mp-
>last_file_name
);
33842 mp-
>last_file_name
= xstrdup
(mp-
>name_of_file
);
33844 set_internal_string
(mp_output_filename
, mp_rts
(mp
, mp-
>name_of_file
));
33848 char
*first_file_name
;
33849 char
*last_file_name
; /* full file names
*/
33850 integer first_output_code
;
33851 integer last_output_code
; /* rounded \
&{charcode} values */
33852 @
:char_code_
}{\
&{charcode} primitive@>
33853 integer total_shipped
; /* total number of |ship_out| operations completed
*/
33856 mp-
>first_file_name
= xstrdup
("");
33857 mp-
>last_file_name
= xstrdup
("");
33858 mp-
>first_output_code
= 32768;
33859 mp-
>last_output_code
= -32768;
33860 mp-
>total_shipped
= 0;
33862 @ @
<Dealloc variables@
>=
33863 xfree
(mp-
>first_file_name
);
33864 xfree
(mp-
>last_file_name
);
33866 @ @
<Begin the progress report for the output of picture~|c|@
>=
33867 if
((int
) mp-
>term_offset
> mp-
>max_print_line
- 6)
33869 else if
((mp-
>term_offset
> 0) ||
(mp-
>file_offset
> 0))
33870 mp_print_char
(mp
, xord
(' '
));
33871 mp_print_char
(mp
, xord
('
['
));
33873 mp_print_int
(mp
, c
)
33876 @ @
<End progress report@
>=
33877 mp_print_char
(mp
, xord
('
]'
));
33879 incr
(mp-
>total_shipped
)
33882 @ @
<Explain what output files were written@
>=
33883 if
(mp-
>total_shipped
> 0) {
33884 mp_print_nl
(mp
, "");
33885 mp_print_int
(mp
, mp-
>total_shipped
);
33886 if
(mp-
>noninteractive
) {
33887 mp_print
(mp
, " figure");
33888 if
(mp-
>total_shipped
> 1)
33889 mp_print_char
(mp
, xord
('s'
));
33890 mp_print
(mp
, " created.");
33892 mp_print
(mp
, " output file");
33893 if
(mp-
>total_shipped
> 1)
33894 mp_print_char
(mp
, xord
('s'
));
33895 mp_print
(mp
, " written: ");
33896 mp_print
(mp
, mp-
>first_file_name
);
33897 if
(mp-
>total_shipped
> 1) {
33898 if
(31 + strlen
(mp-
>first_file_name
) +
33899 strlen
(mp-
>last_file_name
) > (unsigned
) mp-
>max_print_line
)
33901 mp_print
(mp
, " .. ");
33902 mp_print
(mp
, mp-
>last_file_name
);
33904 mp_print_nl
(mp
, "");
33908 @ @
<Internal library declarations@
>=
33909 boolean mp_has_font_size
(MP mp
, font_number f
);
33912 boolean mp_has_font_size
(MP mp
, font_number f
) {
33913 return
(mp-
>font_sizes
[f
] != NULL);
33917 @ The \
&{special} command saves up lines of text to be printed during the next
33918 |ship_out| operation. The saved items are stored as a list of capsule tokens.
33921 mp_node last_pending
; /* the last token in a list of pending specials
*/
33924 @ @
<Declare action procedures for use by |do_statement|@
>=
33925 static void mp_do_special
(MP mp
);
33928 void mp_do_special
(MP mp
) {
33929 mp_get_x_next
(mp
);
33930 mp_scan_expression
(mp
);
33931 if
(mp-
>cur_exp.type
!= mp_string_type
) {
33932 @
<Complain about improper special operation@
>;
33934 mp_link
(mp-
>last_pending
) = mp_stash_cur_exp
(mp
);
33935 mp-
>last_pending
= mp_link
(mp-
>last_pending
);
33936 mp_link
(mp-
>last_pending
) = NULL;
33941 @ @
<Complain about improper special operation@
>=
33943 const char
*hlp
[] = { "Only known strings are allowed for output as specials.", NULL };
33944 mp_disp_err
(mp
, NULL);
33945 mp_back_error
(mp
, "Unsuitable expression", hlp
, true
);
33946 mp_get_x_next
(mp
);
33950 @ On the export side
, we need an extra object type for special strings.
33952 @
<Graphical object codes@
>=
33953 mp_special_code
= 8,
33955 @ @
<Export pending specials@
>=
33956 p
= mp_link
(mp-
>spec_head
);
33957 while
(p
!= NULL) {
33958 mp_special_object
*tp
;
33959 tp
= (mp_special_object
*) mp_new_graphic_object
(mp
, mp_special_code
);
33960 gr_pre_script
(tp
) = mp_xstrdup
(mp
,mp_str
(mp
, value_str
(p
)));
33961 if
(hh-
>body
== NULL)
33962 hh-
>body
= (mp_graphic_object
*) tp
;
33964 gr_link
(hp
) = (mp_graphic_object
*) tp
;
33965 hp
= (mp_graphic_object
*) tp
;
33968 mp_flush_token_list
(mp
, mp_link
(mp-
>spec_head
));
33969 mp_link
(mp-
>spec_head
) = NULL;
33970 mp-
>last_pending
= mp-
>spec_head
33972 @ We are now ready for the main output procedure. Note that the |selector|
33973 setting is saved in a global variable so that |begin_diagnostic| can access it.
33975 @
<Declare the \ps\ output procedures@
>=
33976 static void mp_ship_out
(MP mp
, mp_node h
);
33978 @ Once again
, the |gr_XXXX| macros are defined in |mppsout.h|
33980 @d export_color
(q
,p
)
33981 if
( mp_color_model
(p
)==mp_uninitialized_model
) {
33982 gr_color_model
(q
) = (unsigned char
)(number_to_scaled
(internal_value
(mp_default_color_model
))/65536);
33983 gr_cyan_val
(q
) = 0;
33984 gr_magenta_val
(q
) = 0;
33985 gr_yellow_val
(q
) = 0;
33986 gr_black_val
(q
) = ((gr_color_model
(q
)==mp_cmyk_model ? number_to_scaled
(unity_t
) : 0) / 65536.0);
33988 gr_color_model
(q
) = (unsigned char
)mp_color_model
(p
);
33989 gr_cyan_val
(q
) = number_to_double
(p-
>cyan
);
33990 gr_magenta_val
(q
) = number_to_double
(p-
>magenta
);
33991 gr_yellow_val
(q
) = number_to_double
(p-
>yellow
);
33992 gr_black_val
(q
) = number_to_double
(p-
>black
);
33995 @d export_scripts
(q
,p
)
33996 if
(mp_pre_script
(p
)!=NULL) gr_pre_script
(q
) = mp_xstrdup
(mp
, mp_str
(mp
,mp_pre_script
(p
)));
33997 if
(mp_post_script
(p
)!=NULL) gr_post_script
(q
) = mp_xstrdup
(mp
, mp_str
(mp
,mp_post_script
(p
)));
34000 struct mp_edge_object
*mp_gr_export
(MP mp
, mp_edge_header_node h
) {
34001 mp_node p
; /* the current graphical object
*/
34002 integer t
; /* a temporary value
*/
34003 integer c
; /* a rounded charcode
*/
34004 mp_number d_width
; /* the current pen width
*/
34005 mp_edge_object
*hh
; /* the first graphical object
*/
34006 mp_graphic_object
*hq
; /* something |hp| points to
*/
34007 mp_text_object
*tt
;
34008 mp_fill_object
*tf
;
34009 mp_stroked_object
*ts
;
34010 mp_clip_object
*tc
;
34011 mp_bounds_object
*tb
;
34012 mp_graphic_object
*hp
= NULL; /* the current graphical object
*/
34013 mp_set_bbox
(mp
, h
, true
);
34014 hh
= xmalloc
(1, sizeof
(mp_edge_object
));
34018 hh-
>minx
= number_to_double
(h-
>minx
);
34019 hh-
>minx
= (fabs
(hh-
>minx
)<0.00001 ?
0 : hh-
>minx
);
34020 hh-
>miny
= number_to_double
(h-
>miny
);
34021 hh-
>miny
= (fabs
(hh-
>miny
)<0.00001 ?
0 : hh-
>miny
);
34022 hh-
>maxx
= number_to_double
(h-
>maxx
);
34023 hh-
>maxx
= (fabs
(hh-
>maxx
)<0.00001 ?
0 : hh-
>maxx
);
34024 hh-
>maxy
= number_to_double
(h-
>maxy
);
34025 hh-
>maxy
= (fabs
(hh-
>maxy
)<0.00001 ?
0 : hh-
>maxy
);
34026 hh-
>filename
= mp_get_output_file_name
(mp
);
34027 c
= round_unscaled
(internal_value
(mp_char_code
));
34029 hh-
>width
= number_to_double
(internal_value
(mp_char_wd
));
34030 hh-
>height
= number_to_double
(internal_value
(mp_char_ht
));
34031 hh-
>depth
= number_to_double
(internal_value
(mp_char_dp
));
34032 hh-
>ital_corr
= number_to_double
(internal_value
(mp_char_ic
));
34033 @
<Export pending specials@
>;
34034 p
= mp_link
(edge_list
(h
));
34035 while
(p
!= NULL) {
34036 hq
= mp_new_graphic_object
(mp
, (int
) ((mp_type
(p
) - mp_fill_node_type
) + 1));
34037 switch
(mp_type
(p
)) {
34038 case mp_fill_node_type
:
34040 mp_fill_node p0
= (mp_fill_node
)p
;
34041 tf
= (mp_fill_object
*) hq
;
34042 gr_pen_p
(tf
) = mp_export_knot_list
(mp
, mp_pen_p
(p0
));
34043 new_number
(d_width
);
34044 mp_get_pen_scale
(mp
, &d_width, mp_pen_p (p0)); /* whats the point ? */
34045 free_number
(d_width
);
34046 if
((mp_pen_p
(p0
) == NULL) || pen_is_elliptical
(mp_pen_p
(p0
))) {
34047 gr_path_p
(tf
) = mp_export_knot_list
(mp
, mp_path_p
(p0
));
34050 pc
= mp_copy_path
(mp
, mp_path_p
(p0
));
34051 pp
= mp_make_envelope
(mp
, pc
, mp_pen_p
(p0
), p0-
>ljoin
, 0, p0-
>miterlim
);
34052 gr_path_p
(tf
) = mp_export_knot_list
(mp
, pp
);
34053 mp_toss_knot_list
(mp
, pp
);
34054 pc
= mp_htap_ypoc
(mp
, mp_path_p
(p0
));
34055 pp
= mp_make_envelope
(mp
, pc
, mp_pen_p
((mp_fill_node
) p
), p0-
>ljoin
, 0, p0-
>miterlim
);
34056 gr_htap_p
(tf
) = mp_export_knot_list
(mp
, pp
);
34057 mp_toss_knot_list
(mp
, pp
);
34059 export_color
(tf
, p0
);
34060 export_scripts
(tf
, p
);
34061 gr_ljoin_val
(tf
) = p0-
>ljoin
;
34062 gr_miterlim_val
(tf
) = number_to_double
(p0-
>miterlim
);
34065 case mp_stroked_node_type
:
34067 mp_stroked_node p0
= (mp_stroked_node
)p
;
34068 ts
= (mp_stroked_object
*) hq
;
34069 gr_pen_p
(ts
) = mp_export_knot_list
(mp
, mp_pen_p
(p0
));
34070 new_number
(d_width
);
34071 mp_get_pen_scale
(mp
, &d_width, mp_pen_p (p0));
34072 if
(pen_is_elliptical
(mp_pen_p
(p0
))) {
34073 gr_path_p
(ts
) = mp_export_knot_list
(mp
, mp_path_p
(p0
));
34076 pc
= mp_copy_path
(mp
, mp_path_p
(p0
));
34078 if
(mp_left_type
(pc
) != mp_endpoint
) {
34079 mp_left_type
(mp_insert_knot
(mp
, pc
, pc-
>x_coord
, pc-
>y_coord
)) = mp_endpoint
;
34080 mp_right_type
(pc
) = mp_endpoint
;
34081 pc
= mp_next_knot
(pc
);
34085 mp_make_envelope
(mp
, pc
, mp_pen_p
(p0
),
34086 p0-
>ljoin
, (quarterword
) t
,
34088 gr_path_p
(ts
) = mp_export_knot_list
(mp
, pc
);
34089 mp_toss_knot_list
(mp
, pc
);
34091 export_color
(ts
, p0
);
34092 export_scripts
(ts
, p
);
34093 gr_ljoin_val
(ts
) = p0-
>ljoin
;
34094 gr_miterlim_val
(ts
) = number_to_double
(p0-
>miterlim
);
34095 gr_lcap_val
(ts
) = p0-
>lcap
;
34096 gr_dash_p
(ts
) = mp_export_dashes
(mp
, p0
, d_width
);
34097 free_number
(d_width
);
34100 case mp_text_node_type
:
34102 mp_text_node p0
= (mp_text_node
)p
;
34103 tt
= (mp_text_object
*) hq
;
34104 gr_text_p
(tt
) = mp_xstrldup
(mp
, mp_str
(mp
, mp_text_p
(p
)),mp_text_p
(p
)->len
);
34105 gr_text_l
(tt
) = (size_t
) mp_text_p
(p
)->len
;
34106 gr_font_n
(tt
) = (unsigned int
) mp_font_n
(p
);
34107 gr_font_name
(tt
) = mp_xstrdup
(mp
, mp-
>font_name
[mp_font_n
(p
)]);
34108 gr_font_dsize
(tt
) = mp-
>font_dsize
[mp_font_n
(p
)] / 65536.0;
34109 export_color
(tt
, p0
);
34110 export_scripts
(tt
, p
);
34111 gr_width_val
(tt
) = number_to_double
(p0-
>width
);
34112 gr_height_val
(tt
) = number_to_double
(p0-
>height
);
34113 gr_depth_val
(tt
) = number_to_double
(p0-
>depth
);
34114 gr_tx_val
(tt
) = number_to_double
(p0-
>tx
);
34115 gr_ty_val
(tt
) = number_to_double
(p0-
>ty
);
34116 gr_txx_val
(tt
) = number_to_double
(p0-
>txx
);
34117 gr_txy_val
(tt
) = number_to_double
(p0-
>txy
);
34118 gr_tyx_val
(tt
) = number_to_double
(p0-
>tyx
);
34119 gr_tyy_val
(tt
) = number_to_double
(p0-
>tyy
);
34122 case mp_start_clip_node_type
:
34123 tc
= (mp_clip_object
*) hq
;
34125 mp_export_knot_list
(mp
, mp_path_p
((mp_start_clip_node
) p
));
34127 case mp_start_bounds_node_type
:
34128 tb
= (mp_bounds_object
*) hq
;
34130 mp_export_knot_list
(mp
, mp_path_p
((mp_start_bounds_node
) p
));
34132 case mp_stop_clip_node_type
:
34133 case mp_stop_bounds_node_type
:
34134 /* nothing to do here
*/
34136 default
: /* there are no other valid cases
, but please the compiler
*/
34139 if
(hh-
>body
== NULL)
34150 @ This function is only used for the |glyph| operator
, so
34151 it takes quite a few shortcuts for cases that cannot appear
34152 in the output of |mp_ps_font_charstring|.
34155 mp_edge_header_node mp_gr_import
(MP mp
, struct mp_edge_object
*hh
) {
34156 mp_edge_header_node h
; /* the edge object
*/
34157 mp_node ph
, pn
, pt
; /* for adding items
*/
34158 mp_graphic_object
*p
; /* the current graphical object
*/
34159 h
= mp_get_edge_header_node
(mp
);
34160 mp_init_edges
(mp
, h
);
34161 ph
= edge_list
(h
);
34164 set_number_from_double
(h-
>minx
, hh-
>minx
);
34165 set_number_from_double
(h-
>miny
, hh-
>miny
);
34166 set_number_from_double
(h-
>maxx
, hh-
>maxx
);
34167 set_number_from_double
(h-
>maxy
, hh-
>maxy
);
34168 while
(p
!= NULL) {
34169 switch
(gr_type
(p
)) {
34171 if
(gr_pen_p
((mp_fill_object
*) p
) == NULL) {
34173 new_number
(turns
);
34174 pn
= mp_new_fill_node
(mp
, NULL);
34175 mp_path_p
((mp_fill_node
) pn
) =
34176 mp_import_knot_list
(mp
, gr_path_p
((mp_fill_object
*) p
));
34177 mp_color_model
(pn
) = mp_grey_model
;
34178 mp_turn_cycles
(mp
, &turns, mp_path_p ((mp_fill_node) pn));
34179 if
(number_negative
(turns
)) {
34180 set_number_to_unity
(((mp_fill_node
) pn
)->grey
);
34184 set_number_to_zero
(((mp_fill_node
) pn
)->grey
);
34185 mp_link
(pn
) = mp_link
(ph
);
34190 free_number
(turns
);
34193 case mp_stroked_code
:
34195 case mp_start_clip_code
:
34196 case mp_stop_clip_code
:
34197 case mp_start_bounds_code
:
34198 case mp_stop_bounds_code
:
34199 case mp_special_code
:
34201 } /* all cases are enumerated
*/
34204 mp_gr_toss_objects
(hh
);
34209 @ @
<Declarations@
>=
34210 struct mp_edge_object
*mp_gr_export
(MP mp
, mp_edge_header_node h
);
34211 mp_edge_header_node mp_gr_import
(MP mp
, struct mp_edge_object
*h
);
34213 @ This function is now nearly trivial.
34216 void mp_ship_out
(MP mp
, mp_node h
) { /* output edge structure |h|
*/
34217 int c
; /* \
&{charcode} rounded to the nearest integer */
34218 c
= round_unscaled
(internal_value
(mp_char_code
));
34219 @
<Begin the progress report for the output of picture~|c|@
>;
34220 (mp-
>shipout_backend
) (mp
, h
);
34221 @
<End progress report@
>;
34222 if
(number_positive
(internal_value
(mp_tracing_output
)))
34223 mp_print_edges
(mp
, h
, " (just shipped out)", true
);
34227 @ @
<Declarations@
>=
34228 static void mp_shipout_backend
(MP mp
, void
*h
);
34232 void mp_shipout_backend
(MP mp
, void
*voidh
) {
34234 mp_edge_object
*hh
; /* the first graphical object
*/
34235 mp_edge_header_node h
= (mp_edge_header_node
) voidh
;
34236 hh
= mp_gr_export
(mp
, h
);
34238 if
(internal_string
(mp_output_format
) != NULL)
34239 s
= mp_str
(mp
, internal_string
(mp_output_format
));
34240 if
(s
&& strcmp (s, "svg") == 0) {
34241 (void
) mp_svg_gr_ship_out
(hh
,
34242 (number_to_scaled
(internal_value
(mp_prologues
)) / 65536), false
);
34243 } else if
(s
&& strcmp (s, "png") == 0) {
34244 (void
) mp_png_gr_ship_out
(hh
, (const char
*)((internal_string
(mp_output_format_options
))->str
), false
);
34246 (void
) mp_gr_ship_out
(hh
,
34247 (number_to_scaled
(internal_value
(mp_prologues
)) / 65536),
34248 (number_to_scaled
(internal_value
(mp_procset
)) / 65536), false
);
34250 mp_gr_toss_objects
(hh
);
34254 @ @
<Exported types@
>=
34255 typedef void
(*mp_backend_writer
) (MP
, void
*);
34257 @ @
<Option variables@
>=
34258 mp_backend_writer shipout_backend
;
34260 @ Now that we've finished |ship_out|
, let's look at the other commands
34261 by which a user can send things to the \.
{GF
} file.
34268 @ @
<Allocate or initialize ...@
>=
34269 mp_ps_backend_initialize
(mp
);
34270 mp_svg_backend_initialize
(mp
);
34271 mp_png_backend_initialize
(mp
);
34274 mp_ps_backend_free
(mp
);
34275 mp_svg_backend_free
(mp
);
34276 mp_png_backend_free
(mp
);
34279 @
* Dumping and undumping the tables.
34281 When \.
{MP
} is started
, it is possible to preload a macro file
34282 containing definitions that will be usable in the main input
34283 file. This action even takes place automatically
, based on the
34284 name of the executable
(\.
{mpost
} will attempt to preload the
34285 macros in the file \.
{mpost.mp
}). If such a preload is not
34286 desired
, the option variable |ini_version| has to be set |true|.
34288 The variable |mem_file| holds the open file pointer.
34291 void
*mem_file
; /* file for input or preloaded macros
*/
34293 @ @
<Declarations@
>=
34294 extern boolean mp_load_preload_file
(MP mp
);
34296 @ Preloading a file is a lot like |mp_run| itself
, except that
34297 \MP\ should not exit and that a bit of trickery is needed with
34298 the input buffer to make sure that the preloading does not
34299 interfere with the actual job.
34302 boolean mp_load_preload_file
(MP mp
) {
34304 in_state_record old_state
;
34305 integer old_in_open
= mp-
>in_open
;
34306 void
*old_cur_file
= cur_file
;
34307 char
*fname
= xstrdup
(mp-
>name_of_file
);
34308 size_t l
= strlen
(fname
);
34309 old_state
= mp-
>cur_input
;
34311 for
(k
= 0; k
< l
; k
++) {
34312 append_char
(*(fname
+ k
));
34314 name
= mp_make_string
(mp
);
34315 if
(!mp-
>log_opened
) {
34316 mp_open_log_file
(mp
);
34317 } /* |open_log_file| doesn't |show_context|
, so |limit|
34318 and |loc| needn't be set to meaningful values yet
*/
34319 if
(((int
) mp-
>term_offset
+ (int
) strlen
(fname
)) > (mp-
>max_print_line
- 2))
34321 else if
((mp-
>term_offset
> 0) ||
(mp-
>file_offset
> 0))
34322 mp_print_char
(mp
, xord
(' '
));
34323 mp_print_char
(mp
, xord
('
('
));
34324 incr
(mp-
>open_parens
);
34325 mp_print
(mp
, fname
);
34329 start
= loc
= limit
+ (mp-
>noninteractive ?
0 : 1);
34330 cur_file
= mp-
>mem_file
;
34331 (void
) mp_input_ln
(mp
, cur_file
);
34332 mp_firm_up_the_line
(mp
);
34333 mp-
>buffer
[limit
] = xord
('
%'
);
34334 mp-
>first
= (size_t
) (limit
+ 1);
34337 mp-
>reading_preload
= true
;
34339 mp_do_statement
(mp
);
34340 } while
(!(cur_cmd
() == mp_stop
)); /* "dump" or EOF
*/
34341 mp-
>reading_preload
= false
;
34342 mp_primitive
(mp
, "dump", mp_relax
, 0); /* reset |dump|
*/
34343 while
(mp-
>input_ptr
> 0) {
34345 mp_end_token_list
(mp
);
34347 mp_end_file_reading
(mp
);
34349 while
(mp-
>loop_ptr
!= NULL)
34350 mp_stop_iteration
(mp
);
34351 while
(mp-
>open_parens
> 0) {
34352 mp_print
(mp
, " )");
34353 decr
(mp-
>open_parens
);
34355 while
(mp-
>cond_ptr
!= NULL) {
34356 mp_print_nl
(mp
, "(dump occurred when ");
34357 @.dump occurred...@
>;
34358 mp_print_cmd_mod
(mp
, mp_fi_or_else
, mp-
>cur_if
);
34359 /* `\.
{if
}' or `\.
{elseif
}' or `\.
{else
}'
*/
34360 if
(mp-
>if_line
!= 0) {
34361 mp_print
(mp
, " on line ");
34362 mp_print_int
(mp
, mp-
>if_line
);
34364 mp_print
(mp
, " was incomplete)");
34365 mp-
>if_line
= if_line_field
(mp-
>cond_ptr
);
34366 mp-
>cur_if
= mp_name_type
(mp-
>cond_ptr
);
34367 mp-
>cond_ptr
= mp_link
(mp-
>cond_ptr
);
34370 /* |
(mp-
>close_file
) (mp
, mp-
>mem_file
);|
*/
34371 cur_file
= old_cur_file
;
34372 mp-
>cur_input
= old_state
;
34373 mp-
>in_open
= old_in_open
;
34378 @
* The main program.
34379 This is it
: the part of \MP\ that executes all those procedures we have
34382 Well---almost. We haven't put the parsing subroutines into the
34383 program yet
; and we'd better leave space for a few more routines that may
34384 have been forgotten.
34387 @
<Declare the basic parsing subroutines@
>;
34388 @
<Declare miscellaneous procedures that were declared |forward|@
>
34391 @ Here we do whatever is needed to complete \MP's job gracefully on the
34392 local operating system. The code here might come into play after a fatal
34393 error
; it must therefore consist entirely of ``safe'' operations that
34394 cannot produce error messages. For example
, it would be a mistake to call
34395 |str_room| or |make_string| at this time
, because a call on |overflow|
34396 might lead to an infinite loop.
34397 @^system dependencies@
>
34400 void mp_close_files_and_terminate
(MP mp
) {
34401 integer k
; /* all-purpose index
*/
34402 integer LH
; /* the length of the \.
{TFM
} header
, in words
*/
34403 int lk_offset
; /* extra words inserted at beginning of |lig_kern| array
*/
34404 mp_node p
; /* runs through a list of \.
{TFM
} dimensions
*/
34407 @
<Close all open files in the |rd_file| and |wr_file| arrays@
>;
34408 if
(number_positive
(internal_value
(mp_tracing_stats
)))
34409 @
<Output statistics about this job@
>;
34410 wake_up_terminal
();
34411 @
<Do all the finishing work on the \.
{TFM
} file@
>;
34412 @
<Explain what output files were written@
>;
34413 if
(mp-
>log_opened
&& !mp->noninteractive) {
34415 (mp-
>close_file
) (mp
, mp-
>log_file
);
34416 mp-
>selector
= mp-
>selector
- 2;
34417 if
(mp-
>selector
== term_only
) {
34418 mp_print_nl
(mp
, "Transcript written on ");
34419 @.Transcript written...@
>;
34420 mp_print
(mp
, mp-
>log_name
);
34421 mp_print_char
(mp
, xord
('.'
));
34425 mp-
>finished
= true
;
34429 @ @
<Declarations@
>=
34430 static void mp_close_files_and_terminate
(MP mp
);
34432 @ @
<Close all open files in the |rd_file| and |wr_file| arrays@
>=
34433 if
(mp-
>rd_fname
!= NULL) {
34434 for
(k
= 0; k
< (int
) mp-
>read_files
; k
++) {
34435 if
(mp-
>rd_fname
[k
] != NULL) {
34436 (mp-
>close_file
) (mp
, mp-
>rd_file
[k
]);
34437 xfree
(mp-
>rd_fname
[k
]);
34441 if
(mp-
>wr_fname
!= NULL) {
34442 for
(k
= 0; k
< (int
) mp-
>write_files
; k
++) {
34443 if
(mp-
>wr_fname
[k
] != NULL) {
34444 (mp-
>close_file
) (mp
, mp-
>wr_file
[k
]);
34445 xfree
(mp-
>wr_fname
[k
]);
34451 for
(k
= 0; k
< (int
) mp-
>max_read_files
; k
++) {
34452 if
(mp-
>rd_fname
[k
] != NULL) {
34453 (mp-
>close_file
) (mp
, mp-
>rd_file
[k
]);
34454 xfree
(mp-
>rd_fname
[k
]);
34457 xfree
(mp-
>rd_file
);
34458 xfree
(mp-
>rd_fname
);
34459 for
(k
= 0; k
< (int
) mp-
>max_write_files
; k
++) {
34460 if
(mp-
>wr_fname
[k
] != NULL) {
34461 (mp-
>close_file
) (mp
, mp-
>wr_file
[k
]);
34462 xfree
(mp-
>wr_fname
[k
]);
34465 xfree
(mp-
>wr_file
);
34466 xfree
(mp-
>wr_fname
);
34469 @ We want to produce a \.
{TFM
} file if and only if |mp_fontmaking| is positive.
34471 We reclaim all of the variable-size memory at this point
, so that
34472 there is no chance of another memory overflow after the memory capacity
34473 has already been exceeded.
34475 @
<Do all the finishing work on the \.
{TFM
} file@
>=
34476 if
(number_positive
(internal_value
(mp_fontmaking
))) {
34477 @
<Massage the \.
{TFM
} widths@
>;
34478 mp_fix_design_size
(mp
);
34479 mp_fix_check_sum
(mp
);
34480 @
<Massage the \.
{TFM
} heights
, depths
, and italic corrections@
>;
34481 set_number_to_zero
(internal_value
(mp_fontmaking
)); /* avoid loop in case of fatal error
*/
34482 @
<Finish the \.
{TFM
} file@
>;
34485 @ The present section goes directly to the log file instead of using
34486 |print| commands
, because there's no need for these strings to take
34487 up |str_pool| memory when a non-
{\bf stat
} version of \MP\ is being used.
34489 @
<Output statistics...@
>=
34490 if
(mp-
>log_opened
) {
34493 wlog_ln
("Here is how much of MetaPost's memory you used:");
34494 @.Here is how much...@
>;
34495 mp_snprintf
(s
, 128, " %i string%s using %i character%s",
34496 (int
) mp-
>max_strs_used
, (mp-
>max_strs_used
!= 1 ?
"s" : ""),
34497 (int
) mp-
>max_pl_used
, (mp-
>max_pl_used
!= 1 ?
"s" : ""));
34499 mp_snprintf
(s
, 128, " %i bytes of node memory", (int
) mp-
>var_used_max
);
34501 mp_snprintf
(s
, 128, " %i symbolic tokens", (int
) mp-
>st_count
);
34503 mp_snprintf
(s
, 128,
34504 " %ii,%in,%ip,%ib,%if stack positions out of %ii,%in,%ip,%ib,%if",
34505 (int
) mp-
>max_in_stack
, (int
) mp-
>int_ptr
,
34506 (int
) mp-
>max_param_stack
, (int
) mp-
>max_buf_stack
+ 1,
34507 (int
) mp-
>in_open_max
- file_bottom
, (int
) mp-
>stack_size
,
34508 (int
) mp-
>max_internal
, (int
) mp-
>param_size
, (int
) mp-
>buf_size
,
34509 (int
) mp-
>max_in_open
- file_bottom
);
34513 @ It is nice to have have some of the stats available from the API.
34515 @
<Exported function ...@
>=
34516 int mp_memory_usage
(MP mp
);
34517 int mp_hash_usage
(MP mp
);
34518 int mp_param_usage
(MP mp
);
34519 int mp_open_usage
(MP mp
);
34522 int mp_memory_usage
(MP mp
) {
34523 return
(int
) mp-
>var_used
;
34525 int mp_hash_usage
(MP mp
) {
34526 return
(int
) mp-
>st_count
;
34528 int mp_param_usage
(MP mp
) {
34529 return
(int
) mp-
>max_param_stack
;
34531 int mp_open_usage
(MP mp
) {
34532 return
(int
) mp-
>max_in_stack
;
34536 @ We get to the |final_cleanup| routine when \
&{end} or \&{dump} has
34540 void mp_final_cleanup
(MP mp
) {
34541 /* -Wunused
: integer c
; */ /* 0 for \
&{end}, 1 for \&{dump} */
34542 /* clang
: never read
: |c
= cur_mod
();|
*/
34543 if
(mp-
>job_name
== NULL)
34544 mp_open_log_file
(mp
);
34545 while
(mp-
>input_ptr
> 0) {
34547 mp_end_token_list
(mp
);
34549 mp_end_file_reading
(mp
);
34551 while
(mp-
>loop_ptr
!= NULL)
34552 mp_stop_iteration
(mp
);
34553 while
(mp-
>open_parens
> 0) {
34554 mp_print
(mp
, " )");
34555 decr
(mp-
>open_parens
);
34557 while
(mp-
>cond_ptr
!= NULL) {
34558 mp_print_nl
(mp
, "(end occurred when ");
34559 @.end occurred...@
>;
34560 mp_print_cmd_mod
(mp
, mp_fi_or_else
, mp-
>cur_if
);
34561 /* `\.
{if
}' or `\.
{elseif
}' or `\.
{else
}'
*/
34562 if
(mp-
>if_line
!= 0) {
34563 mp_print
(mp
, " on line ");
34564 mp_print_int
(mp
, mp-
>if_line
);
34566 mp_print
(mp
, " was incomplete)");
34567 mp-
>if_line
= if_line_field
(mp-
>cond_ptr
);
34568 mp-
>cur_if
= mp_name_type
(mp-
>cond_ptr
);
34569 mp-
>cond_ptr
= mp_link
(mp-
>cond_ptr
);
34571 if
(mp-
>history
!= mp_spotless
)
34572 if
(((mp-
>history
== mp_warning_issued
)
34573 ||
(mp-
>interaction
< mp_error_stop_mode
)))
34574 if
(mp-
>selector
== term_and_log
) {
34575 mp-
>selector
= term_only
;
34577 "(see the transcript file for additional information)");
34578 @.see the transcript file...@
>;
34579 mp-
>selector
= term_and_log
;
34584 @ @
<Declarations@
>=
34585 static void mp_final_cleanup
(MP mp
);
34586 static void mp_init_prim
(MP mp
);
34587 static void mp_init_tab
(MP mp
);
34590 void mp_init_prim
(MP mp
) { /* initialize all the primitives
*/
34594 void mp_init_tab
(MP mp
) { /* initialize other tables
*/
34595 @
<Initialize table entries@
>;
34599 @ When we begin the following code
, \MP's tables may still contain garbage
;
34600 thus we must proceed cautiously to get bootstrapped in.
34602 But when we finish this part of the program
, \MP\ is ready to call on the
34603 |main_control| routine to do its work.
34605 @
<Get the first line...@
>=
34607 @
<Initialize the input routines@
>;
34608 if
(!mp-
>ini_version
) {
34609 if
(!mp_load_preload_file
(mp
)) {
34610 mp-
>history
= mp_fatal_error_stop
;
34614 @
<Initializations following first line@
>;
34618 @ @
<Initializations following first line@
>=
34619 mp-
>buffer
[limit
] = (ASCII_code
) '
%'
;
34620 mp_fix_date_and_time
(mp
);
34621 if
(mp-
>random_seed
== 0)
34622 mp-
>random_seed
= (number_to_scaled
(internal_value
(mp_time
)) / number_to_scaled
(unity_t
)) + number_to_scaled
(internal_value
(mp_day
));
34623 init_randoms
(mp-
>random_seed
);
34624 initialize_print_selector
();
34625 mp_normalize_selector
(mp
);
34627 if
(mp-
>buffer
[loc
] != '\\'
)
34628 mp_start_input
(mp
); /* \
&{input} assumed */
34633 @
* System-dependent changes.
34634 This section should be replaced
, if necessary
, by any special
34635 modification of the program
34636 that are necessary to make \MP\ work at a particular installation.
34637 It is usually best to design your change file so that all changes to
34638 previous sections preserve the section numbering
; then everybody's version
34639 will be consistent with the published program. More extensive changes
,
34640 which introduce new sections
, can be inserted here
; then only the index
34641 itself will get a new section number.
34642 @^system dependencies@
>
34645 Here is where you can find all uses of each identifier in the program
,
34646 with underlined entries pointing to where the identifier was defined.
34647 If the identifier is only one letter long
, however
, you get to see only
34648 the underlined entries.
{\sl All references are to section numbers instead of
34651 This index also lists error messages and other aspects of the program
34652 that you might want to look up some day. For example
, the entry
34653 for ``system dependencies'' lists all sections that should receive
34654 special attention from people who are installing \MP\ in a new
34655 operating environment. A list of various things that can't happen appears
34656 under ``this can't happen''.
34657 Approximately
25 sections are listed under ``inner loop''
; these account
34658 for more than
60\pct
! of \MP's running time
, exclusive of input and output.