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

Last change on this file since 31066 was 31066, checked in by Ivan Raikov, 6 years ago

picnic: modifications to polynomial sampling of curves

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