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

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

picnic: some refactoring of population import mechanisms

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