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

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

picnic: use default value for npts argument of processes

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