1 /* Graph reducer.
2 */
3
4 /*
5
6 Copyright (C) 1991-2003 The National Gallery
7
8 This program is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2 of the License, or
11 (at your option) any later version.
12
13 This program is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
17
18 You should have received a copy of the GNU General Public License along
19 with this program; if not, write to the Free Software Foundation, Inc.,
20 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
21
22 */
23
24 /*
25
26 These files are distributed with VIPS - http://www.vips.ecs.soton.ac.uk
27
28 */
29
30 #include "ip.h"
31
32 /* trace each regeneration
33 #define DEBUG_REGEN
34 */
35
36 /* trace each reduction
37 #define DEBUG_TRACE
38 */
39
40 /* trace copies of code from compile heap to main heap.
41 #define DEBUG_COPY
42 */
43
44 /* trace just member regeneration
45 #define DEBUG_REGEN_MEMBER
46 */
47
48 /* Turn on WHNF tests.
49 #define WHNF_DEBUG
50 */
51
52 /* regular tests that we stay in weak head normal form
53 #define WHNF_DEBUG
54 */
55
56 /* State of the reduction engine.
57 */
58 Reduce *reduce_context;
59
60 /* Index with a CombinatorType, get the number of args that combinator takes.
61 COMB_S = 0,
62 COMB_SL,
63 COMB_SR,
64 COMB_I,
65 COMB_K,
66 COMB_GEN,
67 */
68 static int nargs[] = {3, 3, 3, 1, 2, 3};
69
70 /* Recomps this time.
71 */
72 int reduce_total_recomputations = 0;
73
74 /* The current expr being reduced. Used for computation feedback messages.
75 */
76 static Expr *reduce_current_expr = NULL;
77
78 /* Eval error here. Longjmp back a ways.
79 */
80 void
reduce_throw(Reduce * rc)81 reduce_throw( Reduce *rc )
82 {
83 if( !rc->running )
84 error( "panic: uncaught exception in reduce_throw()!" );
85 else
86 longjmp( rc->error[--rc->running], -1 );
87 }
88
89
90 static gboolean
reduce_safe_pointer_wrap(Reduce * rc,PElement * out,reduce_safe_pointer_fn fn,void * a,void * b,void * c,void * d,void ** result)91 reduce_safe_pointer_wrap( Reduce *rc,
92 PElement *out, reduce_safe_pointer_fn fn,
93 void *a, void *b, void *c, void *d,
94 void **result )
95 {
96 REDUCE_CATCH_START( FALSE );
97 *result = fn( rc, out, a, b, c, d );
98 REDUCE_CATCH_STOP;
99
100 return( TRUE );
101 }
102
103 /* Call a function, passing in a "safe" PElement ... ie. the PElement points
104 * at a fresh element which will be safe from the GC.
105 */
106 void *
reduce_safe_pointer(Reduce * rc,reduce_safe_pointer_fn fn,void * a,void * b,void * c,void * d)107 reduce_safe_pointer( Reduce *rc, reduce_safe_pointer_fn fn,
108 void *a, void *b, void *c, void *d )
109 {
110 Element e;
111 PElement pe;
112 void *result;
113
114 e.type = ELEMENT_NOVAL;
115 e.ele = (void *) 12;
116 PEPOINTE( &pe, &e );
117 heap_register_element( rc->heap, &e );
118
119 if( !reduce_safe_pointer_wrap( rc, &pe, fn, a, b, c, d, &result ) ) {
120 heap_unregister_element( rc->heap, &e );
121 reduce_throw( rc );
122 }
123 heap_unregister_element( rc->heap, &e );
124
125 return( result );
126 }
127
128 void
reduce_error_typecheck(Reduce * rc,PElement * e,const char * name,const char * type)129 reduce_error_typecheck( Reduce *rc,
130 PElement *e, const char *name, const char *type )
131 {
132 char txt[1024];
133 VipsBuf buf = VIPS_BUF_STATIC( txt );
134
135 error_top( _( "Typecheck error." ) );
136 vips_buf_appendf( &buf,
137 _( "%s expected %s, instead saw:" ), name, type );
138 vips_buf_appends( &buf, "\n " );
139 itext_value_ev( rc, &buf, e );
140 error_sub( "%s", vips_buf_all( &buf ) );
141
142 reduce_throw( rc );
143 }
144
145 static void
reduce_error_toobig(Reduce * rc,const char * name)146 reduce_error_toobig( Reduce *rc, const char *name )
147 {
148 error_top( _( "Overflow error." ) );
149 error_sub( _( "%s too long." ), name );
150 reduce_throw( rc );
151 }
152
153 /* 'get' a list: convert a MANAGEDSTRING into a list, if necessary.
154 */
155 void
reduce_get_list(Reduce * rc,PElement * list)156 reduce_get_list( Reduce *rc, PElement *list )
157 {
158 if( !heap_get_list( list ) )
159 reduce_throw( rc );
160 }
161
162 /* Map over a heap list. Reduce the list spine as we go, don't reduce the
163 * heads.
164 */
165 void *
reduce_map_list(Reduce * rc,PElement * base,reduce_map_list_fn fn,void * a,void * b)166 reduce_map_list( Reduce *rc,
167 PElement *base, reduce_map_list_fn fn, void *a, void *b )
168 {
169 PElement e = *base;
170
171 reduce_spine( rc, &e );
172
173 if( !PEISLIST( &e ) )
174 reduce_error_typecheck( rc, &e, "reduce_map_list", "list" );
175
176 while( PEISFLIST( &e ) ) {
177 PElement head;
178 void *res;
179
180 reduce_get_list( rc, &e );
181
182 /* Apply user function to the head.
183 */
184 PEGETHD( &head, &e );
185 if( (res = fn( rc, &head, a, b )) )
186 return( res );
187
188 /* Reduce the tail.
189 */
190 PEGETTL( &e, &e );
191 reduce_spine( rc, &e );
192 }
193
194 return( NULL );
195 }
196
197 typedef struct _ReduceMapDict {
198 reduce_map_dict_fn fn;
199 void *a;
200 void *b;
201 } ReduceMapDict;
202
203 static void *
reduce_map_dict_entry(Reduce * rc,PElement * head,ReduceMapDict * map_dict)204 reduce_map_dict_entry( Reduce *rc, PElement *head, ReduceMapDict *map_dict )
205 {
206 char key[256];
207 PElement p1, p2;
208 void *result;
209
210 reduce_spine( rc, head );
211 if( !PEISFLIST( head ) )
212 reduce_error_typecheck( rc, head, "reduce_map_dict", "[*]" );
213
214 reduce_get_list( rc, head );
215 PEGETHD( &p1, head );
216 reduce_get_string( rc, &p1, key, 256 );
217 PEGETTL( &p2, head );
218
219 reduce_spine( rc, &p2 );
220 if( !PEISFLIST( &p2 ) )
221 reduce_error_typecheck( rc, &p2, "reduce_map_dict", "[*]" );
222
223 reduce_get_list( rc, &p2 );
224 PEGETHD( &p1, &p2 );
225 if( (result = map_dict->fn( rc, key, &p1, map_dict->a, map_dict->b )) )
226 return( result );
227
228 PEGETTL( &p1, &p2 );
229 reduce_spine( rc, &p1 );
230 if( !PEISELIST( &p1 ) )
231 reduce_error_typecheck( rc, &p1, "reduce_map_dict", "[]" );
232
233 return( NULL );
234 }
235
236 /* Map over a list of ["key", value] pairs.
237 */
238 void *
reduce_map_dict(Reduce * rc,PElement * base,reduce_map_dict_fn fn,void * a,void * b)239 reduce_map_dict( Reduce *rc, PElement *base,
240 reduce_map_dict_fn fn, void *a, void *b )
241 {
242 ReduceMapDict map_dict;
243
244 map_dict.fn = fn;
245 map_dict.a = a;
246 map_dict.b = b;
247
248 return( reduce_map_list( rc, base,
249 (reduce_map_list_fn) reduce_map_dict_entry, &map_dict, NULL ) );
250 }
251
252 static void *
reduce_clone_list_sub(Reduce * rc,PElement * head,PElement * out)253 reduce_clone_list_sub( Reduce *rc, PElement *head, PElement *out )
254 {
255 PElement lhs;
256
257 if( !heap_list_add( rc->heap, out, &lhs ) )
258 reduce_throw( rc );
259 PEPUTPE( &lhs, head );
260
261 heap_list_next( out );
262
263 return( NULL );
264 }
265
266 /* Clone a list ... just clone the spine, copy pointers to the heads. Reduce
267 * the list as we go (strict shallow clone). We update out as we go, so that
268 * on return it points to the tail (always []) of the cloned list.
269 */
270 void
reduce_clone_list(Reduce * rc,PElement * base,PElement * out)271 reduce_clone_list( Reduce *rc, PElement *base, PElement *out )
272 {
273 heap_list_init( out );
274
275 (void) reduce_map_list( rc, base,
276 (reduce_map_list_fn) reduce_clone_list_sub, out, NULL );
277 }
278
279 /* Sub-fn of below. Add a character to the buffer.
280 */
281 static void *
reduce_add_char(Reduce * rc,PElement * base,char ** buf,int * sz)282 reduce_add_char( Reduce *rc, PElement *base, char **buf, int *sz )
283 {
284 /* Overflow?
285 */
286 if( *sz == 0 )
287 reduce_error_toobig( rc, "[char]" );
288
289 /* Reduce this list element.
290 */
291 reduce_spine( rc, base );
292
293 /* Should be a char.
294 */
295 if( !PEISCHAR( base ) )
296 reduce_error_typecheck( rc, base, "reduce_add_char", "char" );
297
298 /* Add to buffer.
299 */
300 **buf = PEGETCHAR( base );
301 (*buf)++;
302 (*sz)--;
303
304 return( NULL );
305 }
306
307 /* Evaluate a PElement into a string buffer. Return the number of characters
308 * in string, not including '\0' terminator.
309 */
310 int
reduce_get_string(Reduce * rc,PElement * base,char * buf,int n)311 reduce_get_string( Reduce *rc, PElement *base, char *buf, int n )
312 {
313 int sz = n - 1;
314
315 reduce_spine( rc, base );
316
317 if( PEISMANAGEDSTRING( base ) ) {
318 /* A static string ... rather than expanding to a list and
319 * parsing, we can copy directly.
320 */
321 Managedstring *managedstring = PEGETMANAGEDSTRING( base );
322
323 im_strncpy( buf, managedstring->string, n );
324 sz -= strlen( buf );
325 }
326 else {
327 (void) reduce_map_list( rc, base,
328 (reduce_map_list_fn) reduce_add_char, &buf, &sz );
329
330 /* Add '\0' terminator.
331 */
332 *buf = '\0';
333 }
334
335 return( n - sz - 1 );
336 }
337
338 static void *
reduce_get_lstring_sub(Reduce * rc,PElement * base,GSList ** labels,int * n)339 reduce_get_lstring_sub( Reduce *rc, PElement *base, GSList **labels, int *n )
340 {
341 char buf[MAX_STRSIZE];
342
343 (void) reduce_get_string( rc, base, buf, MAX_STRSIZE );
344 *labels = g_slist_append( *labels, g_strdup( buf ) );
345
346 return( NULL );
347 }
348
349 /* Evaluate to [[char]]. Return the number of strings we read.
350 */
351 int
reduce_get_lstring(Reduce * rc,PElement * base,GSList ** labels)352 reduce_get_lstring( Reduce *rc, PElement *base, GSList **labels )
353 {
354 int n;
355
356 n = 0;
357 *labels = NULL;
358 (void) reduce_map_list( rc, base,
359 (reduce_map_list_fn) reduce_get_lstring_sub, labels, &n );
360
361 return( n );
362 }
363
364 /* Get an element as a boolean.
365 */
366 gboolean
reduce_get_bool(Reduce * rc,PElement * base)367 reduce_get_bool( Reduce *rc, PElement *base )
368 {
369 reduce_spine( rc, base );
370
371 if( !PEISBOOL( base ) )
372 reduce_error_typecheck( rc, base, "reduce_get_bool", "bool" );
373
374 return( PEGETBOOL( base ) );
375 }
376
377 /* Get an element as a real.
378 */
379 double
reduce_get_real(Reduce * rc,PElement * base)380 reduce_get_real( Reduce *rc, PElement *base )
381 {
382 /* Reduce this element.
383 */
384 reduce_spine( rc, base );
385
386 /* Should be a real.
387 */
388 if( !PEISREAL( base ) )
389 reduce_error_typecheck( rc, base, "reduce_get_real", "real" );
390
391 return( PEGETREAL( base ) );
392 }
393
394 /* Get an element as a class.
395 */
396 void
reduce_get_class(Reduce * rc,PElement * base)397 reduce_get_class( Reduce *rc, PElement *base )
398 {
399 /* Reduce this element.
400 */
401 reduce_spine( rc, base );
402
403 /* Should be a class.
404 */
405 if( !PEISCLASS( base ) )
406 reduce_error_typecheck( rc, base, "reduce_get_class", "class" );
407 }
408
409 /* Get an element as an image.
410 */
411 Imageinfo *
reduce_get_image(Reduce * rc,PElement * base)412 reduce_get_image( Reduce *rc, PElement *base )
413 {
414 /* Reduce this element.
415 */
416 reduce_spine( rc, base );
417
418 /* Should be an image.
419 */
420 if( !PEISIMAGE( base ) )
421 reduce_error_typecheck( rc, base, "reduce_get_image", "image" );
422
423 return( PEGETII( base ) );
424 }
425
426 /* Sub-fn of below. Add a real to the buffer.
427 */
428 static void *
reduce_add_real(Reduce * rc,PElement * base,double ** buf,int * sz)429 reduce_add_real( Reduce *rc, PElement *base, double **buf, int *sz )
430 {
431 /* Overflow?
432 */
433 if( *sz == 0 )
434 reduce_error_toobig( rc, "[real]" );
435
436 /* Add to buffer.
437 */
438 **buf = reduce_get_real( rc, base );
439 (*buf)++;
440 (*sz)--;
441
442 return( NULL );
443 }
444
445 /* Get an element as a realvec. Return length of vector.
446 */
447 int
reduce_get_realvec(Reduce * rc,PElement * base,double * buf,int n)448 reduce_get_realvec( Reduce *rc, PElement *base, double *buf, int n )
449 {
450 int sz = n;
451
452 (void) reduce_map_list( rc, base,
453 (reduce_map_list_fn) reduce_add_real, &buf, &sz );
454
455 return( n - sz );
456 }
457
458 /* Sub-fn of below. Add an ii to the buffer.
459 */
460 static void *
reduce_add_image(Reduce * rc,PElement * base,Imageinfo *** buf,int * sz)461 reduce_add_image( Reduce *rc, PElement *base, Imageinfo ***buf, int *sz )
462 {
463 /* Overflow?
464 */
465 if( *sz == 0 )
466 reduce_error_toobig( rc, "[image]" );
467
468 /* Add to buffer.
469 */
470 **buf = reduce_get_image( rc, base );
471 (*buf)++;
472 (*sz)--;
473
474 return( NULL );
475 }
476
477 /* Get an element as a realvec. Return length of vector.
478 */
479 int
reduce_get_imagevec(Reduce * rc,PElement * base,Imageinfo ** buf,int n)480 reduce_get_imagevec( Reduce *rc, PElement *base, Imageinfo **buf, int n )
481 {
482 int sz = n;
483
484 (void) reduce_map_list( rc, base,
485 (reduce_map_list_fn) reduce_add_image, &buf, &sz );
486
487 return( n - sz );
488 }
489
490 /* Test for 1st sz elements are reals. Init sz < 0 for unlimited test.
491 */
492 static void *
reduce_test_real(Reduce * rc,PElement * base,int * sz)493 reduce_test_real( Reduce *rc, PElement *base, int *sz )
494 {
495 /* Tested enough?
496 */
497 if( *sz == 0 )
498 return( NULL );
499
500 (void) reduce_get_real( rc, base );
501 (*sz)--;
502
503 return( NULL );
504 }
505
506 /* Sub fn ... get the length of a list of real.
507 */
508 int
reduce_get_real_size(Reduce * rc,PElement * base)509 reduce_get_real_size( Reduce *rc, PElement *base )
510 {
511 int n;
512
513 n = -1;
514 (void) reduce_map_list( rc, base,
515 (reduce_map_list_fn) reduce_test_real, &n, NULL );
516
517 return( -1 - n );
518 }
519
520 /* Sub fn of below ... get the length of one line from a matrix.
521 */
522 static void *
reduce_get_line_size(Reduce * rc,PElement * base,int * w,int * h)523 reduce_get_line_size( Reduce *rc, PElement *base, int *w, int *h )
524 {
525 int l;
526
527 l = reduce_get_real_size( rc, base );
528
529 if( *w == 0 )
530 *w = l;
531 else if( *w != l ) {
532 error_top( _( "Not rectangular." ) );
533 error_sub( _( "Matrix of real is not rectangular. "
534 "Found row of length %d, should be %d." ), l, *w );
535 reduce_throw( rc );
536 }
537
538 *h += 1;
539
540 return( NULL );
541 }
542
543 /* Find the size of a matrix. Write xsize/ysize to args.
544 */
545 void
reduce_get_matrix_size(Reduce * rc,PElement * base,int * xsize,int * ysize)546 reduce_get_matrix_size( Reduce *rc,
547 PElement *base, int *xsize, int *ysize )
548 {
549 int w, h;
550
551 w = 0;
552 h = 0;
553 (void) reduce_map_list( rc, base,
554 (reduce_map_list_fn) reduce_get_line_size, &w, &h );
555
556 if( w == 0 || h == 0 ) {
557 error_top( _( "Zero dimension." ) );
558 error_sub( _( "Matrix has width %d, height %d." ), w, h );
559 reduce_throw( rc );
560 }
561
562 *xsize = w;
563 *ysize = h;
564 }
565
566 /* Track stuff during a get_matrix in one of these.
567 */
568 typedef struct {
569 double *buf; /* Start of output buffer */
570 int mx; /* Size of output buffer */
571 int w, h; /* Size of matrix we have generated */
572 int i; /* Current write point */
573 } GetMatrixInfo;
574
575 /* Sub-fn of below ... get another line of the matrix.
576 */
577 static void *
reduce_get_line(Reduce * rc,PElement * base,GetMatrixInfo * gmi)578 reduce_get_line( Reduce *rc, PElement *base, GetMatrixInfo *gmi )
579 {
580 int l;
581 int remain = gmi->mx - gmi->i;
582
583 /* Read next line from matrix.
584 */
585 l = reduce_get_realvec( rc, base, gmi->buf + gmi->i, remain );
586
587 /* Overflow?
588 */
589 if( l > remain )
590 reduce_error_toobig( rc, "Matrix" );
591
592 /* 1st line?
593 */
594 if( gmi->h == 0 )
595 gmi->w = l;
596 else if( l != gmi->w ) {
597 error_top( _( "Not rectangular." ) );
598 error_sub( _( "Matrix of real is not rectangular. "
599 "Found row of length %d, should be %d." ), l, gmi->w );
600 reduce_throw( rc );
601 }
602
603 /* Move pointers on!
604 */
605 gmi->h++;
606 gmi->i += l;
607
608 return( NULL );
609 }
610
611 /* Get an element as a matrix. Return length of buffer used.
612 * Write xsize/ysize to args.
613 */
614 int
reduce_get_matrix(Reduce * rc,PElement * base,double * buf,int n,int * xsize,int * ysize)615 reduce_get_matrix( Reduce *rc,
616 PElement *base, double *buf, int n, int *xsize, int *ysize )
617 {
618 GetMatrixInfo gmi;
619
620 gmi.buf = buf;
621 gmi.mx = n;
622 gmi.w = gmi.h = 0;
623 gmi.i = 0;
624
625 (void) reduce_map_list( rc, base,
626 (reduce_map_list_fn) reduce_get_line, &gmi, NULL );
627
628 *xsize = gmi.w;
629 *ysize = gmi.h;
630
631 return( gmi.i );
632 }
633
634 /* Test for object is the empty list.
635 */
636 gboolean
reduce_is_elist(Reduce * rc,PElement * base)637 reduce_is_elist( Reduce *rc, PElement *base )
638 {
639 reduce_spine( rc, base );
640 if( PEISELIST( base ) )
641 return( TRUE );
642
643 return( FALSE );
644 }
645
646 /* Test for object is any list.
647 */
648 gboolean
reduce_is_list(Reduce * rc,PElement * base)649 reduce_is_list( Reduce *rc, PElement *base )
650 {
651 reduce_spine( rc, base );
652 if( PEISLIST( base ) )
653 return( TRUE );
654
655 return( FALSE );
656 }
657
658 /* Sub-fn of below. Test for 1st sz elements are char. We have several
659 * possible return values :-(
660 *
661 * - evaluation error ... we can throw an exception
662 * - we find a non-char in the first n elements ... return -1
663 * - we have tested the first n and want to stop looking ... return -2
664 * - all OK so far, but we want to keep looking ... return NULL
665 */
666 static void *
reduce_test_char(Reduce * rc,PElement * base,int * sz)667 reduce_test_char( Reduce *rc, PElement *base, int *sz )
668 {
669 /* Tested enough?
670 */
671 if( *sz == 0 )
672 return( (void *) -2 );
673
674 /* Reduce this list element.
675 */
676 reduce_spine( rc, base );
677
678 /* Should be a char.
679 */
680 if( !PEISCHAR( base ) )
681 return( (void *) -1 );
682
683 /* Move on.
684 */
685 (*sz)--;
686
687 return( NULL );
688 }
689
690 /* Test the first n elements of a list are char. n < 0 means test all
691 * elements.
692 */
693 static gboolean
reduce_n_is_string(Reduce * rc,PElement * base,int sz)694 reduce_n_is_string( Reduce *rc, PElement *base, int sz )
695 {
696 void *result;
697
698 reduce_spine( rc, base );
699
700 /* We know managedstrings are strings without needing to expand them.
701 */
702 if( PEISMANAGEDSTRING( base ) )
703 return( TRUE );
704
705 /* reduce_map_list() will throw an exeception if we give it a
706 * non-list.
707 */
708 if( !PEISLIST( base ) )
709 return( FALSE );
710
711 result = reduce_map_list( rc, base,
712 (reduce_map_list_fn) reduce_test_char, &sz, NULL );
713
714 if( result == (void *) -1 )
715 return( FALSE );
716
717 return( TRUE );
718 }
719
720 /* Test for object is string. Just test the first few elements, so we
721 * allow infinite strings.
722 */
723 gboolean
reduce_is_string(Reduce * rc,PElement * base)724 reduce_is_string( Reduce *rc, PElement *base )
725 {
726 return( reduce_n_is_string( rc, base, 4 ) );
727 }
728
729 /* Test for list is a finite string.
730 */
731 gboolean
reduce_is_finitestring(Reduce * rc,PElement * base)732 reduce_is_finitestring( Reduce *rc, PElement *base )
733 {
734 return( reduce_n_is_string( rc, base, -1 ) );
735 }
736
737 /* Test for list is realvec.
738 */
739 gboolean
reduce_is_realvec(Reduce * rc,PElement * base)740 reduce_is_realvec( Reduce *rc, PElement *base )
741 {
742 int sz = 4;
743
744 reduce_spine( rc, base );
745 if( !PEISLIST( base ) )
746 return( FALSE );
747
748 if( reduce_map_list( rc, base,
749 (reduce_map_list_fn) reduce_test_real, &sz, NULL ) )
750 return( FALSE );
751
752 return( TRUE );
753 }
754
755 /* Test for 1st sz elements are reals. Init sz < 0 for unlimited test.
756 */
757 static void *
reduce_test_image(Reduce * rc,PElement * base,int * sz)758 reduce_test_image( Reduce *rc, PElement *base, int *sz )
759 {
760 /* Tested enough?
761 */
762 if( *sz == 0 )
763 return( NULL );
764
765 (void) reduce_get_image( rc, base );
766 (*sz)--;
767
768 return( NULL );
769 }
770
771 /* Test for list is imagevec.
772 */
773 gboolean
reduce_is_imagevec(Reduce * rc,PElement * base)774 reduce_is_imagevec( Reduce *rc, PElement *base )
775 {
776 int sz = 4;
777
778 reduce_spine( rc, base );
779 if( !PEISLIST( base ) )
780 return( FALSE );
781
782 if( reduce_map_list( rc, base,
783 (reduce_map_list_fn) reduce_test_image, &sz, NULL ) )
784 return( FALSE );
785
786 return( TRUE );
787 }
788
789 /* Sub-fn of below ... test another line of the matrix.
790 */
791 static void *
reduce_test_line(Reduce * rc,PElement * base,int * w,int * h)792 reduce_test_line( Reduce *rc, PElement *base, int *w, int *h )
793 {
794 /* Test next line from matrix.
795 */
796 if( !reduce_is_realvec( rc, base ) )
797 return( base );
798
799 return( NULL );
800 }
801
802 /* Test for object is [[real]] .. don't test for rectangularness.
803 */
804 gboolean
reduce_is_matrix(Reduce * rc,PElement * base)805 reduce_is_matrix( Reduce *rc, PElement *base )
806 {
807 reduce_spine( rc, base );
808 if( !PEISLIST( base ) )
809 return( FALSE );
810
811 if( reduce_map_list( rc, base,
812 (reduce_map_list_fn) reduce_test_line, NULL, NULL ) )
813 return( FALSE );
814
815 return( TRUE );
816 }
817
818 /* Test for object is a class.
819 */
820 gboolean
reduce_is_class(Reduce * rc,PElement * klass)821 reduce_is_class( Reduce *rc, PElement *klass )
822 {
823 reduce_spine( rc, klass );
824 if( PEISCLASS( klass ) )
825 return( TRUE );
826
827 return( FALSE );
828 }
829
830 /* Test for instance is an exact instance ... ie. no inheritance.
831
832 FIXME ... yuk! strcmp()!!
833
834 */
835 gboolean
reduce_is_instanceof_exact(Reduce * rc,const char * name,PElement * instance)836 reduce_is_instanceof_exact( Reduce *rc, const char *name, PElement *instance )
837 {
838 char txt[256];
839 VipsBuf buf = VIPS_BUF_STATIC( txt );
840
841 if( !reduce_is_class( rc, instance ) )
842 return( FALSE );
843
844 symbol_qualified_name( PEGETCLASSCOMPILE( instance )->sym, &buf );
845 if( strcmp( name, vips_buf_all( &buf ) ) == 0 )
846 return( TRUE );
847
848 return( FALSE );
849 }
850
851 /* Test for thing is an instance of the named class symbol.
852 */
853 gboolean
reduce_is_instanceof(Reduce * rc,const char * name,PElement * instance)854 reduce_is_instanceof( Reduce *rc, const char *name, PElement *instance )
855 {
856 PElement super;
857
858 reduce_spine( rc, instance );
859 if( !PEISCLASS( instance ) )
860 return( FALSE );
861 if( reduce_is_instanceof_exact( rc, name, instance ) )
862 return( TRUE );
863 if( class_get_super( instance, &super ) && !PEISELIST( &super ) )
864 return( reduce_is_instanceof( rc, name, &super ) );
865
866 return( FALSE );
867 }
868
869 /* Find the length of a list, with a bailout for the largest size we test.
870 * Handy for avoiding finding the length of "[1..]".
871 */
872 int
reduce_list_length_max(Reduce * rc,PElement * base,int max_length)873 reduce_list_length_max( Reduce *rc, PElement *base, int max_length )
874 {
875 PElement p;
876 int i;
877
878 /* Reduce to first element.
879 */
880 p = *base;
881 reduce_spine( rc, &p );
882
883 /* Does it look like the start of a list?
884 */
885 if( !PEISLIST( &p ) )
886 reduce_error_typecheck( rc, &p, _( "List length" ), "list" );
887
888 if( PEISMANAGEDSTRING( &p ) ) {
889 Managedstring *managedstring = PEGETMANAGEDSTRING( &p );
890
891 i = strlen( managedstring->string );
892 }
893 else {
894 /* Loop down list.
895 */
896 for( i = 0; PEISFLIST( &p ); i++ ) {
897 HeapNode *hn;
898
899 if( max_length != -1 && i > max_length )
900 reduce_error_toobig( rc, "list" );
901
902 reduce_get_list( rc, &p );
903
904 hn = PEGETVAL( &p );
905 PEPOINTRIGHT( hn, &p );
906
907 reduce_spine( rc, &p );
908 }
909
910 g_assert( PEISELIST( &p ) );
911 }
912
913 return( i );
914 }
915
916 /* Find the length of a list.
917 */
918 int
reduce_list_length(Reduce * rc,PElement * base)919 reduce_list_length( Reduce *rc, PElement *base )
920 {
921 return( reduce_list_length_max( rc, base, -1 ) );
922 }
923
924 /* Point "out" at the nth element of a list. Index from 0.
925 */
926 void
reduce_list_index(Reduce * rc,PElement * base,int n,PElement * out)927 reduce_list_index( Reduce *rc, PElement *base, int n, PElement *out )
928 {
929 PElement p;
930 int i;
931 HeapNode *hn;
932
933 if( n < 0 ) {
934 error_top( _( "Bad argument." ) );
935 error_sub( _( "List index must be positive, not %d" ), n );
936 reduce_throw( rc );
937 }
938
939 p = *base;
940 reduce_spine( rc, &p );
941
942 if( !PEISLIST( &p ) )
943 reduce_error_typecheck( rc, &p, _( "List index" ), "list" );
944
945 for( i = n;; ) {
946 if( PEISELIST( &p ) ) {
947 error_top( _( "Bad argument." ) );
948 error_sub( _( "List only has %d elements, "
949 "unable to get element %d." ), n - i, n );
950 reduce_throw( rc );
951 }
952
953 g_assert( PEISFLIST( &p ) );
954
955 reduce_get_list( rc, &p );
956
957 hn = PEGETVAL( &p );
958 PEPOINTRIGHT( hn, &p );
959
960 if( --i < 0 )
961 break;
962
963 reduce_spine( rc, &p );
964 }
965
966 if( trace_flags & TRACE_OPERATOR ) {
967 VipsBuf *buf = trace_push();
968
969 trace_pelement( base );
970 vips_buf_appendf( buf, " \"?\" %d ->\n", n );
971 }
972
973 PEPOINTLEFT( hn, out );
974
975 if( trace_flags & TRACE_OPERATOR ) {
976 trace_result( TRACE_OPERATOR, out );
977 trace_pop();
978 }
979 }
980
981 /* No args allowed error.
982 */
983 static void
argserror(Reduce * rc,PElement * a)984 argserror( Reduce *rc, PElement *a )
985 {
986 char txt[MAX_ERROR_FRAG];
987 VipsBuf buf = VIPS_BUF_STATIC( txt );
988
989 itext_value_ev( rc, &buf, a );
990
991 error_top( _( "No arguments allowed." ) );
992 error_sub( _( "Object \"%s\" should have no arguments." ),
993 vips_buf_all( &buf ) );
994 reduce_throw( rc );
995 }
996
997 #ifdef WHNF_DEBUG
998 /* Test for PElement is in weak head-normal form.
999 */
1000 static gboolean
is_WHNF(PElement * out)1001 is_WHNF( PElement *out )
1002 {
1003 PElement spine;
1004 int i;
1005 HeapNode *hn;
1006 Symbol *sym;
1007 Compile *compile;
1008 int na;
1009
1010 /* Might be a base type ...
1011 */
1012 if( PEISREAL( out ) ||
1013 PEISCOMPLEX( out ) || PEISNUM( out ) || PEISCHAR( out ) ||
1014 PEISBOOL( out ) || PEISTAG( out ) || PEISIMAGE( out ) ||
1015 PEISLIST( out ) || PEISCLASS( out ) || PEISSYMREF( out ) ||
1016 PEISCOMPILEREF( out ) || PEISNOVAL( out ) )
1017 return( TRUE );
1018
1019 /* Must be a function or generator ... loop down the spine, counting
1020 * args.
1021 */
1022 for( spine = *out, i = 0; PEGETTYPE( &spine ) == ELEMENT_NODE; i++ ) {
1023 hn = PEGETVAL( &spine );
1024
1025 if( hn->type != TAG_APPL )
1026 break;
1027
1028 PEPOINTLEFT( PEGETVAL( &spine ), &spine );
1029 }
1030
1031 if( PEISBINOP( &spine ) ) {
1032 if( i > 1 )
1033 return( FALSE );
1034 }
1035 else if( PEISUNOP( &spine ) ) {
1036 if( i > 0 )
1037 return( FALSE );
1038 }
1039 else if( PEISCOMB( &spine ) ) {
1040 if( i > nargs[(int) PEGETCOMB( &spine )] - 1 )
1041 return( FALSE );
1042 }
1043 else if( PEISCONSTRUCTOR( &spine ) ) {
1044 compile = PEGETCOMPILE( &spine );
1045 na = compile->nparam + compile->nsecret;
1046
1047 if( i > na ) {
1048 printf( "constructor %s with %d args ",
1049 symbol_name( sym ), i );
1050 printf( "should have %d args\n", compile->nparam );
1051 return( FALSE );
1052 }
1053 }
1054 else if( PEISSYMBOL( &spine ) ) {
1055 /* If it's a VIPS or a builtin with too few args, it's OK.
1056 */
1057 sym = SYMBOL( PEGETVAL( &spine ) );
1058
1059 if( sym->type == SYM_EXTERNAL ) {
1060 if( i < sym->fn_nargs )
1061 return( TRUE );
1062 }
1063 else if( sym->type == SYM_BUILTIN ) {
1064 if( i < sym->builtin->nargs )
1065 return( TRUE );
1066 }
1067
1068 /* Nope ... should have been reduced.
1069 */
1070 return( FALSE );
1071 }
1072 else {
1073 return( FALSE );
1074 }
1075
1076 return( TRUE );
1077 }
1078 #endif /*WHNF_DEBUG*/
1079
1080 /* Main reduction machine loop.
1081 */
1082 void
reduce_spine(Reduce * rc,PElement * out)1083 reduce_spine( Reduce *rc, PElement *out )
1084 {
1085 Heap *heap = rc->heap;
1086 PElement np;
1087
1088 /* Check for possible C stack overflow ... can't go over 2M on most
1089 * systems if we're using (or any of our libs are using) threads.
1090 */
1091 if( (char *) main_c_stack_base - (char *) &rc > 2000000 ) {
1092 error_top( _( "Overflow error." ) );
1093 error_sub( _( "C stack overflow. Expression too complex." ) );
1094 reduce_throw( rc );
1095 }
1096
1097 /* Point node pointer at reduction start.
1098 */
1099 np = *out;
1100
1101 /* Start a new frame.
1102 */
1103 RSPUSHFRAME( rc, out );
1104
1105 reduce_start:
1106 reduce_total_recomputations += 1;
1107 if( (reduce_total_recomputations % 100000) == 0 ) {
1108 if( progress_update_expr( reduce_current_expr ) ) {
1109 error_top( _( "Cancelled." ) );
1110 error_sub( _( "Evaluation cancelled." ) );
1111 reduce_throw( rc );
1112 }
1113 }
1114
1115 #ifdef DEBUG_TRACE
1116 {
1117 char txt[1024];
1118 VipsBuf buf = VIPS_BUF_STATIC( txt );
1119
1120 graph_pelement( rc->heap, &buf, out, TRUE );
1121 printf( "reduce_spine: %s\n", vips_buf_all( &buf ) );
1122 }
1123 #endif /*DEBUG_TRACE*/
1124
1125 switch( PEGETTYPE( &np ) ) {
1126 case ELEMENT_CHAR:
1127 case ELEMENT_BOOL:
1128 case ELEMENT_ELIST:
1129 case ELEMENT_TAG:
1130 case ELEMENT_SYMREF:
1131 case ELEMENT_COMPILEREF:
1132 case ELEMENT_MANAGED:
1133 /* Base type .. no more reduction needed.
1134 */
1135
1136 /* Should have no args.
1137 */
1138 if( RSFRAMESIZE( rc ) != 0 )
1139 argserror( rc, &np );
1140
1141 break;
1142
1143 case ELEMENT_CONSTRUCTOR:
1144 {
1145 Compile *compile;
1146 HeapNode **arg;
1147 PElement rhs1;
1148 int na;
1149
1150 /* Class constructor.
1151 */
1152 compile = PEGETCOMPILE( &np );
1153 g_assert( is_class( compile ) );
1154
1155 /* Class args ... real params, secret params.
1156 */
1157 na = compile->nparam + compile->nsecret;
1158
1159 /* Get args.
1160 */
1161 if( !RSCHECKARGS( rc, na ) )
1162 break;
1163 arg = &RSGET( rc, na - 1 );
1164
1165 if( na == 0 ) {
1166 /* Zero args ... just construct on top of the current
1167 * node pointer.
1168 */
1169 action_proc_construct( rc, compile, arg, &np );
1170 goto reduce_start;
1171 }
1172
1173 /* Overwrite RHS of arg[0], make LHS into COMB_I.
1174 */
1175 PEPOINTRIGHT( arg[0], &rhs1 );
1176 action_proc_construct( rc, compile, arg, &rhs1 );
1177 PPUTLEFT( arg[0], ELEMENT_COMB, COMB_I );
1178
1179 RSPOP( rc, na );
1180 if( RSFRAMEEMPTY( rc ) )
1181 np = RSGETWB( rc );
1182 else
1183 PEPOINTLEFT( RSGET( rc, 0 ), &np );
1184 PEPUTP( &np,
1185 GETRT( arg[0] ), GETRIGHT( arg[0] ) );
1186
1187 goto reduce_start;
1188 }
1189
1190 case ELEMENT_SYMBOL:
1191 {
1192 Symbol *sym = PEGETSYMBOL( &np );
1193
1194 g_assert( sym );
1195
1196 switch( sym->type ) {
1197 case SYM_VALUE:
1198 {
1199 Compile *compile = sym->expr->compile;
1200
1201 /* Make sure it's clean ... we can get
1202 * links to dirty syms through dynamic dependencies.
1203 */
1204 if( sym->dirty ) {
1205 error_top( _( "No value." ) );
1206 error_sub( _( "Symbol \"%s\" has no value." ),
1207 symbol_name( sym ) );
1208 reduce_throw( rc );
1209 }
1210
1211 /* We copy code, but link to values. We have to take a
1212 * fresh copy of code as (together with any args our
1213 * context might supply) it will expand to a value,
1214 * which we might then edit in a row. We want to make
1215 * sure any edits do not zap the original code.
1216 */
1217 if( compile->nparam + compile->nsecret == 0 ) {
1218 /* Make sure the value has copied to the main
1219 * heap.
1220 */
1221 if( PEISNOVAL( &sym->expr->root ) ) {
1222 gboolean res;
1223
1224 res = reduce_regenerate( sym->expr,
1225 &sym->expr->root );
1226 expr_new_value( sym->expr );
1227
1228 if( !res )
1229 reduce_throw( rc );
1230 }
1231
1232 /* Link to this sym's value.
1233 */
1234 PEPUTPE( &np, &sym->expr->root );
1235 }
1236 else
1237 /* Copy compiled code from the private compile
1238 * heap.
1239 */
1240 if( !heap_copy( rc->heap, compile, &np ) )
1241 reduce_throw( rc );
1242
1243 goto reduce_start;
1244 }
1245
1246 case SYM_PARAM:
1247 /* All params should be taken out by var abstract.
1248 */
1249 printf( "sym-param found, argh: " );
1250 symbol_name_print( sym );
1251 printf( "\n" );
1252 g_assert( FALSE );
1253 break;
1254
1255 case SYM_EXTERNAL:
1256 {
1257 HeapNode **arg;
1258 int na;
1259
1260 /* A VIPS function.
1261 */
1262 na = sym->fn_nargs;
1263
1264 /* Get args.
1265 */
1266 if( !RSCHECKARGS( rc, na ) )
1267 /* Not enough ... function result.
1268 */
1269 break;
1270
1271 /* Run strictly.
1272 */
1273 arg = &RSGET( rc, na - 1 );
1274
1275 action_dispatch( rc, NULL, reduce_spine,
1276 -1, sym->function->name, FALSE,
1277 (ActionFn) call_run, na, arg,
1278 sym->function );
1279
1280 /* Find output element.
1281 */
1282 RSPOP( rc, na );
1283
1284 if( RSFRAMEEMPTY( rc ) )
1285 np = RSGETWB( rc );
1286 else
1287 PEPOINTLEFT( RSGET( rc, 0 ), &np );
1288
1289 /* Write to node above.
1290 */
1291 PEPUTP( &np,
1292 GETRT( arg[0] ), GETRIGHT( arg[0] ) );
1293
1294 goto reduce_start;
1295 }
1296
1297 case SYM_BUILTIN:
1298 {
1299 HeapNode **arg;
1300 int na;
1301
1302 /* A builtin function.
1303 */
1304 na = sym->builtin->nargs;
1305
1306 /* Get args.
1307 */
1308 if( !RSCHECKARGS( rc, na ) )
1309 /* Not enough ... function result.
1310 */
1311 break;
1312
1313 /* Run strictly.
1314 */
1315 arg = &RSGET( rc, na - 1 );
1316
1317 action_dispatch( rc, NULL, reduce_spine,
1318 -1, sym->builtin->name, sym->builtin->override,
1319 (ActionFn) builtin_run,
1320 na, arg, sym->builtin );
1321
1322 /* Find output element.
1323 */
1324 RSPOP( rc, na );
1325
1326 if( RSFRAMEEMPTY( rc ) )
1327 np = RSGETWB( rc );
1328 else
1329 PEPOINTLEFT( RSGET( rc, 0 ), &np );
1330
1331 /* Write to node above.
1332 */
1333 PEPUTP( &np,
1334 GETRT( arg[0] ), GETRIGHT( arg[0] ) );
1335
1336 goto reduce_start;
1337 }
1338
1339 case SYM_ZOMBIE:
1340 {
1341 Symbol *new_sym;
1342
1343 /* Could be defined on an enclosing scope. Search
1344 * outwards for a definition.
1345 */
1346 if( !(new_sym = compile_resolve_top( sym )) ) {
1347 symbol_not_defined( sym );
1348 reduce_throw( rc );
1349 }
1350
1351 /* Zap linked symbol into graph.
1352 */
1353 PEPUTP( &np, ELEMENT_SYMBOL, new_sym );
1354
1355 goto reduce_start;
1356 }
1357
1358 case SYM_ROOT:
1359 case SYM_WORKSPACE:
1360 case SYM_WORKSPACEROOT:
1361 /* Becomes a symref ... base type.
1362 */
1363 PEPUTP( &np, ELEMENT_SYMREF, sym );
1364
1365 /* Should have no args.
1366 */
1367 if( RSFRAMESIZE( rc ) != 0 )
1368 argserror( rc, &np );
1369
1370 break;
1371
1372 default:
1373 g_assert( FALSE );
1374 }
1375
1376 break;
1377 }
1378
1379 case ELEMENT_NODE:
1380 {
1381 HeapNode *hn;
1382
1383 /* Get the node that np points to.
1384 */
1385 hn = PEGETVAL( &np );
1386
1387 switch( hn->type ) {
1388 case TAG_CONS:
1389 case TAG_DOUBLE:
1390 case TAG_COMPLEX:
1391 case TAG_CLASS:
1392 /* Base type ... reduction all done! We don't test
1393 * that class's superclasses are base, as they aren't
1394 * always for non-top-level base types ... see
1395 * reduce_pelement().
1396 */
1397
1398 /* Should have no args.
1399 */
1400 if( RSFRAMESIZE( rc ) != 0 )
1401 argserror( rc, &np );
1402
1403 break;
1404
1405 case TAG_APPL:
1406 /* Function application ... push this node and loop
1407 * down the LHS looking for a combinator.
1408 */
1409
1410 /* Push this node.
1411 */
1412 RSPUSH( rc, hn );
1413
1414 /* Move down left branch.
1415 */
1416 PEPOINTLEFT( hn, &np );
1417
1418 goto reduce_start;
1419
1420 case TAG_GEN:
1421 {
1422 double d1;
1423 double d2;
1424 double d3 = 0.0; /* keeps gcc happy */
1425 gboolean limit;
1426 HeapNode *hn1, *hn2;
1427
1428 /* Extract next, step, final.
1429 */
1430 d1 = GETLEFT( hn )->body.num;
1431 d2 = GETLEFT( GETRIGHT( hn ) )->body.num;
1432 limit = GETRT( GETRIGHT( hn ) ) != ELEMENT_ELIST;
1433 if( limit )
1434 d3 = GETRIGHT( GETRIGHT( hn ) )->body.num;
1435
1436 if( trace_flags & TRACE_OPERATOR ) {
1437 VipsBuf *buf = trace_push();
1438
1439 if( limit )
1440 vips_buf_appendf( buf,
1441 "generator %g %g %g ->\n",
1442 d1, d2, d3 );
1443 else
1444 vips_buf_appendf( buf,
1445 "generator %g %g ->\n",
1446 d1, d2 );
1447 }
1448
1449 /* At end?
1450 */
1451 if( GETRT( GETRIGHT( hn ) ) != ELEMENT_ELIST &&
1452 ((d2 > 0 && d1 > d3) ||
1453 (d2 < 0 && d1 < d3)) ) {
1454 /* Make I node for end.
1455 */
1456 hn->type = TAG_APPL;
1457 PPUT( hn,
1458 ELEMENT_COMB, COMB_I,
1459 ELEMENT_ELIST, NULL );
1460
1461 /* Write back to node above.
1462 */
1463 PEPUTP( &np, ELEMENT_ELIST, NULL );
1464
1465 if( trace_flags & TRACE_OPERATOR ) {
1466 trace_result( TRACE_OPERATOR, &np );
1467 trace_pop();
1468 }
1469
1470 /* All done!
1471 */
1472 break;
1473 }
1474
1475 /* Not at end, or no final. Generate new gen node.
1476 */
1477 if( NEWNODE( heap, hn1 ) )
1478 reduce_throw( rc );
1479 *hn1 = *hn;
1480
1481 /* Change hn into CONS node.
1482 */
1483 hn->type = TAG_CONS;
1484 PPUTRIGHT( hn, ELEMENT_NODE, hn1 );
1485
1486 /* Generate new number.
1487 */
1488 if( NEWNODE( heap, hn2 ) )
1489 reduce_throw( rc );
1490 hn2->type = TAG_DOUBLE;
1491 hn2->body.num = d1 + d2;
1492 PPUTLEFT( hn1,
1493 ELEMENT_NODE, hn2 );
1494
1495 if( trace_flags & TRACE_OPERATOR ) {
1496 trace_result( TRACE_OPERATOR, &np );
1497 trace_pop();
1498 }
1499
1500 /* And loop!
1501 */
1502 goto reduce_start;
1503 }
1504
1505 case TAG_FILE:
1506 {
1507 Managedfile *managedfile = MANAGEDFILE( GETLEFT( hn ) );
1508 int ch = managedfile_getc( managedfile );
1509
1510 /* -1 means error, 0 means EOF.
1511 */
1512 if( ch == -1 )
1513 reduce_throw( rc );
1514 else if( ch == 0 ) {
1515 /* Turn us into [].
1516 */
1517 hn->type = TAG_APPL;
1518 PPUT( hn,
1519 ELEMENT_COMB, COMB_I,
1520 ELEMENT_ELIST, NULL );
1521 }
1522 else {
1523 HeapNode *hn1;
1524
1525 /* Not at end ... make another CONS.
1526 */
1527 if( NEWNODE( heap, hn1 ) )
1528 reduce_throw( rc );
1529 *hn1 = *hn;
1530 hn->type = TAG_CONS;
1531 PPUT( hn,
1532 ELEMENT_CHAR, GUINT_TO_POINTER( ch ),
1533 ELEMENT_NODE, hn1 );
1534 }
1535
1536 /* Loop again with new np.
1537 */
1538 goto reduce_start;
1539 }
1540
1541 case TAG_FREE:
1542 g_assert( FALSE );
1543
1544 default:
1545 g_assert( FALSE );
1546 }
1547
1548 break;
1549 }
1550
1551 case ELEMENT_COMB:
1552 {
1553 CombinatorType comb = PEGETCOMB( &np );
1554 HeapNode *hn1, *hn2;
1555 HeapNode **arg;
1556 int na;
1557
1558 na = nargs[(int) comb];
1559
1560 /* Get args.
1561 */
1562 if( !RSCHECKARGS( rc, na ) )
1563 /* Not enough ... function result.
1564 */
1565 break;
1566
1567 /* Extract args.
1568 */
1569 arg = &RSGET( rc, na - 1 );
1570
1571 switch( comb ) {
1572 case COMB_S:
1573 /* Rewrite graph for S a b c => (a c) (b c).
1574 */
1575
1576 /* Make (b c) appl node.
1577 */
1578 if( NEWNODE( heap, hn1 ) )
1579 reduce_throw( rc );
1580 *hn1 = *arg[0];
1581 PPUTLEFT( hn1,
1582 GETRT( arg[1] ), GETRIGHT( arg[1] ) );
1583 PPUTRIGHT( arg[0],
1584 ELEMENT_NODE, hn1 );
1585
1586 /* Make (a c) appl node.
1587 */
1588 if( NEWNODE( heap, hn2 ) )
1589 reduce_throw( rc );
1590 *hn2 = *hn1;
1591 PPUTLEFT( hn2,
1592 GETRT( arg[2] ), GETRIGHT( arg[2] ) );
1593 PPUTLEFT( arg[0],
1594 ELEMENT_NODE, hn2 );
1595
1596 /* End of S ... now pop three, push 1 and loop.
1597 */
1598 RSPOP( rc, 2 );
1599 PEPOINTLEFT( arg[0], &np );
1600 goto reduce_start;
1601
1602 case COMB_SL:
1603 /* Rewrite graph for Sl a b c => (a c) b.
1604 */
1605
1606 /* Make (a c) appl node.
1607 */
1608 if( NEWNODE( heap, hn1 ) )
1609 reduce_throw( rc );
1610 *hn1 = *arg[0];
1611 PPUTLEFT( hn1,
1612 GETRT( arg[2] ), GETRIGHT( arg[2] ) );
1613 PPUT( arg[0],
1614 ELEMENT_NODE, hn1,
1615 GETRT( arg[1] ), GETRIGHT( arg[1] ) );
1616
1617 /* End of SL ... now pop three, push 1 and loop.
1618 */
1619 RSPOP( rc, 2 );
1620 PEPOINTLEFT( arg[0], &np );
1621 goto reduce_start;
1622
1623 case COMB_SR:
1624 /* Rewrite graph for Sr a b c => a (b c).
1625 */
1626
1627 /* Make (b c) appl node.
1628 */
1629 if( NEWNODE( heap, hn1 ) )
1630 reduce_throw( rc );
1631 *hn1 = *arg[0];
1632 PPUTLEFT( hn1,
1633 GETRT( arg[1] ), GETRIGHT( arg[1] ) );
1634 PPUT( arg[0],
1635 GETRT( arg[2] ), GETRIGHT( arg[2] ),
1636 ELEMENT_NODE, hn1 );
1637
1638 /* End of SR ... now pop three, push 1 and loop.
1639 */
1640 RSPOP( rc, 2 );
1641 PEPOINTLEFT( arg[0], &np );
1642 goto reduce_start;
1643
1644 case COMB_I:
1645 /* No action necessary.
1646 */
1647 break;
1648
1649 case COMB_K:
1650 /* Make I node.
1651 */
1652 PPUT( arg[0],
1653 ELEMENT_COMB, COMB_I,
1654 GETRT( arg[1] ), GETRIGHT( arg[1] ) );
1655
1656 break;
1657
1658 case COMB_GEN:
1659 {
1660 double d1;
1661 double d2 = 0.0; /* Don't need to init, but */
1662 double d3 = 0.0; /* keeps gcc happy */
1663 PElement rhs1, rhs2, rhs3;
1664
1665 PEPOINTRIGHT( arg[2], &rhs1 );
1666 PEPOINTRIGHT( arg[1], &rhs2 );
1667 PEPOINTRIGHT( arg[0], &rhs3 );
1668 reduce_spine_strict( rc, &rhs1 );
1669 reduce_spine_strict( rc, &rhs2 );
1670 reduce_spine_strict( rc, &rhs3 );
1671
1672 /* May have done ourselves in the process.
1673 */
1674 if( arg[0]->type != TAG_APPL )
1675 break;
1676
1677 /* Typecheck.
1678 */
1679 if( !PEISREAL( &rhs1 ) )
1680 reduce_error_typecheck( rc, &rhs1,
1681 _( "List generator" ), "real" );
1682 d1 = PEGETREAL( &rhs1 );
1683
1684 if( !PEISELIST( &rhs2 ) && !PEISREAL( &rhs2 ) )
1685 reduce_error_typecheck( rc, &rhs2,
1686 _( "List generator" ), "real" );
1687 if( PEISREAL( &rhs2 ) )
1688 d2 = PEGETREAL( &rhs2 );
1689
1690 if( !PEISELIST( &rhs3 ) && !PEISREAL( &rhs3 ) )
1691 reduce_error_typecheck( rc, &rhs3,
1692 _( "List generator" ), "real" );
1693 if( PEISREAL( &rhs3 ) )
1694 d3 = PEGETREAL( &rhs3 );
1695
1696 if( trace_flags & TRACE_OPERATOR ) {
1697 VipsBuf *buf = trace_push();
1698
1699 vips_buf_appends( buf, "generator constructor " );
1700 trace_args( arg, 3 );
1701 }
1702
1703 /* If next is missing, set default.
1704 */
1705 if( PEISREAL( &rhs2 ) )
1706 /* Next is there, calculate step.
1707 */
1708 d2 = d2 - d1;
1709 else {
1710 /* If final is missing, default is 1.
1711 */
1712 if( PEISELIST( &rhs3 ) )
1713 d2 = 1;
1714 else {
1715 /* Final is there, choose 1 or -1.
1716 */
1717 if( d1 < d3 )
1718 d2 = 1;
1719 else
1720 d2 = -1;
1721 }
1722 }
1723
1724 /* Make node for pairing next and final fields.
1725 */
1726 if( NEWNODE( heap, hn1 ) )
1727 reduce_throw( rc );
1728 hn1->type = TAG_COMPLEX;
1729 PPUT( hn1,
1730 GETRT( arg[1] ), GETRIGHT( arg[1] ),
1731 GETRT( arg[0] ), GETRIGHT( arg[0] ) );
1732
1733 /* Link to old root, make gen node.
1734 */
1735 arg[0]->type = TAG_GEN;
1736 PPUT( arg[0],
1737 GETRT( arg[2] ), GETRIGHT( arg[2] ),
1738 ELEMENT_NODE, hn1 );
1739
1740 /* Make step node.
1741 */
1742 if( NEWNODE( heap, hn2 ) )
1743 reduce_throw( rc );
1744 hn2->type = TAG_DOUBLE;
1745 hn2->body.num = d2;
1746 PPUTLEFT( hn1,
1747 ELEMENT_NODE, hn2 );
1748
1749 if( trace_flags & TRACE_OPERATOR ) {
1750 VipsBuf *buf = trace_current();
1751
1752 vips_buf_appends( buf, " " );
1753 trace_node( arg[0] );
1754 vips_buf_appends( buf, "\n" );
1755
1756 trace_text( TRACE_OPERATOR,
1757 "%s", vips_buf_all( buf ) );
1758
1759 trace_pop();
1760 }
1761
1762 /* Find output element.
1763 */
1764 RSPOP( rc, 3 );
1765 if( RSFRAMEEMPTY( rc ) )
1766 np = RSGETWB( rc );
1767 else
1768 PEPOINTLEFT( RSGET( rc, 0 ), &np );
1769
1770 /* Restart from there.
1771 */
1772 goto reduce_start;
1773 }
1774
1775 default:
1776 g_assert( FALSE );
1777 }
1778
1779 /* Find output element.
1780 */
1781 RSPOP( rc, na );
1782 if( RSFRAMEEMPTY( rc ) )
1783 np = RSGETWB( rc );
1784 else
1785 PEPOINTLEFT( RSGET( rc, 0 ), &np );
1786
1787 /* Write to above node.
1788 */
1789 PEPUTP( &np,
1790 GETRT( arg[0] ), GETRIGHT( arg[0] ) );
1791
1792 /* Loop again with new np.
1793 */
1794 goto reduce_start;
1795 /*NOTREACHED*/
1796 }
1797
1798 case ELEMENT_BINOP:
1799 {
1800 BinOp bop = PEGETBINOP( &np );
1801 HeapNode **arg;
1802 Compile *compile;
1803 PElement rhs1, rhs2;
1804
1805 /* Three args to binops ... first is the Compile that built us
1806 * (for error messages), other two are actual args.
1807 */
1808 if( !RSCHECKARGS( rc, 3 ) )
1809 /* Not enough ... function result.
1810 */
1811 break;
1812
1813 /* Extract args.
1814 */
1815 arg = &RSGET( rc, 2 );
1816 compile = COMPILE( GETRIGHT( arg[2] ) );
1817
1818 /* CONS is very, very lazy ... more like a combinator.
1819 */
1820 if( bop == BI_CONS ) {
1821 PEPOINTRIGHT( arg[1], &rhs1 );
1822
1823 if( trace_flags & TRACE_OPERATOR ) {
1824 trace_push();
1825
1826 PEPOINTRIGHT( arg[0], &rhs2 );
1827 trace_binop( compile, &rhs1, bop, &rhs2 );
1828 }
1829
1830 arg[0]->type = TAG_CONS;
1831 PPUTLEFT( arg[0],
1832 PEGETTYPE( &rhs1 ), PEGETVAL( &rhs1 ) );
1833
1834 if( trace_flags & TRACE_OPERATOR ) {
1835 VipsBuf *buf = trace_current();
1836
1837 vips_buf_appends( buf, " " );
1838 trace_node( arg[0] );
1839 vips_buf_appends( buf, "\n" );
1840
1841 trace_text( TRACE_OPERATOR,
1842 "%s", vips_buf_all( buf ) );
1843
1844 trace_pop();
1845 }
1846
1847 RSPOP( rc, 3 );
1848
1849 break;
1850 }
1851
1852 action_proc_bop( rc, compile, bop, arg );
1853
1854 /* Find output element.
1855 */
1856 RSPOP( rc, 3 );
1857
1858 if( RSFRAMEEMPTY( rc ) )
1859 np = RSGETWB( rc );
1860 else
1861 PEPOINTLEFT( RSGET( rc, 0 ), &np );
1862
1863 /* Write to node above.
1864 */
1865 PEPUTP( &np,
1866 GETRT( arg[0] ), GETRIGHT( arg[0] ) );
1867
1868 /* Loop again with new np.
1869 */
1870 goto reduce_start;
1871 }
1872
1873 case ELEMENT_UNOP:
1874 {
1875 HeapNode **arg;
1876 Compile *compile;
1877
1878 /* Some unary operator. First arg is the compile that built
1879 * us, 2nd is the actual arg that might need reducing.
1880 */
1881 if( !RSCHECKARGS( rc, 2 ) )
1882 /* Not enough ... function result.
1883 */
1884 break;
1885
1886 /* Extract arg.
1887 */
1888 arg = &RSGET( rc, 1 );
1889 compile = COMPILE( GETRIGHT( arg[1] ) );
1890
1891 action_dispatch( rc, compile, reduce_spine,
1892 PEGETUNOP( &np ), OPERATOR_NAME( PEGETUNOP( &np ) ),
1893 TRUE, (ActionFn) action_proc_uop, 1, arg, NULL );
1894
1895 /* Find output element.
1896 */
1897 RSPOP( rc, 2 );
1898 if( RSFRAMEEMPTY( rc ) )
1899 np = RSGETWB( rc );
1900 else
1901 PEPOINTLEFT( RSGET( rc, 0 ), &np );
1902
1903 /* Write to above node.
1904 */
1905 PEPUTP( &np,
1906 GETRT( arg[0] ), GETRIGHT( arg[0] ) );
1907
1908 /* Loop again with new np.
1909 */
1910 goto reduce_start;
1911 }
1912
1913 case ELEMENT_NOVAL:
1914 break;
1915
1916 default:
1917 g_assert( FALSE );
1918 }
1919
1920 /* Unwind stack, restore frame pointer.
1921 */
1922 RSPOPFRAME( rc );
1923
1924 #ifdef WHNF_DEBUG
1925 /* Should now be in WHNF ... test!
1926 */
1927 if( !is_WHNF( out ) ) {
1928 char txt[1000];
1929 VipsBuf buf = VIPS_BUF_STATIC( txt );
1930
1931 graph_pelement( heap, &buf, out, TRUE );
1932 printf( "*** internal error:\n" );
1933 printf( "result of reduce_spine not in WHNF: " );
1934 printf( "%s\n", vips_buf_all( &buf ) );
1935 reduce_throw( rc );
1936 }
1937 #endif /*WHNF_DEBUG*/
1938 }
1939
1940 /* Strict reduction ... fully eval all lists etc.
1941 */
1942 void
reduce_spine_strict(Reduce * rc,PElement * np)1943 reduce_spine_strict( Reduce *rc, PElement *np )
1944 {
1945 PElement rhs, lhs;
1946
1947 /* Make sure this element is reduced.
1948 */
1949 reduce_spine( rc, np );
1950
1951 /* If it's a non-empty list, may need to reduce inside. Not managed
1952 * strings though, we can leave them unevaluated.
1953 */
1954 if( PEISFLIST( np ) && !PEISMANAGEDSTRING( np ) ) {
1955 /* Recurse for head and tail.
1956 */
1957 HeapNode *hn = PEGETVAL( np );
1958
1959 PEPOINTLEFT( hn, &lhs );
1960 PEPOINTRIGHT( hn, &rhs );
1961 reduce_spine_strict( rc, &lhs );
1962 reduce_spine_strict( rc, &rhs );
1963 }
1964 }
1965
1966 /* Free a Reduce.
1967 */
1968 void
reduce_destroy(Reduce * rc)1969 reduce_destroy( Reduce *rc )
1970 {
1971 heap_unregister_reduce( rc->heap, rc );
1972 UNREF( rc->heap );
1973 IM_FREE( rc );
1974 }
1975
1976 /* Max cells function for main reduce engine. Read from Preferences, and scale
1977 * by the number of workspaces we have open.
1978 */
1979 static int
reduce_heap_max_fn(Heap * heap)1980 reduce_heap_max_fn( Heap *heap )
1981 {
1982 return( workspace_number() * MAX_HEAPSIZE );
1983 }
1984
1985 /* Build a Reduce.
1986 */
1987 Reduce *
reduce_new(void)1988 reduce_new( void )
1989 {
1990 /* Initial heap size. Big enough that we won't need to grow just
1991 * loading prefs and standard stuff.
1992 */
1993 const int stsz = 100000;
1994
1995 /* Heap increment..
1996 */
1997 const int incr = 2000;
1998
1999 Reduce *rc = INEW( NULL, Reduce );
2000
2001 if( !rc )
2002 return( NULL );
2003 rc->sp = 0;
2004 rc->fsp = 0;
2005 rc->heap = NULL;
2006 rc->running = 0;
2007
2008 rc->heap = heap_new( NULL, reduce_heap_max_fn, stsz, incr );
2009 g_object_ref( G_OBJECT( rc->heap ) );
2010 iobject_sink( IOBJECT( rc->heap ) );
2011 heap_register_reduce( rc->heap, rc );
2012 iobject_set( IOBJECT( rc->heap ), "reduce-heap", NULL );
2013
2014 return( rc );
2015 }
2016
2017 /* Reduce a PElement to a base type. Return TRUE/FALSE, no longjmp.
2018 */
2019 gboolean
reduce_pelement(Reduce * rc,ReduceFunction fn,PElement * out)2020 reduce_pelement( Reduce *rc, ReduceFunction fn, PElement *out )
2021 {
2022 gboolean res = TRUE;
2023
2024 REDUCE_CATCH_START( FALSE );
2025 fn( reduce_context, out );
2026 REDUCE_CATCH_STOP;
2027
2028 return( res );
2029 }
2030
2031 /* Make sure a symbol's value is registered with the main GC.
2032 */
2033 void
reduce_register(Symbol * sym)2034 reduce_register( Symbol *sym )
2035 {
2036 Reduce *rc = reduce_context;
2037 Heap *heap = rc->heap;
2038
2039 heap_register_element( heap, &sym->base );
2040 }
2041
2042 /* Make sure a symbol's value is not registered with the main GC.
2043 */
2044 void
reduce_unregister(Symbol * sym)2045 reduce_unregister( Symbol *sym )
2046 {
2047 Reduce *rc = reduce_context;
2048 Heap *heap = rc->heap;
2049
2050 heap_unregister_element( heap, &sym->base );
2051 }
2052
2053 /* Copy and evaluate compiled code into element pointed to by out.
2054 */
2055 gboolean
reduce_regenerate(Expr * expr,PElement * out)2056 reduce_regenerate( Expr *expr, PElement *out )
2057 {
2058 Reduce *rc = reduce_context;
2059 Heap *heap = rc->heap;
2060
2061 /* Clear any run state from old expr value.
2062 */
2063 expr_error_clear( expr );
2064 if( slist_map( expr->dynamic_links,
2065 (SListMapFn) link_expr_destroy, NULL ) )
2066 return( FALSE );
2067
2068 /* Copy new code in.
2069 */
2070 if( !heap_copy( heap, expr->compile, out ) ) {
2071 expr_error_set( expr );
2072 return( FALSE );
2073 }
2074
2075 #ifdef DEBUG_REGEN
2076 {
2077 char txt[1024];
2078 VipsBuf buf = VIPS_BUF_STATIC( txt );
2079
2080 graph_pelement( heap, &buf, out, TRUE );
2081 printf( "reduce_regenerate: reducing " );
2082 expr_name_print( expr );
2083 printf( "graph: %s\n", vips_buf_all( &buf ) );
2084 }
2085 #endif /*DEBUG_REGEN*/
2086
2087 reduce_current_expr = expr;
2088 if( !reduce_pelement( rc, reduce_spine, out ) ) {
2089 reduce_current_expr = NULL;
2090 expr_error_set( expr );
2091 (void) heap_gc( heap );
2092 return( FALSE );
2093 }
2094 reduce_current_expr = NULL;
2095
2096 #ifdef DEBUG_REGEN
2097 {
2098 char txt[1024];
2099 VipsBuf buf = VIPS_BUF_STATIC( txt );
2100
2101 /* Force immediate GC to pick up any stray pointers.
2102 */
2103 if( !heap_gc( heap ) ) {
2104 expr_error_set( expr );
2105 return( FALSE );
2106 }
2107
2108 graph_pelement( heap, &buf, out, TRUE );
2109 printf( "reduce_regenerate: reduced " );
2110 expr_name_print( expr );
2111 printf( " to: %s\n", vips_buf_all( &buf ) );
2112 }
2113 #endif /*DEBUG_REGEN*/
2114
2115 return( TRUE );
2116 }
2117
2118 /* Regenerate an (expr this) pair.
2119 */
2120 gboolean
reduce_regenerate_member(Expr * expr,PElement * ths,PElement * out)2121 reduce_regenerate_member( Expr *expr, PElement *ths, PElement *out )
2122 {
2123 Reduce *rc = reduce_context;
2124 Heap *heap = rc->heap;
2125
2126 PElement e;
2127 HeapNode *apl;
2128
2129 /* New (NULL this) pair.
2130 */
2131 if( NEWNODE( heap, apl ) ) {
2132 expr_error_set( expr );
2133 return( FALSE );
2134 }
2135 apl->type = TAG_APPL;
2136 PPUT( apl, ELEMENT_NOVAL, (void *) 10,
2137 PEGETTYPE( ths ), PEGETVAL( ths ) );
2138 PEPUTP( out, ELEMENT_NODE, apl );
2139
2140 /* Link code to node.
2141 */
2142 PEPOINTLEFT( apl, &e );
2143 if( !reduce_regenerate( expr, &e ) )
2144 return( FALSE );
2145
2146 #ifdef DEBUG_REGEN_MEMBER
2147 {
2148 char txt[1024];
2149 VipsBuf buf = VIPS_BUF_STATIC( txt );
2150
2151 graph_pelement( heap, &buf, out, TRUE );
2152 printf( "reduce_regenerate_member: " );
2153 expr_name_print( expr );
2154 printf( " new code: %s\n", vips_buf_all( &buf ) );
2155 }
2156 #endif /*DEBUG_REGEN_MEMBER*/
2157
2158 /* Do initial reduction.
2159 */
2160 if( !reduce_pelement( rc, reduce_spine, out ) ) {
2161 /* Failure! Junk the half-made value.
2162 */
2163 expr_error_set( expr );
2164 (void) heap_gc( heap );
2165 return( FALSE );
2166 }
2167
2168 /* Special case: if this is a "super" row, we need to rebuild the
2169 * class.
2170 */
2171 if( is_super( expr->compile->sym ) ) {
2172 Compile *parent = compile_get_parent( expr->compile );
2173 PElement instance;
2174
2175 PEPOINTE( &instance, &expr->row->scol->base );
2176
2177 if( !class_new_super( heap, parent, ths, &instance ) )
2178 return( FALSE );
2179 }
2180
2181 return( TRUE );
2182 }
2183