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

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

picnic: initial support for composable curves

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