source: project/release/4/npccl/trunk/npccl-core.scm @ 30536

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

initial import of npccl, the Neural Parametric Curve Connectivity Language

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