source: project/release/4/picnic/trunk/picnic-core.scm @ 30658

Last change on this file since 30658 was 30658, checked in by Ivan Raikov, 7 years ago

picnic: reworking config imports

File size: 98.6 KB
Line 
1;;
2;; Neural Parametric Curve Connectivity core language module.
3;;
4;; Copyright 2012-2014 Ivan Raikov and the Okinawa Institute of Science and Technology
5;;
6;; This program is free software: you can redistribute it and/or
7;; modify it under the terms of the GNU General Public License as
8;; published by the Free Software Foundation, either version 3 of the
9;; License, or (at your option) any later version.
10;;
11;; This program is distributed in the hope that it will be useful, but
12;; WITHOUT ANY WARRANTY; without even the implied warranty of
13;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
14;; General Public License for more details.
15;;
16;; A full copy of the GPL license can be found at
17;; <http://www.gnu.org/licenses/>.
18;;
19
20(module picnic-core
21
22        (make-picnic-core picnic-verbose
23         picnic:error picnic:warning picnic:version-string
24         picnic:env-copy picnic:quantity?
25         picnic:rhs? picnic:expr? picnic:subst-term picnic:binding? picnic:bind
26         picnic:math-constants
27         picnic-intern picnic-scoped eval-picnic-system-decls 
28         CONST CONFIG ASGN INITIAL PS SEGPS SET EXTERNAL PRIM LABEL
29
30         )
31
32
33        (import scheme chicken)
34
35       
36        (require-extension srfi-69
37                           datatype matchable vector-lib mpi
38                           varsubst digraph graph-bfs graph-cycles
39                           mathh picnic-utils)
40
41
42        (require-library srfi-1 srfi-4 irregex files posix data-structures)
43
44
45        (import 
46                (only srfi-1 
47                      cons* fold filter-map filter every zip list-tabulate delete-duplicates partition 
48                      first second third take
49                      lset-union)
50                (only srfi-4 
51                      s32vector s32vector-length s32vector-ref
52                      f64vector f64vector? f64vector-ref f64vector-length f64vector->list list->f64vector)
53                (only srfi-13 string= string< string-null? string-concatenate)
54                (only irregex string->irregex irregex-match)
55                (only files make-pathname)
56                (only posix glob)
57                (only extras read-lines pp fprintf )
58                (only ports with-output-to-port )
59                (only data-structures ->string alist-ref compose identity string-split sort atom? intersperse)
60                (only lolevel extend-procedure procedure-data extended-procedure?)
61                )
62
63
64        (include "mathh-constants")
65
66
67
68        (define (picnic:warning x . rest)
69          (let loop ((port (open-output-string)) (objs (cons x rest)))
70            (if (null? objs)
71                (begin
72                  (newline port)
73                  (print-error-message (get-output-string port) 
74                                       (current-error-port) "picnic warning"))
75                (begin (display (car objs) port)
76                       (display " " port)
77                       (loop port (cdr objs))))))
78
79
80        (define (picnic:error x . rest)
81          (let ((port (open-output-string)))
82            (if (port? x)
83                (begin
84                  (display "[" port)
85                  (display (port-name x) port)
86                  (display "] " port)))
87            (let loop ((objs (if (port? x) rest (cons x rest))))
88              (if (null? objs)
89                  (begin
90                    (newline port)
91                    (error 'picnic (get-output-string port)))
92                  (let ((obj (car objs)))
93                    (if (procedure? obj) 
94                        (with-output-to-port port obj)
95                        (begin
96                          (display obj port)
97                          (display " " port)))
98                    (loop (cdr objs)))))))
99
100
101        (include "picnic-version.scm")
102
103
104        (define (picnic:version-string) 
105          (sprintf "PICNIC (http://wiki.call-cc.org/picnic) version ~A~%" picnic-version))
106
107
108
109
110        (define (make-opt pred?) (lambda (x) 
111                                   (or (not x) (pred? x))))
112
113        (define (sign x) (if (negative? x) -1.0 1.0))
114
115        (define (f64vector-empty? x) (zero? (f64vector-length x)))
116
117
118        (define (eval-math x . rest)
119          (define prelude
120            `(
121              (import mathh random-mtzig)
122              (define (random-init seed) (random-mtzig:init seed))
123              (define (random-normal mean sdev st)
124                (+ mean (* sdev (random-mtzig:randn! st))))
125              (define (random-uniform low high st)
126                (let ((rlo (if (< low high) low high))
127                      (rhi (if (< low high) high low))) 
128                  (let ((delta (+ 1 (- rhi rlo)))
129                        (v (random-mtzig:randu! st)))
130                    (+ rlo (floor (* delta v))) ))
131                )
132              ))
133          (if (null? rest)
134              (let ((ex `(begin ,@prelude ,x)))
135                (eval ex))
136              (let ((ex `(begin ,@prelude (list ,x . ,rest))))
137                (eval ex))
138              )
139          )
140       
141
142        (define (expr? x) 
143          (or (symbol? x) (number? x) (string? x) 
144              (match x 
145                     (((? symbol?) ())  #t)
146                     (((? symbol?) () . rest)  (expr? rest))
147                     (((? symbol?) . rest)  (every expr? rest)) 
148                     (((and hd (? expr?)) . rest)  (every expr? rest))
149                     (else #f))))
150
151
152        (define (rhs? x) 
153          (or (symbol? x) (number? x) (string? x)
154              (match x 
155                     (('let bnds body) (and (rhs? body)
156                                            (every (lambda (b) 
157                                                     (and (symbol? (car b)) (rhs? (cadr b)))) bnds)))
158                     (((? symbol?) . rest)  (every rhs? rest)) 
159                     (else #f))))
160
161
162        (define (setexpr? x) 
163          (match x 
164                 (('population pop)  (symbol? pop))
165                 (('section pop sec) (and (symbol? pop) (symbol? sec)))
166                 (('union x y)       (and (setexpr? x) (setexpr? y)))
167                 (else #f)))
168
169
170        (define picnic:expr?   expr?)
171        (define picnic:rhs?    rhs?)
172
173
174        (define-datatype picnic:quantity picnic:quantity?
175          (SYSNAME    (name symbol?) )
176          (LABEL      (v symbol?) )
177          (CONFIG     (name symbol?) )
178          (CONST      (name symbol?) (value number?) )
179          (ASGN       (name symbol?) (value number?) (rhs rhs?) )
180          (INITIAL    (name symbol?) (rhs rhs?) )
181          (SEGPS      (name    symbol?) 
182                      (gfun    symbol?)
183                      (initial  (lambda (x) (or (not x) (rhs? x))))
184                      (nsegs   integer?)
185                      (nsegpts integer?)
186                      )
187          (PS         (name symbol?) 
188                      (gfun symbol?)
189                      (initial  (lambda (x) (or (not x) (rhs? x))))
190                      (npts integer?)
191                      )
192          (SET        (name symbol?)
193                      (rhs  setexpr?)
194                      )
195          (PRIM       (name symbol?) (value identity))
196          (EXTERNAL   (local-name symbol?) (name symbol?) (namespace (make-opt symbol?)))
197          (EXPORTS    (lst (lambda (x) (and (list? x) (every symbol? x)))))
198          (COMPONENT  (name symbol?) (type symbol?) (lst (lambda (x) (and (list? x) (every symbol? x)))) (scope-subst list?))
199          (FUNCTOR    (name symbol?) (args (lambda (x) (and (list? x) (every symbol? x)))) (type symbol?)  (decls list?))
200          (DISPATCH   (value procedure?))
201          )
202
203
204        (define (picnic-intern sym)
205          (string->symbol (string-append "#" (symbol->string sym))))
206
207
208        (define (picnic-scoped scope sym)
209          (let ((ss (map ->string scope)))
210            (if (null? ss) 
211                (->string sym)
212                (string->symbol (string-concatenate (intersperse (append ss (list (->string sym))) "."))))
213            ))
214
215
216        (define fresh (compose string->symbol symbol->string gensym))
217
218
219        (define (alist? x)
220          (every (lambda (x) (and (pair? x) (symbol? (car x)))) x))
221
222
223        (define (lookup-def k lst . rest)
224          (let-optionals rest ((default #f))
225                         (let ((k (->string k))) 
226                           (let recur ((kv #f) (lst lst))
227                             (if (or kv (null? lst))
228                                 (if (not kv) default
229                                     (match kv ((k v) v) (else (cdr kv))))
230                                 (let ((kv (car lst)))
231                                   (recur (and (string=? (->string (car kv)) k) kv)
232                                          (cdr lst)) ))))))
233
234
235        (define (picnic:subst-term t subst k)
236          (assert (every symbol? (map car subst)))
237          (if (null? subst) t
238              (match t
239                     (('if c t e)
240                      `(if ,(k c subst) ,(k t subst) ,(k e subst)))
241                     
242                     (('let bs e)
243                      (let ((r `(let ,(map (lambda (b) `(,(car b) ,(k (cadr b) subst))) bs) ,(k e subst))))
244                        (k r subst)))
245                     
246                     ((f . es)
247                      (cons (k f subst) (map (lambda (e) (k e subst)) es)))
248                     
249                     ((? symbol? )  (lookup-def t subst t))
250                     
251                     ((? atom? ) t))
252              ))
253       
254
255        (define (picnic:binding? t) 
256          (and (list? t) (eq? 'let (car t)) (cdr t)))
257
258        (define (picnic:bind ks vs e) `(let ,(zip ks vs) ,e))
259
260        (define picnic:env-copy hash-table-copy)
261
262        (define picnic:math-constants
263          (zip 
264           `(E 1/E E^2 E^PI/4 LOG2E LOG10E LN2 LN3 LNPI LN10 1/LN2 1/LN10 PI PI/2
265               PI/4 1/PI 2/PI 2/SQRTPI SQRTPI PI^2 DEGREE SQRT2 1/SQRT2 SQRT3 SQRT5
266               SQRT10 CUBERT2 CUBERT3 4THRT2 GAMMA1/2 GAMMA1/3 GAMMA2/3 PHI LNPHI
267               1/LNPHI EULER E^EULER SIN1 COS1 ZETA3)
268           (list E 1/E E^2 E^PI/4 LOG2E LOG10E LN2 LN3 LNPI LN10 1/LN2 1/LN10 PI PI/2
269                 PI/4 1/PI 2/PI 2/SQRTPI SQRTPI PI^2 DEGREE SQRT2 1/SQRT2 SQRT3 SQRT5
270                 SQRT10 CUBERT2 CUBERT3 4THRT2 GAMMA1/2 GAMMA1/3 GAMMA2/3 PHI LNPHI
271                 1/LNPHI EULER E^EULER SIN1 COS1 ZETA3)))
272       
273
274
275        (define (make-picnic-core . alst)
276
277          (define local-config (lookup-def 'config alst))
278
279          ;; floating point precision (single or double; default is double)
280          (define  inttype        'int)
281          (define  fptype (lookup-def 'fpprec alst 'double))
282          (define  boundstype     'bounds)
283          (define  rngstatetype   'rngstate)
284          (define  stringtype     'string)
285          (define  pathtype       'path)
286          (define  pointtype      'point)
287          (define  pointsettype   'pointset)
288          (define  projectiontype 'projection)
289          (define  settype        'set)
290
291          (define builtin-arith-ops
292            `(+ - * / pow neg abs atan asin acos sin cos exp ln
293                sqrt tan cosh sinh tanh hypot gamma lgamma log10 log2 log1p ldexp cube
294                > < <= >= = and or round ceiling floor max min
295                randomInit randomNormal randomUniform ))
296
297          (define builtin-projection-ops
298                `(Projection SegmentProjection)
299                )
300
301          (define builtin-path-ops
302                `(LineSegment)
303                )
304
305          (define builtin-bounds-ops
306                `(Bounds)
307                )
308
309          (define builtin-pointset-ops
310                `(PointsFromFile UniformRandomPointProcess)
311                )
312
313          (define builtin-ops (append builtin-projection-ops 
314                                      builtin-bounds-ops 
315                                      builtin-path-ops 
316                                      builtin-pointset-ops
317                                      builtin-arith-ops 
318                                      ))
319
320          (define (add-primitives! env)
321            (let (
322                  (pointset-procs
323                   (list load-points-from-file UniformRandomPointProcess)
324                   )
325
326                  (pointset-exprs
327                   '(load-points-from-file UniformRandomPointProcess)
328                   )
329
330                  (path-procs
331                   (list make-line-segment)
332                   )
333
334                  (path-exprs
335                   '(make-line-segment)
336                   )
337
338                  (bounds-procs
339                   (list Bounds)
340                   )
341
342                  (bounds-exprs
343                   '(Bounds)
344                   )
345
346                  (projection-procs
347                   (list projection segment-projection)
348                   )
349
350                  (projection-exprs
351                   '(projection segment-projection)
352                   )
353
354                  (prim-exprs
355                   '(fp+ fp- fp* fp/ expt fpneg
356                     abs atan asin acos sin cos exp log sqrt tan 
357                     cosh sinh tanh hypot gamma lgamma log10 log2 log1p ldexp
358                     (lambda (x) (* x x x))
359                     fp> fp< fp<= fp>= fp=
360                     (lambda (x y) (and x y)) (lambda (x y) (or x y)) 
361                     round ceiling floor fpmax fpmin
362                     random-init random-normal random-uniform
363                     ))
364                  )
365
366              (for-each (lambda (n v qb fms rt) 
367                          (let ((fb (extend-procedure 
368                                     v `((name ,n) (eval-body ,qb)
369                                         (rt ,rt) (formals ,fms)))))
370                            (hash-table-set! env n fb)))
371                        builtin-projection-ops
372                        projection-procs
373                        projection-exprs
374                        `((,fptype ,settype  ,settype) (,fptype ,settype  ,settype))
375                        `(,projectiontype ,projectiontype)
376                        )
377
378              (for-each (lambda (n v qb fms rt) 
379                          (let ((fb (extend-procedure 
380                                     v `((name ,n) (eval-body ,qb)
381                                         (rt ,rt) (formals ,fms)))))
382                            (hash-table-set! env n fb)))
383                        builtin-path-ops
384                        path-procs
385                        path-exprs
386                        `((,pointtype ,fptype  ,fptype  ,fptype))
387                        `(,pathtype)
388                        )
389
390              (for-each (lambda (n v qb fms rt) 
391                          (let ((fb (extend-procedure 
392                                     v `((name ,n) (eval-body ,qb)
393                                         (rt ,rt) (formals ,fms)))))
394                            (hash-table-set! env n fb)))
395                        builtin-bounds-ops
396                        bounds-procs
397                        bounds-exprs
398                        `((,fptype ,fptype ,fptype ,fptype))
399                        `(,boundstype)
400                        )
401
402              (for-each (lambda (n v qb fms rt) 
403                          (let ((fb (extend-procedure 
404                                     v `((name ,n) (eval-body ,qb)
405                                         (rt ,rt) (formals ,fms)))))
406                            (hash-table-set! env n fb)))
407                        builtin-pointset-ops
408                        pointset-procs
409                        pointset-exprs
410                        `((,stringtype) (,inttype ,rngstatetype ,rngstatetype ,boundstype))
411                        `(,pointsettype ,pointsettype)
412                        )
413
414
415              (for-each (lambda (n v qb fms rt) 
416
417                          (let ((fb (extend-procedure 
418                                     v `((name ,n) (eval-body ,qb)
419                                         (rt ,rt) (formals ,fms)))))
420                            (hash-table-set! env n fb)))
421                        builtin-arith-ops
422                        (apply eval-math prim-exprs)
423                        prim-exprs
424                        `((,fptype ,fptype) (,fptype ,fptype) (,fptype ,fptype) (,fptype ,fptype) 
425                          (,fptype ,fptype) (,fptype)
426                          (,fptype) (,fptype) (,fptype) (,fptype) (,fptype) (,fptype) (,fptype)
427                          (,fptype) (,fptype) (,fptype)
428                          (,fptype) (,fptype) (,fptype) (,fptype) (,fptype) (,fptype) (,fptype)
429                          (,fptype) (,fptype) (,fptype)
430                          (,fptype) 
431                          (bool bool) (bool bool) (bool bool) (bool bool) (bool bool) (bool bool) (bool bool) 
432                          (,fptype) (,fptype) (,fptype) (,fptype ,fptype) (,fptype ,fptype) 
433                          (int) (,fptype ,fptype ,rngstatetype) (,fptype ,fptype ,rngstatetype) 
434                          )
435                        `(,fptype ,fptype ,fptype ,fptype 
436                                  ,fptype ,fptype
437                                  ,fptype ,fptype ,fptype ,fptype ,fptype ,fptype ,fptype
438                                  ,fptype ,fptype ,fptype
439                                  ,fptype ,fptype ,fptype ,fptype ,fptype ,fptype ,fptype
440                                  ,fptype ,fptype ,fptype
441                                  ,fptype 
442                                  bool bool bool bool bool bool bool 
443                                  ,fptype ,fptype ,fptype ,fptype ,fptype 
444                                  ,rngstatetype ,fptype ,fptype 
445                                   )
446                        ))
447            )
448
449
450          (define (add-constants! env)
451            (for-each (lambda (kv) (hash-table-set! env (car kv) (cadr kv)))
452                      picnic:math-constants))
453
454
455          (define (enumdeps expr)
456            (let loop ((expr expr) (ax (list)) (lbs (list)))
457              (match expr 
458                     (('let bs e)  (let let-loop ((bs bs) (ax ax) (lbs lbs))
459                                     (if (null? bs) (loop e ax lbs)
460                                         (let ((x   (first  (car bs)))
461                                               (ex  (second (car bs))))
462                                           (let* ((lbs1  (cons x lbs))
463                                                  (ax1   (loop ex ax lbs)))
464                                             (let-loop (cdr bs) ax1 lbs1))))))
465
466                     ((s . es)     (if (symbol? s) (fold (lambda (e ax) (loop e ax lbs)) ax es) 
467                                       (fold (lambda (e ax) (loop e ax lbs)) ax (cons s es))))
468                     (id           (if (and (symbol? id) (not (member id lbs))) (cons id ax) ax)))))
469
470
471          (define (binop-fold op lst)
472            (if (null? lst) lst
473                (match lst
474                       ((x)   x)
475                       ((x y) `(,op ,x ,y))
476                       ((x y . rest) `(,op (,op ,x ,y) ,(binop-fold op rest)))
477                       ((x . rest) `(,op ,x ,(binop-fold op rest))))))
478
479
480          ;; if argument is constant, return the negative of that constant,
481          ;; otherwise return `(neg ,expr)
482          (define (negate expr)
483            (if (number? expr) (- expr)
484                `(neg ,expr)))
485
486          ;; 1. make sure all constants in an expression are flonums
487          ;; 2. fold expressions like (+ a b c d) into nested binops
488          (define (make-normalize-expr arity-check symbol-check)
489            (lambda (expr loc)
490              (let recur ((expr expr) (lbs '()))
491                (match expr 
492                       (('let bs e)         (let ((normalize-bnd  (lambda (lbs) (lambda (x) `(,(first x) ,(recur (second x) lbs)))))
493                                                  (lbs1 (append (map first bs) lbs)))
494                                              `(let ,(map (normalize-bnd lbs1) bs) ,(recur e lbs1))))
495                       (('if c t e)         `(if ,(recur c lbs) ,(recur t lbs) ,(recur e lbs))) 
496                       (('+ . es)           (binop-fold '+ (map (lambda (x) (recur x lbs)) es)))
497                       (('- . es)           (let ((es1 (map (lambda (x) (recur x lbs)) es)))
498                                              (binop-fold '+ (cons (car es1) (map negate (cdr es1))))))
499                       (('* . es)           (binop-fold '* (map (lambda (x) (recur x lbs)) es)))
500                       (('/ . es)           (binop-fold '/ (map (lambda (x) (recur x lbs)) es)))
501                       (('fix n)            n)
502                       ((s . es)            (begin
503                                              (arity-check s es loc)
504                                              (cons s (map (lambda (x) (recur x lbs)) es))))
505                       (x                   (cond ((number? x) (exact->inexact x))
506                                                  ((symbol? x) (begin (symbol-check x loc lbs) x))
507                                                  (else x)))
508                       
509                       ))))
510
511          (define base-env
512            (let ((env (make-hash-table)))
513              (add-primitives! env)
514              (add-constants! env)
515              env))
516         
517          (define (make-const-env picnic-env)
518            (let ((env (picnic:env-copy base-env)))
519              (hash-table-for-each picnic-env
520                                   (lambda (sym en)
521                                     (cond  ((picnic:quantity? en) 
522                                             (cases picnic:quantity en
523                                                    (CONFIG (name) 
524                                                            (let ((value (lookup-def name local-config)))
525                                                              (if (not value)
526                                                                  (picnic:error 'make-const-env 
527                                                                                ": unknown configuration entry" name))
528                                                              (hash-table-set! env name value)))
529                                                    (CONST (name value) 
530                                                           (hash-table-set! env name value))
531                                                    (PRIM (name value) 
532                                                          (hash-table-set! env name value))))
533                                            ((procedure? en)
534                                             (hash-table-set! env sym en)))))
535              env))
536
537          (define (make-const-ftenv picnic-env)
538            (let ((env (make-hash-table)))
539              (hash-table-for-each
540               picnic-env
541               (lambda (sym en)
542                 (cond  ((picnic:quantity? en) 
543                         (cases picnic:quantity en
544                                (CONFIG (name) 
545                                       (hash-table-set! env name fptype))
546                                (CONST (name value) 
547                                       (hash-table-set! env name fptype))
548                                (PRIM (name value) 
549                                      (hash-table-set! env name fptype))))
550                        ((procedure? en)
551                         (let ((d (procedure-data en)))
552                           (hash-table-set! env sym (lookup-def 'rt d)))))))
553              env))
554
555
556          (define (const-env-entry->value en)
557            (cond  ((picnic:quantity? en) 
558                    (cases picnic:quantity en
559                           (CONFIG (name)  (let ((v (lookup-def name local-config)))
560                                             (or (and v v)
561                                                 (picnic:error 'const-env-entry->value
562                                                               "unknown configuration entry" name))))
563                           (CONST (name value)  value)
564                           (PRIM (name value)  value)
565                           ))
566                   ((procedure? en)  en)
567                   ((or (number? en) (symbol? en))   en)
568                   (else (picnic:error 'const-env-entry->value 
569                                       "unknown type of const env entry" en))
570                   ))
571
572
573          (define (system name)
574            (let ((env  (picnic:env-copy base-env))
575                  (name (if (symbol? name) name (string->symbol name))))
576              (hash-table-set! env (picnic-intern 'dispatch)  (DISPATCH picnic-dispatch))
577              (hash-table-set! env (picnic-intern 'name)      (SYSNAME name))
578              (hash-table-set! env (picnic-intern 'exports)   (EXPORTS (list)))
579              (hash-table-set! env (picnic-intern 'toplevel)  (COMPONENT 'toplevel 'toplevel (list) (list)))
580              env))
581
582
583          (define (add-external! picnic-env)
584            (lambda (sym typ)
585              (match typ
586                     ('output
587                      (begin
588                        (if (not (hash-table-exists? picnic-env sym))
589                            (picnic:error 'add-external! "exported quantity " sym " is not defined"))
590                        (let* ((exports-sym   (picnic-intern 'exports))
591                               (exports       (hash-table-ref picnic-env exports-sym)))
592                          (cases picnic:quantity exports
593                                 (EXPORTS (lst) (hash-table-set! picnic-env exports-sym (EXPORTS (append lst (list sym)))))
594                                 (else  (picnic:error 'add-external! "invalid exports entry " exports))))))
595                     
596                     (('input sym lsym ns . rest)
597                      (let (
598                            (lsym (or lsym sym))
599                            )
600                        (if (hash-table-exists? picnic-env lsym)
601                            (picnic:error 'add-import! "import symbol " lsym " is already defined"))
602                       
603                        ((env-extend! picnic-env) lsym '(external) 'none 
604                         `(name ,sym) `(namespace ,ns))))
605                     
606                     )))
607
608
609          (define (make-symbol-check picnic-env)
610            (lambda (s loc . rest)
611              (let-optionals rest ((lbs '()))
612
613                             (if (and (not (hash-table-exists? picnic-env s)) 
614                                      (not (member s lbs)))
615                                 (begin
616                                   (pp (hash-table->alist picnic-env))
617                                   (picnic:error 'symbol-check s " in the definition of " loc " is not defined")
618                                   )
619                                 ))
620              ))
621
622
623          (define (make-arity-check picnic-env)
624            (lambda (s args loc)
625              (if (hash-table-exists? picnic-env s)
626                  (let ((op (hash-table-ref picnic-env s)))
627                    (if (extended-procedure? op)
628                        (let* ((fd   (procedure-data op))
629                               (fms   (lookup-def 'formals fd)))
630                         
631                          (if (not (= (length fms) (length args)))
632                              (picnic:error 'arity-check "procedure " s 
633                                          " called with incorrect number of arguments: "
634                                          args)))))
635                  (picnic:error 'arity-check "symbol " s "(" loc ")" " is not defined")
636                  )))
637
638
639          (define (env-extend! picnic-env)
640            (lambda (name type initial . alst)
641              (let* ((sym (if (symbol? name) name (string->symbol name)))
642                     (arity-check (make-arity-check picnic-env))
643                     (symbol-check (make-symbol-check picnic-env))
644                     (normalize-expr (make-normalize-expr arity-check symbol-check)))
645
646                (if (hash-table-exists? picnic-env sym)
647                    (picnic:error 'env-extend! "quantity " sym " already defined")
648                    (match type
649
650                           (('label)   
651                            (begin
652                              (if (not (symbol? initial)) 
653                                  (picnic:error 'env-extend! "label definitions require symbolic value"))
654                              (hash-table-set! picnic-env sym (LABEL initial))))
655
656                           (('external) 
657                            (begin
658                              (let* (
659                                     (ns             (lookup-def 'namespace alst))
660                                     (external-name  (lookup-def 'name alst))
661                                     (x              (EXTERNAL name external-name ns))
662                                     )
663                                (hash-table-set! picnic-env sym x)
664                                )))
665                           
666                           (('prim)
667                            (let* ((rhs (lookup-def 'rhs alst))
668                                   (val (if (and rhs (procedure? initial) )
669                                            (extend-procedure initial rhs)
670                                            initial)))
671                              (hash-table-set! picnic-env sym (PRIM name val))))
672
673                           (('config)   
674                            (hash-table-set! picnic-env sym (CONFIG name)))
675
676                           (('const)   
677                            (if (not (number? initial))
678                                (picnic:error 'env-extend! "constant definitions require numeric value" name initial)
679                                (hash-table-set! picnic-env sym (CONST name initial))
680                                ))
681
682                           (('asgn)
683                            (let* (
684                                   (rhs (lookup-def 'rhs alst))
685                                   )
686                             
687                              (if (not (eq? initial 'none))
688                                  (picnic:error 'env-extend! 
689                                              "state function definitions must have initial value of '(none)"))
690                              (if (not rhs) 
691                                  (picnic:error 'env-extend! "state function definitions require an equation"))
692                              (let ((expr1 (normalize-expr rhs (sprintf "assignment ~A" sym))))
693                                (hash-table-set! picnic-env sym (ASGN name 0.0 expr1)))
694                              ))
695
696                           (('initial)
697                            (let* (
698                                   (rhs (lookup-def 'rhs alst))
699                                   )
700                             
701                              (if (not (eq? initial 'none))
702                                  (picnic:error 'env-extend! 
703                                              "initial state function definitions must have initial value of '(none)"))
704                              (if (not rhs) 
705                                  (picnic:error 'env-extend! "initial state function definitions require an equation"))
706                              (let ((expr1 (normalize-expr rhs (sprintf "initial ~A" sym))))
707                                (hash-table-set! picnic-env sym (INITIAL name expr1)))
708                              ))
709
710                           (('process)   
711                            (let* (
712                                   (alst  (filter identity alst))
713                                   (gfun  (lookup-def 'gfun alst))
714                                   (npts  (lookup-def 'npts alst))
715                                   (initial (lookup-def 'initial alst))
716                                   (local-env (let ((local-env (hash-table-copy picnic-env)))
717                                                (hash-table-set! local-env name #t)
718                                                local-env))
719                                   (symbol-check (make-symbol-check local-env))
720                                   (normalize-expr (make-normalize-expr arity-check symbol-check))
721                                   )
722
723                              (if (not (and (symbol? gfun)
724                                            (procedure? (hash-table-ref local-env gfun))))
725                                  (picnic:error 'env-extend! "process definitions require a generating function"))
726
727                              (if (not npts)
728                                  (picnic:error 'env-extend! "process definitions require number of points"))
729                             
730                              (let ((initial-expr
731                                     (and initial
732                                          (normalize-expr initial
733                                                          (sprintf "initial value for process ~A" sym)))))
734
735                                (hash-table-set! picnic-env sym (PS name gfun initial-expr npts)))
736                             
737                              ))
738
739                           (('segmented-process) 
740                            (let* (
741                                   (alst    (filter identity alst))
742                                   (gfun    (lookup-def 'gfun alst))
743                                   (nsegs   (lookup-def 'nsegs alst))
744                                   (nsegpts (lookup-def 'nsegpts alst))
745                                   (initial (lookup-def 'initial alst))
746                                   (local-env (let ((local-env (hash-table-copy picnic-env)))
747                                                (hash-table-set! local-env name #t)
748                                                local-env))
749                                   (symbol-check (make-symbol-check local-env))
750                                   (normalize-expr (make-normalize-expr arity-check symbol-check))
751                                   )
752                             
753                              (if (not (and (symbol? gfun)
754                                            (procedure? (hash-table-ref local-env gfun))))
755                                  (picnic:error 'env-extend! "segmented process definitions require a generating function"))
756                             
757                              (if (not (and nsegs nsegpts))
758                                  (picnic:error 'env-extend! "segmented process definitions require number of points and number of segments"))
759                             
760                              (let ((initial-expr
761                                     (and initial
762                                          (normalize-expr initial
763                                                          (sprintf "initial value for process ~A" sym)))))
764
765                                (hash-table-set! picnic-env sym (SEGPS name gfun initial-expr nsegs nsegpts)))
766                             
767                              ))
768
769                           (('set) 
770                            (let* (
771                                   (rhs  initial)
772                                   (local-env (let ((local-env (hash-table-copy picnic-env)))
773                                                (hash-table-set! local-env name #t)
774                                                local-env))
775                                   (symbol-check (make-symbol-check local-env))
776                                   )
777                              (hash-table-set! picnic-env sym (SET name rhs))
778                             
779                              ))
780
781
782                           (else
783                            (begin
784                              (hash-table-set! picnic-env sym `(,type (name ,sym) . ,initial))))
785
786                           ))
787                ))
788            )
789
790
791          (define (infer picnic-env ftenv body)
792            (let recur ((expr body) (lb (list)))
793              (match expr 
794                     (('if c t e)
795                      (let ((ct (recur c lb))
796                            (tt (recur t lb))
797                            (et (recur e lb)))
798                        (and ct tt et 
799                             (begin
800                               (if (not (equal? ct 'bool)) 
801                                   (picnic:error 'infer "if condition type must be boolean"))
802                               (if (equal? tt et) tt
803                                   (picnic:error 'infer "type mismatch in if statement: then = " tt
804                                               " else = " et))))))
805                     (('let bs e)
806                      (let* ((rlb (lambda (x) (recur x lb)))
807                             (tbs (map rlb (map second bs)))
808                             (lb1 (append (zip (map first bs) tbs) lb)))
809                        (recur e lb1)))
810                     
811                     ((s . es)   
812                      (let* ((f    (hash-table-ref picnic-env s))
813                             (lst  (procedure-data f)))
814                        (and lst 
815                             (let ((rt   (lookup-def 'rt   lst))
816                                   (fms  (lookup-def 'formals lst)))
817                               (and rt fms
818                                    (begin
819                                      (for-each (lambda (x ft)
820                                                  (if (and (symbol? x) (not (hash-table-exists? ftenv x)))
821                                                      (hash-table-set! ftenv x ft)))
822                                                es fms)
823                                      (let* ((rlb (lambda (x) (recur x lb)))
824                                             (ets (map rlb es)))
825                                        (and (every identity ets)
826                                             (every (lambda (xt ft) (equal? xt ft)) ets fms)
827                                             rt))))))))
828                     
829                     (id    (cond ((symbol? id)     (or (lookup-def id lb) (hash-table-ref ftenv id)))
830                                  ((number? id)     fptype)
831                                  ((boolean? id)    'bool)
832                                  (else #f))))))
833         
834
835          (define (defun! picnic-env)
836
837            (lambda (name formals body)
838
839              (let* ((const-env (make-const-env picnic-env))
840                     (local-env (let ((local-env (hash-table-copy picnic-env)))
841                                  (for-each (lambda (s) (hash-table-set! local-env s #t))  formals)
842                                  local-env))
843                     (arity-check (make-arity-check local-env))
844                     (symbol-check (make-symbol-check local-env))
845                     (normalize-expr (make-normalize-expr arity-check symbol-check))
846                     (sym (if (symbol? name) name (string->symbol name))))
847
848                (letrec ((enumconsts
849                          (lambda (lb)
850                            (lambda (expr ax)
851                              (match expr 
852                                     (('let bs e)  (let ((ec (enumconsts (append (map first bs) lb))))
853                                                     (ec e (fold ec ax (map second bs)))))
854
855                                     (('if . es)   (fold (enumconsts lb) ax es))
856
857                                     ((s . es)     (cond ((and (symbol? s) (not (member s builtin-ops))
858                                                               (hash-table-exists? const-env s))
859                                                          (let ((v (const-env-entry->value (hash-table-ref const-env s))))
860                                                            (cons (cons s v) (fold (enumconsts lb) ax es))))
861
862                                                         ((and (symbol? s) (not (member s builtin-ops)) (not (member s lb)))
863                                                          (picnic:error 'defun "quantity " s " not defined"))
864
865                                                         (else (fold (enumconsts lb) ax es))
866                                                         ))
867
868                                     (s            (cond
869                                                    ((and (symbol? s) (not (member s lb)) 
870                                                          (hash-table-exists? const-env s))
871                                                     (let ((v (const-env-entry->value (hash-table-ref const-env s))))
872                                                       (cons (cons s v) ax) ))
873
874                                                    ((and (symbol? s) (not (member s lb)))
875                                                     (picnic:error 'defun "quantity " s " not defined"))
876
877                                                    (else ax)))
878
879                                     ))
880                            ))
881                         )
882
883
884                  (if (hash-table-exists? picnic-env sym)
885                      (picnic:error 'defun! "quantity " sym " already defined")
886                      (let* (
887                             (body    (normalize-expr body (sprintf "function ~A" sym)))
888                             (consts  (delete-duplicates ((enumconsts formals) body (list)) 
889                                                         (lambda (x y) (equal? (car x) (car y)))))
890                             (eval-body (let ((svs (map (lambda (sv) 
891                                                          (let ((s (car sv))
892                                                                (v (if (procedure? (cdr sv)) 
893                                                                       (lookup-def 'eval-body (procedure-data (cdr sv)))
894                                                                       (cdr sv))))
895                                                            `(,s ,v))) consts)))
896                                          (if (null? svs) `(lambda ,formals ,body)
897                                              `(let ,svs (lambda ,formals ,body)))))
898                             (f      (eval eval-body))
899                             )
900
901                        (let* ((ftenv  (make-const-ftenv picnic-env))
902                               (rt     (infer picnic-env ftenv body))
903                               (ftypes (filter-map (lambda (x) 
904                                                     (or (and (hash-table-exists? ftenv x)
905                                                              (hash-table-ref ftenv x)) 'double))
906                                                   formals))
907                               (ef     (extend-procedure f 
908                                                         `((name ,sym) (body ,body) (eval-body ,eval-body) 
909                                                           (rt ,rt) (formals ,ftypes) (vars ,formals)
910                                                           (consts ,(filter (lambda (x) (not (member x builtin-ops))) consts)))))
911                               )
912
913                          (hash-table-set! picnic-env sym ef))
914                        ))
915                  ))
916              ))
917
918          (define (symbol-list? lst)
919            (and (list? lst) (every symbol? lst)))
920
921          (define (sysname picnic-env)
922            (let ((v (hash-table-ref picnic-env (picnic-intern 'name))))
923              (and v (cases picnic:quantity v
924                            (SYSNAME (name)  name)))
925              ))
926         
927
928          (define (extended picnic-env)
929            (filter-map (lambda (sym) 
930                          (let ((x (hash-table-ref picnic-env sym)))
931                            (and (not (picnic:quantity? x)) (not (procedure? x)) 
932                                 (match x 
933                                        (((? symbol-list?) ('name name) . rest)  `(,sym ,x))
934                                        (else #f)))))
935                        (hash-table-keys picnic-env)))
936         
937
938          (define (extended-with-tag picnic-env tag)
939            (filter-map (lambda (sym) 
940                          (let ((x (hash-table-ref picnic-env sym)))
941                            (and (not (picnic:quantity? x)) (not (procedure? x)) 
942                                 (match x 
943                                        (((? (lambda (x) (equal? x tag))) ('name name) . rest) 
944                                         `(,sym ,x))
945                                        (else #f)))))
946                        (hash-table-keys picnic-env)))
947         
948
949          (define (components picnic-env)
950            (filter-map (lambda (sym) 
951                          (let ((x (hash-table-ref picnic-env sym)))
952                            (and (picnic:quantity? x)
953                                 (cases picnic:quantity x
954                                        (COMPONENT (name type lst _)  `(,name ,type ,sym))
955                                        (else #f)))))
956                        (hash-table-keys picnic-env)))
957
958
959          (define (component-name picnic-env sym)
960            (let ((x (hash-table-ref picnic-env sym)))
961              (and (picnic:quantity? x)
962                   (cases picnic:quantity x
963                          (COMPONENT (name type lst _)  name)
964                          (else #f)))))
965
966
967          (define (component-symbols picnic-env sym)
968            (let ((x (hash-table-ref picnic-env sym)))
969              (and (picnic:quantity? x)
970                   (cases picnic:quantity x
971                          (COMPONENT (name type lst _)  lst)
972                          (else #f)))))
973
974
975          (define (component-scope-subst picnic-env sym)
976            (let ((x (hash-table-ref picnic-env sym)))
977              (and (picnic:quantity? x)
978                   (cases picnic:quantity x
979                          (COMPONENT (name type lst scope-subst)  scope-subst)
980                          (else #f)))))
981
982
983          (define (component-exports picnic-env sym)
984            (let ((all-exports (cases picnic:quantity (hash-table-ref picnic-env (picnic-intern 'exports))
985                                      (EXPORTS (lst)  lst))))
986              (let ((x  (hash-table-ref picnic-env sym)))
987                (and (picnic:quantity? x)
988                     (cases picnic:quantity x
989                            (COMPONENT (name type lst _) 
990                                       (begin
991                                         (filter (lambda (x) (member x lst)) all-exports)))
992                            (else #f))))))
993
994          (define (component-imports picnic-env sym)
995            (let ((all-imports 
996                   (filter-map
997                    (lambda (sym) 
998                      (let ((x (hash-table-ref picnic-env sym)))
999                        (and (picnic:quantity? x)
1000                             (cases picnic:quantity x
1001                                    (EXTERNAL (local-name name namespace)
1002                                              (list local-name name namespace))
1003                                    (else #f)))))
1004                    (hash-table-keys picnic-env))))
1005              (let ((x (hash-table-ref picnic-env sym)))
1006                (and (picnic:quantity? x)
1007                     (cases picnic:quantity x
1008                            (COMPONENT (name type lst _) 
1009                                       (begin
1010                                         (filter (lambda (x) (member (car x) lst)) all-imports)))
1011                            (else #f))))))
1012
1013
1014          (define (component-subcomps picnic-env sym)
1015
1016            (define (component-type x)
1017              (cases picnic:quantity x
1018                     (COMPONENT (name type lst _) type)
1019                     (else #f)))
1020
1021            (define (component-name x)
1022              (cases picnic:quantity x
1023                     (COMPONENT (name type lst _) name)
1024                     (else #f)))
1025
1026            (let ((en (hash-table-ref picnic-env sym)))
1027              (and (picnic:quantity? en)
1028                   (cases picnic:quantity en
1029                          (COMPONENT (name type lst _) 
1030                                     (filter-map 
1031                                      (lambda (s) 
1032                                        (let ((x (hash-table-ref picnic-env s)))
1033                                          (and (iscomp? x) `(,(component-type x) ,(component-name x) ,s)))) lst))
1034                          (else #f)))))
1035
1036          (define (component-extend! picnic-env)
1037            (lambda (comp-name sym)
1038              (let ((x (hash-table-ref picnic-env comp-name)))
1039                (if (picnic:quantity? x)
1040                    (cases picnic:quantity x
1041                           (COMPONENT (name type lst scope-subst) 
1042                                      (let ((en1 (COMPONENT name type (delete-duplicates (append lst (list sym))) scope-subst)))
1043                                        (hash-table-set! picnic-env comp-name en1)))
1044                           (else (picnic:error 'component-extend! "invalid component " comp-name)))
1045                    (picnic:error 'component-extend! "invalid component " comp-name)))))
1046
1047
1048          (define (component-enumdeps picnic-env sym)
1049
1050            (let ((x (hash-table-ref picnic-env sym)))
1051              (and (picnic:quantity? x)
1052                   (cases picnic:quantity x
1053
1054                          (COMPONENT 
1055                           (name type lst scope-subst) 
1056                           (delete-duplicates
1057                            (append
1058                             (fold (lambda (qsym ax)
1059                                     (let* ((q   (hash-table-ref picnic-env qsym))
1060                                            (rhs (qrhs q)))
1061                                       (or (and rhs (append (enumdeps rhs) ax)) ax)))
1062                                   '()
1063                                   lst)
1064                             (fold (lambda (x ax) (append (component-enumdeps picnic-env (third x)) ax))
1065                                   '()
1066                                   (component-subcomps picnic-env sym)))))
1067
1068                          (else #f)))))
1069
1070
1071          (define (component-env picnic-env sym . syms)
1072            (fold 
1073             (lambda (sym env)
1074               (let ((comp (hash-table-ref picnic-env sym)))
1075                 (and (picnic:quantity? comp)
1076                      (cases picnic:quantity comp
1077                             (COMPONENT 
1078                              (name type lst scope-subst) 
1079                              (let* ((depnames (component-enumdeps picnic-env sym))
1080                                     (subnames (map third (component-subcomps picnic-env sym)))
1081                                     (cnames   lst))
1082                                (let* ((syms (delete-duplicates (append depnames subnames cnames)))
1083                                       (vals (map (lambda (x) (hash-table-ref picnic-env x)) syms)))
1084                                  (for-each (lambda (s v) (hash-table-set! env s v)) 
1085                                            syms vals)
1086                                  env
1087                                  )))
1088                             (else env)))))
1089             (picnic:env-copy base-env)
1090             (cons sym syms)))
1091
1092
1093          (define (exports picnic-env)
1094            (cases picnic:quantity (hash-table-ref picnic-env (picnic-intern 'exports))
1095                   (EXPORTS (lst)  lst)))
1096
1097
1098          (define (imports picnic-env)
1099            (filter-map (lambda (sym) 
1100                          (let ((x (hash-table-ref picnic-env sym)))
1101                            (and (picnic:quantity? x)
1102                                 (cases picnic:quantity x
1103                                        (EXTERNAL (local-name name namespace)
1104                                                  (list local-name name namespace))
1105                                        (else #f)))))
1106                        (hash-table-keys picnic-env)))
1107
1108
1109
1110          (define (configs picnic-env)
1111            (filter-map (lambda (sym) 
1112                          (let ((x (hash-table-ref picnic-env sym)))
1113                            (and (picnic:quantity? x)
1114                                 (cases picnic:quantity x
1115                                        (CONFIG (name)  (list name (lookup-def name local-config) ))
1116                                        (else #f)))))
1117                        (hash-table-keys picnic-env)))
1118
1119
1120          (define (consts picnic-env)
1121            (filter-map (lambda (sym) 
1122                          (let ((x (hash-table-ref picnic-env sym)))
1123                            (and (picnic:quantity? x)
1124                                 (cases picnic:quantity x
1125                                        (CONST (name value)  (list name value) )
1126                                        (else #f)))))
1127                        (hash-table-keys picnic-env)))
1128
1129
1130
1131          (define (states picnic-env)
1132            (fold (lambda (sym ax) 
1133                    (let ((x (hash-table-ref picnic-env sym)))
1134                      (if (picnic:quantity? x)
1135                          (cases picnic:quantity x
1136                                 (PS (name gfun initial-expr npts)
1137                                     (cons name ax))
1138                                 (SEGPS (name gfun initial-expr nsegs nsegpts)
1139                                        (cons name ax))
1140                                 (else ax))
1141                          ax)))
1142                  (list) (hash-table-keys picnic-env)))
1143
1144
1145          (define (processes picnic-env)
1146            (fold (lambda (sym ax) 
1147                    (let ((x (hash-table-ref picnic-env sym)))
1148                      (if (picnic:quantity? x)
1149                          (cases picnic:quantity x
1150                                 (PS (name gfun initial npts)
1151                                     (cons name ax))
1152                                 (else ax))
1153                          ax)))
1154                  (list) (hash-table-keys picnic-env)))
1155
1156          (define (segmented-processes picnic-env)
1157            (fold (lambda (sym ax) 
1158                    (let ((x (hash-table-ref picnic-env sym)))
1159                      (if (picnic:quantity? x)
1160                          (cases picnic:quantity x
1161                                 (SEGPS (name gfun initial-expr nsegs nsegpts)
1162                                        (cons name ax))
1163                                 (else ax))
1164                          ax)))
1165                  (list) (hash-table-keys picnic-env)))
1166
1167
1168          (define (initials picnic-env)
1169            (filter-map (lambda (sym) 
1170                          (let ((x (hash-table-ref picnic-env sym)))
1171                            (and (picnic:quantity? x)
1172                                 (cases picnic:quantity x
1173                                        (INITIAL (name rhs) name)
1174                                        (else #f)))))
1175                        (hash-table-keys picnic-env)))
1176
1177          (define (asgns picnic-env)
1178            (filter-map (lambda (sym) 
1179                          (let ((x (hash-table-ref picnic-env sym)))
1180                            (and (picnic:quantity? x)
1181                                 (cases picnic:quantity x
1182                                        (ASGN (name value rhs) name)
1183                                        (else #f)))))
1184                        (hash-table-keys picnic-env)))
1185
1186
1187          (define (defuns picnic-env)
1188            (filter-map (lambda (sym) 
1189                          (let ((x (hash-table-ref picnic-env sym)))
1190                            (and (procedure? x) (not (member sym builtin-ops)) (list sym x))))
1191                        (hash-table-keys picnic-env)))
1192
1193          (define (sets picnic-env)
1194            (filter-map (lambda (sym) 
1195                          (let ((x (hash-table-ref picnic-env sym)))
1196                            (and (picnic:quantity? x)
1197                                 (cases picnic:quantity x
1198                                        (SET (name rhs) name)
1199                                        (else #f)))))
1200                        (hash-table-keys picnic-env)))
1201
1202
1203          (define (toplevel picnic-env)
1204            (cases picnic:quantity (hash-table-ref picnic-env (picnic-intern 'toplevel))
1205                   (COMPONENT (name type lst _) `(,type ,lst))))
1206
1207         
1208          (define (eval-simple-expr env expr)
1209            (cond ((number? expr) expr)
1210                  ((symbol? expr) (hash-table-ref env expr))
1211                  ((pair? expr)   (match expr
1212                                         (('if cexpr then-expr else-expr)
1213                                          (let ((cval (eval-simple-expr env cexpr))
1214                                                (then-val (eval-simple-expr env then-expr))
1215                                                (else-val (eval-simple-expr env else-expr))
1216                                                )
1217                                            (if cval then-val else-val)
1218                                            ))
1219                                         (else
1220                                          (let ((expr1 (map (lambda (x) (eval-simple-expr env x)) expr)))
1221                                            (apply (car expr1) (cdr expr1))))))
1222                  ))
1223
1224          (define (eval-const picnic-env expr qname)
1225            (let* ((arity-check (make-arity-check picnic-env))
1226                   (symbol-check (make-symbol-check picnic-env))
1227                   (normalize-expr (make-normalize-expr arity-check symbol-check)))
1228              (let ((expr1 (normalize-expr expr (sprintf "constant ~A" qname)))
1229                    (const-env (make-const-env picnic-env)))
1230                (condition-case
1231                 (exact->inexact (eval-simple-expr const-env expr1))
1232                 [var () expr1])
1233                )))
1234
1235
1236          (define (iscomp? x)
1237            (cond ((picnic:quantity? x)
1238                   (cases picnic:quantity x
1239                          (COMPONENT  (name type lst _)  #t)
1240                          (else #f)))
1241                  (else #f)))
1242
1243          (define (isdep? x)
1244            (cond ((picnic:quantity? x)
1245                   (cases picnic:quantity x
1246                          (SET     (name rhs)  #t)
1247                          (ASGN    (name value rhs)  #t)
1248                          (INITIAL (name rhs)  #t)
1249                          (EXTERNAL   (ln name ns) #t)
1250                          (else #f)))
1251                  ((and (list? x) (every pair? (cdr x)))  (alist-ref 'dep?  (cdr x)))
1252                  (else #f)))
1253
1254
1255          (define (isstate? x)
1256            (and (picnic:quantity? x)
1257                 (cases picnic:quantity x
1258                        (PS        (name gfun initial npts)  #t)
1259                        (SEGPS     (name gfun initial-expr nsegs nsegpts) #t)
1260                        (else #f))
1261                 ))
1262
1263
1264          (define (qrhs x)
1265            (and (picnic:quantity? x)
1266                 (cases picnic:quantity x
1267                        (SET (name rhs)   (let recur ((rhs rhs))
1268                                            (match rhs 
1269                                                   (('section v l) (list v))
1270                                                   (('union l r) (append (recur l) (recur r)))
1271                                                   (else rhs))))
1272                        (PS (name gfun initial npts)   gfun)
1273                        (SEGPS (name gfun initial-expr nsegs nsegpts) gfun)
1274                        (ASGN  (name value rhs)  rhs)
1275                        (INITIAL  (name rhs)  rhs)
1276                        (else #f))))
1277
1278
1279          ;; create equation dependency graph
1280          (define (make-eqng picnic-env)
1281            (let* ((sysname    (sysname picnic-env))
1282                   (g          (make-digraph sysname (string-append (symbol->string sysname) 
1283                                                                    " equation dependency graph")))
1284                   (add-node!  (g 'add-node!))
1285                   (add-edge!  (g 'add-edge!))
1286                   (picnic-list  (filter (lambda (sym) 
1287                                         (let ((x (hash-table-ref picnic-env sym)))
1288                                           (or (isstate? x) (isdep? x))))
1289                                       (hash-table-keys picnic-env)))
1290                   (picnic-ids      (list-tabulate (length picnic-list) identity))
1291                   (name->id-map  (zip picnic-list picnic-ids)))
1292
1293              (let-values (((state-list asgn-list) 
1294                            (partition (lambda (sym) (isstate? (hash-table-ref picnic-env sym)))
1295                                       picnic-list)))
1296               
1297                ;; insert equations in the dependency graph
1298                (for-each (lambda (i n) (add-node! i n)) picnic-ids picnic-list)
1299                ;; create dependency edges in the graph
1300                (for-each (lambda (e) 
1301                            (match e ((ni . nj) (begin
1302                                                  (let ((i (car (alist-ref ni name->id-map)))
1303                                                        (j (car (alist-ref nj name->id-map))))
1304                                                    (add-edge! (list i j (format "~A=>~A" ni nj))))))
1305                                   (else (picnic:error 'make-eqng "invalid edge " e))))
1306                          (fold (lambda (qsym ax) 
1307                                  (let* ((q   (hash-table-ref picnic-env qsym))
1308                                         (rhs (qrhs q)))
1309                                    (if rhs 
1310                                        (let* ((deps (filter (if (isstate? q)
1311                                                                 (lambda (sym) 
1312                                                                   (if (not (hash-table-exists? picnic-env sym))
1313                                                                       (picnic:error 'make-eqng "undefined symbol " sym 
1314                                                                                   " in definition of quantity " qsym))
1315                                                                   (and (let ((x (hash-table-ref picnic-env sym)))
1316                                                                          (and (isdep? x) (not (eq? sym qsym))))))
1317                                                                 (lambda (sym) 
1318                                                                   (if (not (hash-table-exists? picnic-env sym))
1319                                                                       (picnic:error 'make-eqng "undefined symbol " sym 
1320                                                                                   " in definition of quantity " qsym))
1321                                                                   (and (let ((x (hash-table-ref picnic-env sym)))
1322                                                                          (isdep? x)))))
1323                                                             (enumdeps rhs)))
1324
1325                                               (edges (map (lambda (d) (cons qsym d)) deps)))
1326                                          (if edges (append edges ax) ax))
1327                                        ax)))
1328                                (list) picnic-list))
1329                (let ((cycles (graph-cycles-fold g (lambda (cycle ax) (cons cycle ax)) (list))))
1330                  (if (null? cycles) (list state-list asgn-list g)
1331                      (picnic:error 'make-eqng "equation cycle detected: " (car cycles)))))))
1332
1333
1334          ;; given a graph, create a partial ordering based on BFS distance from root
1335          (define (graph->bfs-dist-poset g #!key (root-labels #f))
1336            (define node-info (g 'node-info))
1337            (let ((roots (if root-labels
1338                             (let ((node-map (map reverse ((g 'nodes)))))
1339                               (filter-map 
1340                                (lambda (x) (let ((xn (alist-ref x node-map))) (and xn (first xn))))
1341                                root-labels))
1342                             ((g 'roots)))))
1343            (let-values (((dists dmax) (graph-bfs-dist g roots)))
1344              (let loop ((poset  (make-vector (+ 1 dmax) (list)))
1345                         (i      (- (s32vector-length dists) 1)))
1346                (if (>= i 0)
1347                    (let* ((c     (s32vector-ref dists i))
1348                           (info  (and (>= c 0) (node-info i))))
1349                      (if info
1350                          (vector-set! poset c (cons (cons i info) (vector-ref poset c))))
1351                      (loop poset (- i 1)))
1352                    (begin
1353                      (list->vector (reverse (vector->list poset)))
1354                      ))
1355                ))
1356            ))
1357
1358
1359          (define (make-eval-poset picnic-env eqposet)
1360            (vector-map 
1361             (lambda (i lst) 
1362               (filter-map (lambda (id+sym)
1363                             (let* ((sym  (cdr id+sym))
1364                                    (x    (hash-table-ref picnic-env sym)))
1365                               (and (picnic:quantity? x)
1366                                    (cases picnic:quantity x
1367                                           (PS  (name gfun initial npts)
1368                                                (list 'ps sym gfun))
1369                                           (SEGPS  (name gfun initial nsegs nsegpts)
1370                                                   (list 'segps sym gfun))
1371                                           (ASGN  (name value rhs)
1372                                                  (list 'a sym rhs))
1373                                           (INITIAL  (name rhs)
1374                                                  (list 'init sym rhs))
1375                                           (SET  (name rhs)
1376                                                 (list 'set sym rhs))
1377                                           (else picnic:error 'make-eval-poset
1378                                                 "invalid quantity in equation poset: " sym)))))
1379                           lst))
1380             eqposet))
1381
1382
1383        (define (eval-set-expr env) 
1384          (lambda (expr)
1385            (match expr
1386                   (('population pop)  (hash-table-ref env pop))
1387                   (('section pop sec) (let ((pop (hash-table-ref env pop)))
1388                                         (alist-ref sec pop)))
1389                   (('union x y)       (lset-union equal? x y))
1390                   (else #f))))
1391
1392          (define (eval-expr env)
1393            (lambda (expr)
1394              (let ((val (match expr
1395                                (('if c t f) 
1396                                 (let ((ee (eval-expr env)))
1397                                   (condition-case
1398                                    (if (ee c) (ee t) (ee f))
1399                                    [var () 
1400                                         (picnic:error 'eval-expr " exception in " expr ": \n"
1401                                                     (lambda () (print-error-message var)))])))
1402
1403                                ((s . es)   
1404                                 (condition-case 
1405                                  (let ((op   (hash-table-ref env s))
1406                                        (args (map (eval-expr env) es)))
1407                                    (if (extended-procedure? op)
1408                                        (let* ((fd  (procedure-data op))
1409                                               (vs  (lookup-def 'formals fd)))
1410                                          (if (not (= (length vs) (length args)))
1411                                              (picnic:error 'eval-expr "procedure " s 
1412                                                          " called with incorrect number of arguments"))))
1413                                    (apply op args))
1414                                  [var () 
1415                                       (picnic:error 'eval-expr " exception in " expr ": \n"
1416                                                   (lambda () (print-error-message var)))]))
1417                               
1418                                (s                 
1419                                 (cond ((symbol? s) (hash-table-ref env s))
1420                                       ((or (number? s) (string? s)) s)
1421                                       (else (picnic:error 'eval-expr "unknown expression " s)))))))
1422                val)))
1423
1424
1425          (define (eval-poset picnic-env eqposet)
1426            (let ((my-env (hash-table-copy picnic-env)))
1427              (vector-for-each 
1428               (lambda (i lst) 
1429                 (for-each
1430                  (lambda (id+sym)
1431                    (let* ((sym  (cdr id+sym))
1432                           (x    (hash-table-ref my-env sym)))
1433                      (and (picnic:quantity? x)
1434                           (cases picnic:quantity x
1435                                  (SET  (name rhs)
1436                                         (let ((v ((eval-set-expr my-env) rhs)))
1437                                           (hash-table-set! my-env sym v)))
1438                                  (ASGN  (name value rhs)
1439                                         (let ((v ((eval-expr my-env) rhs)))
1440                                           (hash-table-set! my-env sym v)))
1441                                  (INITIAL  (name rhs)
1442                                         (let ((v ((eval-expr my-env) rhs)))
1443                                           (hash-table-set! my-env sym v)))
1444                                  (else picnic:error 'eval-poset
1445                                        "invalid quantity in equation poset: " sym)))))
1446                  lst))
1447               eqposet)
1448              my-env
1449              ))
1450
1451
1452          (define (depgraph picnic-env)
1453            (match-let (((state-list asgn-list g)  (make-eqng picnic-env))) g))
1454
1455
1456          (define (depgraph* picnic-env)
1457            (match-let (((state-list asgn-list g)  (make-eqng picnic-env))) 
1458                       (list state-list asgn-list g)))
1459
1460
1461          ;; Dispatcher
1462          (define (picnic-dispatch selector)
1463            (case selector
1464              ((add-external!)     add-external!)
1465              ((defun!)            defun!)
1466              ((depgraph)          depgraph)
1467              ((depgraph*)         depgraph*)
1468              ((depgraph->bfs-dist-poset)  graph->bfs-dist-poset)
1469              ((make-eval-poset)   make-eval-poset)
1470              ((eval-const)        eval-const)
1471              ((eval-poset)        eval-poset)
1472              ((env-extend!)       env-extend!)
1473              ((subst-expr)        (subst-driver (lambda (x) (and (symbol? x) x)) 
1474                                                 picnic:binding? 
1475                                                 identity 
1476                                                 picnic:bind 
1477                                                 picnic:subst-term))
1478              ((make-const-env)      make-const-env)
1479              ((system)              system)
1480              ((sysname)             sysname)
1481              ((asgns)               asgns)
1482              ((initials)            initials)
1483              ((states)              states)
1484              ((processes)           processes)
1485              ((segmented-processes) segmented-processes)
1486              ((sets)                sets)
1487              ((defuns)              defuns)
1488              ((consts)              consts)
1489              ((configs)             configs)
1490              ((exports)             exports)
1491              ((imports)             imports)
1492              ((toplevel)            toplevel)
1493              ((components)          components)
1494              ((component-env)       component-env)
1495              ((component-name)      component-name)
1496              ((component-symbols)   component-symbols)
1497              ((component-exports)   component-exports)
1498              ((component-imports)   component-imports)
1499              ((component-subcomps)  component-subcomps)
1500              ((component-scope-subst)  component-scope-subst)
1501              ((component-extend!)   component-extend!)
1502              ((extended)            extended)
1503              ((extended-with-tag)   extended-with-tag)
1504              (else
1505               (picnic:error 'selector "unknown message " selector " sent to an picnic-core object"))))
1506
1507          picnic-dispatch)
1508
1509
1510        (define (eval-picnic-system-decls picnic-core name sys declarations #!key 
1511                                        (parse-expr (lambda (x . rest) x))
1512                                        (initial-scope #f))
1513
1514          (define (eval-const x loc) (and x ((picnic-core 'eval-const) sys x loc)))
1515          (define env-extend!  ((picnic-core 'env-extend!) sys))
1516          (define (compute-qid id scope scope-subst) (or (and scope scope-subst (picnic-scoped scope id)) id))
1517          (define (update-subst id qid subst) (if (equal? id qid) subst
1518                                                  (subst-extend id qid subst) ))
1519          (define subst-expr  (subst-driver (lambda (x) (and (symbol? x) x)) 
1520                                            picnic:binding? 
1521                                            identity 
1522                                            picnic:bind 
1523                                            picnic:subst-term))
1524          (define (subst-set-expr x subst-env)
1525            (match x 
1526                 (('population pop)  `(population ,(subst-expr pop subst-env)))
1527                 (('section pop sec) `(section ,(subst-expr pop subst-env) ,sec))
1528                 (('union x y)       `(union ,(subst-set-expr x subst-env)
1529                                             ,(subst-set-expr y subst-env)))
1530                 (else #f)))
1531
1532
1533          (let ((res
1534                 (let loop ((ds declarations) (qs (list)) (scope initial-scope) (scope-subst '()))
1535
1536                   (if (null? ds) 
1537                       (let ((qs (reverse qs)))
1538                         (if (not scope)
1539                             (let* ((top-syms   ((picnic-core 'component-symbols ) sys (picnic-intern 'toplevel)))
1540                                    (top-syms1  (append qs top-syms)))
1541                               (hash-table-set! sys (picnic-intern 'toplevel) (COMPONENT 'toplevel 'toplevel top-syms1 '()))))
1542                         (list qs scope-subst))
1543                       (let ((decl (car ds)))
1544                         (if (null? decl)
1545                             (loop (cdr ds) qs scope scope-subst)
1546                             (match-let 
1547                              (((qs1 scope-subst1)
1548                                (match decl
1549
1550                                       ;; labels
1551                                       (((or 'label 'LABEL) (and id (? symbol?)) '= (and v (? symbol?)))
1552                                        (let* ((qid  (compute-qid id scope scope-subst)))
1553                                          (env-extend! qid '(label) v)
1554                                          (list (cons qid qs) (update-subst id qid scope-subst))))
1555                                       
1556                                       ;; imported quantities
1557                                       (((or 'input 'INPUT) . lst) 
1558                                        (cond ((every (lambda (x) (or (symbol? x) (list? x))) lst)
1559                                               (fold
1560                                                (lambda (x ax) 
1561                                                  (match-let (((qs scope-subst) ax))
1562                                                             (match x
1563                                                                    ((? symbol?) 
1564                                                                     (let ((qid (compute-qid x scope scope-subst)))
1565                                                                       (((picnic-core 'add-external!) sys) x `(input ,x ,qid #f))
1566                                                                       (list (cons qid qs) (update-subst x qid scope-subst))))
1567                                                                    ((id1 (or 'as 'AS) x1 . rest) 
1568                                                                     (let ((qid (compute-qid x1 scope scope-subst)))
1569                                                                       (((picnic-core 'add-external!) sys) x `(input ,id1 ,qid #f ,@rest))
1570                                                                       (list (cons qid qs) (update-subst x1 qid scope-subst) )))
1571                                                                    ((id1 (or 'from 'FROM) n1 . rest) 
1572                                                                     (let ((qid (compute-qid id1 scope scope-subst)))
1573                                                                       (((picnic-core 'add-external!) sys) x `(input ,id1 ,qid ,n1 ,@rest))
1574                                                                       (list (cons qid qs) (update-subst id1 qid scope-subst) )))
1575                                                                    ((id1 (or 'as 'AS) x1 (or 'from 'FROM) n1 . rest)
1576                                                                     (let ((qid (compute-qid x1 scope scope-subst)))
1577                                                                       (((picnic-core 'add-external!) sys) x `(input ,id1 ,qid ,n1 ,@rest))
1578                                                                       (list (cons qid qs) (update-subst x1 qid scope-subst) )))
1579                                                                    (((and id1 (? symbol?)) . rest)
1580                                                                     (let ((qid (compute-qid id1 scope scope-subst)))
1581                                                                       (((picnic-core 'add-external!) sys) id1 `(input ,id1 ,qid #f ,@rest))
1582                                                                       (list (cons qid qs) (update-subst id1 qid scope-subst))))
1583                                                                    )))
1584                                                (list qs scope-subst) lst))
1585                                              (else (picnic:error 'eval-picnic-system-decls 
1586                                                                "import statement must be of the form: "
1587                                                                "input id1 [as x1] ... "))))
1588                                       
1589                                       ;; exported quantities
1590                                       (((or 'output 'OUTPUT) . (and lst (? (lambda (x) (every symbol? x)))))
1591                                        (let ((lst1 (map (lambda (x) (compute-qid x scope scope-subst)) lst)))
1592                                          (for-each (lambda (x) (((picnic-core 'add-external!) sys) x 'output)) lst1)
1593                                          (list qs scope-subst)))
1594                                       
1595                                       ;; constant read from a config file
1596                                       (((or 'config 'CONFIG) (and id (? symbol?)) . rest)
1597                                        (let* (
1598                                               (qid    (compute-qid id scope scope-subst))
1599                                               (alst   (filter identity rest))
1600                                               )
1601                                          (apply env-extend! (list qid '(config) #f))
1602                                          (list (cons qid qs) (update-subst id qid scope-subst))
1603                                          ))
1604
1605
1606                                       ;; constant during point generation
1607                                       (((or 'const 'CONST) (and id (? symbol?)) '= (and expr (? expr? )) . rest)
1608                                        (let* ((qid    (compute-qid id scope scope-subst))
1609                                               (qexpr  (subst-expr (parse-expr expr `(const ,qid)) scope-subst))
1610                                               (qval   (eval-const qexpr id))
1611                                               (alst   (filter identity rest))
1612                                               )
1613                                          (apply env-extend! (list qid '(const) qval))
1614                                          (list (cons qid qs) (update-subst id qid scope-subst))
1615                                          ))
1616
1617                                       ;; process equation
1618                                       (((or 'p 'process 'PROCESS) ((and id (? symbol?))) '= . rest)
1619
1620                                        (let* ((qid     (compute-qid id scope scope-subst))
1621                                               (scope-subst1 (update-subst id qid scope-subst))
1622                                               (alst    (filter identity rest))
1623                                               (gfun    ((lambda (x) (and x (subst-expr (parse-expr x `(segprocess ,id)) scope-subst)))
1624                                                         (lookup-def 'generator alst)))
1625                                               (initial ((lambda (x) (and x (subst-expr (parse-expr x `(segprocess ,id)) scope-subst)))
1626                                                         (lookup-def 'initial alst)))
1627                                               (npts    ((lambda (x) (if x (subst-expr (parse-expr x `(process ,id)) scope-subst) 2))
1628                                                         (lookup-def 'npts alst)))
1629                                               )
1630
1631                                          (apply env-extend!
1632                                                 (list qid '(process) #f
1633                                                       (and npts `(npts ,(eval-const npts (sprintf "~A.npts" id)) ))
1634                                                       (and gfun `(gfun ,gfun))
1635                                                       (and initial `(initial ,initial))
1636                                                       ))
1637                                          (list (cons qid qs) scope-subst1)))
1638                                       
1639                                       ;; segmented process equation
1640                                       (((or 'segp 'segmented-process 'SEGMENTED-PROCESS) 
1641                                         ((and id (? symbol?))) '= . rest)
1642
1643                                        (let* ((qid     (compute-qid id scope scope-subst))
1644                                               (scope-subst1 (update-subst id qid scope-subst))
1645                                               (alst    (filter identity rest))
1646                                               (gfun    ((lambda (x) (and x (subst-expr (parse-expr x `(segprocess ,id)) scope-subst)))
1647                                                          (lookup-def 'generator alst)))
1648                                               (initial ((lambda (x) (and x (subst-expr (parse-expr x `(segprocess ,id)) scope-subst)))
1649                                                          (lookup-def 'initial alst)))
1650                                               (nsegs    ((lambda (x) (and x (subst-expr (parse-expr x `(segprocess ,id)) scope-subst)))
1651                                                          (lookup-def 'nsegs alst)))
1652                                               (nsegpts ((lambda (x) (and x (subst-expr (parse-expr x `(segprocess ,id)) scope-subst)))
1653                                                         (lookup-def 'nsegpts alst)))
1654                                               )
1655
1656                                          (apply env-extend!
1657                                                 (list qid '(segmented-process) #f
1658                                                       (and nsegs `(nsegs ,(eval-const nsegs (sprintf "~A.nsegs" id)) ))
1659                                                       (and nsegpts `(nsegpts ,(eval-const nsegpts (sprintf "~A.nsegpts" id)) ))
1660                                                       (and gfun `(gfun ,gfun))
1661                                                       (and initial `(initial ,initial))
1662                                                       ))
1663                                          (list (cons qid qs) scope-subst1)))
1664
1665                                       ;; population set
1666                                       (((or 'set 'SET) (and id (? symbol?)) '= (and rhs (? setexpr?)))
1667
1668                                        (let* ((loc    `(set ,id)))
1669
1670                                          (let* ((qid (compute-qid id scope scope-subst))
1671                                                 (qexpr (subst-set-expr rhs scope-subst)))
1672
1673                                            (apply env-extend! (cons* qid '(set) qexpr '()))
1674                                            (list (cons qid qs) (update-subst id qid scope-subst)))
1675                                          ))
1676                               
1677                                       
1678                                       ;; algebraic assignment
1679                                       (((and id (? symbol?)) '= (and expr (? expr?) ) . rest)
1680                                        (let* ((qid    (compute-qid id scope scope-subst))
1681                                               (qexpr  (subst-expr (parse-expr expr `(asgn ,id)) scope-subst))
1682                                               (alst   (filter identity rest))
1683                                               )
1684                                          (apply env-extend! (list qid '(asgn) 'none `(rhs ,qexpr)))
1685                                          (list (cons qid qs) (update-subst id qid scope-subst))))
1686                                       
1687                                       ;; single-state algebraic assignment
1688                                       (('initial (and id (? symbol?)) '= (and expr (? expr?) ) . rest)
1689                                        (let* ((qid    (compute-qid id scope scope-subst))
1690                                               (qexpr  (subst-expr (parse-expr expr `(initial ,id)) scope-subst))
1691                                               (alst   (filter identity rest))
1692                                               )
1693                                          (apply env-extend! (list qid '(initial) 'none `(rhs ,qexpr)))
1694                                          (list (cons qid qs) (update-subst id qid scope-subst))))
1695                                       
1696                                       ;; user-defined function
1697                                       (((or 'fun 'FUN 'rel 'REL 'defun 'DEFUN) (and id (? symbol?)) 
1698                                         (and idlist (? (lambda (x) (every symbol? x)))) 
1699                                         (and expr (? expr?)))
1700
1701                                        (let* ((qid          (compute-qid id scope scope-subst))
1702                                               (scope-subst1 (fold (lambda (x ax) (subst-remove x ax))
1703                                                                   scope-subst
1704                                                                   idlist))
1705                                               (qexpr         (subst-expr (parse-expr expr `(defun ,qid)) 
1706                                                                          scope-subst1))
1707                                               )
1708                                          (((picnic-core 'defun!) sys) qid idlist qexpr)
1709                                          (list (cons qid qs) (update-subst id qid scope-subst))))
1710                                       
1711                                       ;; compiled primitives
1712                                       (((or 'prim 'PRIM) id value) 
1713                                        (cond ((symbol? id)  (env-extend! id '(prim) value))
1714                                              (else (picnic:error 'eval-picnic-system-decls 
1715                                                                "prim declarations must be of the form: "
1716                                                                "prim id value"))))
1717
1718                                       (((or 'sysname 'SYSNAME) name) 
1719                                        (if (symbol? name)
1720                                            (hash-table-set! sys (picnic-intern 'name) (SYSNAME name))
1721                                            (picnic:error 'eval-picnic-system-decls
1722                                                        "system name must be a symbol")))
1723                                       
1724                                       (((or 'component 'COMPONENT)
1725                                         ((or 'type 'TYPE) typ) 
1726                                         ((or 'name 'NAME) name) . lst)
1727
1728                                        (let ((name1 (let ((x (and (hash-table-exists? 
1729                                                                    sys (or (lookup-def name scope-subst) name))
1730                                                                   (hash-table-ref 
1731                                                                    sys (or (lookup-def name scope-subst) name)))))
1732                                                       (or (and x (picnic:quantity? x)
1733                                                                (cases picnic:quantity x
1734                                                                       (LABEL (v)  v)
1735                                                                       (else name)))
1736                                                           name))))
1737
1738                                          (let* ((sym   (fresh "comp"))
1739                                                 (scope (if scope (cons sym scope) (list sym))))
1740                                            (match-let (((cqs scope-subst1)   (loop lst (list) scope scope-subst)))
1741                                                       (let ((comp  (COMPONENT name1 typ cqs scope-subst1)))
1742                                                         (hash-table-set! sys sym comp)
1743                                                         (list (cons sym qs) scope-subst1))))))
1744
1745                                       (((or 'component 'COMPONENT) ((or 'type 'TYPE) typ)  . lst) 
1746                                        (let* ((sym   (fresh "comp"))
1747                                               (scope (if scope (cons sym scope) (list sym))))
1748
1749                                          (match-let (((cqs scope-subst1)   (loop lst (list) scope scope-subst)))
1750                                                     (let ((comp  (COMPONENT sym typ cqs scope-subst1)))
1751                                                       (hash-table-set! sys sym comp)
1752                                                       (list (cons sym qs) scope-subst1)))))
1753
1754                                       (((or 'component 'COMPONENT)  ((or 'name 'NAME) name) '= 
1755                                         (and functor-name (? symbol?)) 
1756                                         (and args (? list?)))
1757
1758                                        (if (and scope scope-subst) 
1759                                            (picnic:error 'eval-picnic-system-decls
1760                                                        "functor instantiation is not permitted in nested scope"))
1761
1762                                        (match-let
1763                                         (((functor-args functor-type functor-lst)
1764                                           (let ((x (hash-table-ref sys functor-name)))
1765                                             (or (and (picnic:quantity? x)
1766                                                      (cases picnic:quantity x
1767                                                             (FUNCTOR (sym args typ lst)  (list args typ lst))
1768                                                             (else #f)))
1769                                                 (picnic:error 'eval-picnic-system-decls! functor-name 
1770                                                             " is not a functor" )))))
1771
1772                                         (if (not (<= (length functor-args)  (length args)))
1773                                             (let ((n (length args)))
1774                                               (picnic:error 'eval-picnic-system-decls! "functor " functor-name 
1775                                                           " requires at least " (length functor-args) " arguments; "
1776                                                           args  " (total " n ") "
1777                                                           (if (= n 1) "was" "were") " given" )))
1778
1779
1780                                         (match-let
1781                                          (((cqs1 scope-subst1)   (loop args (list) name scope-subst)))
1782                                          (let ((cqs1-names (sort (map ->string cqs1) string< ))
1783                                                (args-names (let ((qs (map (lambda (x) 
1784                                                                             (->string (compute-qid x name scope-subst1)) )
1785                                                                           functor-args)))
1786                                                              (sort qs string<))))
1787
1788                                            (if (not (every (lambda (x) (member x cqs1-names string=)) args-names))
1789                                                (picnic:error 'eval-picnic-system-decls! "functor " functor-name 
1790                                                            " instantiation did not include required arguments " 
1791                                                            (filter (lambda (x) (not (member x cqs1-names string=))) args-names)))
1792                                           
1793                                            (match-let
1794                                             (((cqs2 scope-subst2)   (loop functor-lst (list) name scope-subst1)))
1795                                             (let* ((sym    (fresh "comp"))
1796                                                    (comp   (COMPONENT name functor-type (append cqs1 cqs2) scope-subst2)))
1797                                               (hash-table-set! sys sym comp)
1798                                               
1799                                               (list (cons sym qs) scope-subst)))))))
1800                                       
1801                                       ((or
1802                                         ((or 'functor 'FUNCTOR) ((or 'name 'NAME) name) ((or 'type 'TYPE) typ)
1803                                          (and args (? list?))  '= . lst)
1804                                         ((or 'functor 'FUNCTOR) ((or 'type 'TYPE) typ) ((or 'name 'NAME) name)
1805                                          (and args (? list?))  '= . lst))
1806
1807                                        (if (and scope scope-subst) 
1808                                            (picnic:error 'eval-picnic-system-decls
1809                                                        "functor declaration is not permitted in nested scope"))
1810                                        (let* ((sym      (string->symbol (->string name)))
1811                                               (functor  (FUNCTOR sym args typ lst)))
1812                                          (if (hash-table-exists? sys sym)
1813                                              (picnic:error 'eval-picnic-system-decls! "functor " sym " already defined"))
1814                                          (hash-table-set! sys sym functor)
1815                                          (list (cons sym qs) scope-subst)))
1816                                       
1817                                       (((or 'const 'CONST) . _)
1818                                        (picnic:error 'eval-picnic-system-decls "declaration: " decl
1819                                                    "constant declarations must be of the form: "
1820                                                    "const id = expr"))
1821                                       
1822                                       ((id '= . _) 
1823                                        (picnic:error 'eval-picnic-system-decls 
1824                                                    "declaration " decl
1825                                                    "algebraic equations must be of the form: "
1826                                                    "id = expr")) 
1827                                       
1828                                       (((or 'reaction 'REACTION) . _)
1829                                        (picnic:error 'eval-picnic-system-decls 
1830                                                    "declaration " decl 
1831                                                    "reaction declarations must be of the form: "
1832                                                    "reaction (id ...)"))
1833                                       
1834                                       (((or 'fun 'FUN 'rel 'REL 'defun 'DEFUN) . _) 
1835                                        (picnic:error 'eval-picnic-system-decls "function declarations must be of the form: "
1836                                                    "fun id (arg1 arg2 ...) expr"))
1837                                       
1838                                       (((or 'prim 'PRIM) . _) 
1839                                        (picnic:error 'eval-picnic-system-decls "prim declarations must be of the form: "
1840                                                    "prim id value"))
1841                                       
1842                                       (((or 'component 'COMPONENT) . _) 
1843                                        (picnic:error 'eval-picnic-system-decls "invalid component: " decl))
1844                                       
1845                                       (((or 'sysname 'SYSNAME) . _) 
1846                                        (picnic:error 'eval-picnic-system-decls "system name must be of the form (sysname name)"))
1847                                       
1848                                       ;; anything that doesn't match is possibly
1849                                       ;; declarations recognized by the picnic extension
1850                                       ;; modules
1851                                       (((and tag (? symbol?))  . lst)
1852                                        (match-let (((typ name alst) 
1853                                                     (let loop ((lst lst) (ax (list tag)))
1854                                                       (if (null? lst)
1855                                                           (list (list (car (reverse ax))) #f (cdr (reverse ax)))
1856                                                           (match lst
1857                                                                  (((? symbol?) . rest) 
1858                                                                   (loop (cdr lst) (cons (car lst) ax) ))
1859                                                                  (((x . rest)) 
1860                                                                   (if (and (symbol? x) (every list? rest))
1861                                                                       (list (reverse ax) x rest)
1862                                                                       (list (reverse ax) #f lst)))
1863                                                                  (else  (list (reverse ax) #f lst)))))))
1864                                                   
1865                                                   (let* ((name (or name (fresh tag)))
1866                                                          (qid  name))
1867                                                     (env-extend! qid  typ (if scope (append alst `((scope ,scope))) alst))
1868                                                     (list (cons qid qs) (update-subst name qid scope-subst)))))
1869
1870                                       (else
1871                                        (picnic:error 'eval-picnic-system-decls 
1872                                                    "declaration " decl ": "
1873                                                    "extended declarations must be of the form: "
1874                                                    "declaration (name (properties ...)"
1875                                                    ))
1876                                       )))
1877                              (loop (cdr ds) qs1 scope scope-subst1))
1878                             ))
1879                       ))
1880                 ))
1881            res
1882            ))
1883)
1884
1885       
Note: See TracBrowser for help on using the repository browser.