Changeset 11845 in project
 Timestamp:
 09/01/08 09:54:07 (13 years ago)
 Location:
 release/3/nemo/trunk
 Files:

 3 edited
Legend:
 Unmodified
 Added
 Removed

release/3/nemo/trunk/extensions/nemohh.scm
r11844 r11845 25 25 (requireextension srfi1) 26 26 (requireextension srfi13) 27 (requireextension orucore)27 (requireextension nemocore) 28 28 (requireextension environments) 29 29 … … 42 42 (foreach (lambda (name) 43 43 (if (environmentincludes? env name) 44 ( oru:error 'oru:hhtransformer "quantity " name " in ionic conductance declaration " ion44 (nemo:error 'nemo:hhtransformer "quantity " name " in ionic conductance declaration " ion 45 45 "is already declared elsewhere"))) 46 46 names)) … … 51 51 (foreach (lambda (name) 52 52 (if (not (alistref name alst)) 53 ( oru:error 'oru:hhtransformer "required quantity " name53 (nemo:error 'nemo:hhtransformer "required quantity " name 54 54 " is not present in ionic conductance declaration " ion))) 55 55 names) … … 72 72 73 73 (if (not (and (integer? mpower) (positive? mpower))) 74 ( oru:error 'oru:hhtransformer74 (nemo:error 'nemo:hhtransformer 75 75 "mpower value in ionic conductance declaration " ion 76 76 " must be a positive integer")) … … 88 88 89 89 (if (not (and (integer? hpower) (or (zero? hpower) (positive? mpower)))) 90 ( oru:error 'oru:hhtransformer90 (nemo:error 'nemo:hhtransformer 91 91 "hpower value in ionic conductance declaration " ion 92 92 " must be a positive integer")) … … 133 133 (else (list)))) 134 134 135 (define ( oru:hhtransformer sys . rest)136 (let ((newsys ( oru:envcopy sys)))137 (matchlet ((($ oru:quantity 'DISPATCH dis) (environmentref newsys (oruintern 'dispatch))))135 (define (nemo:hhtransformer sys . rest) 136 (let ((newsys (nemo:envcopy sys))) 137 (matchlet ((($ nemo:quantity 'DISPATCH dis) (environmentref newsys (nemointern 'dispatch)))) 138 138 (let* ((evalconst (dis 'evalconst)) 139 139 (envextend! ((dis 'envextend!) newsys)) 
release/3/nemo/trunk/nemomacros.scm
r11844 r11845 20 20 21 21 (requireextension srfi1) 22 (requireextension orucore)22 (requireextension nemocore) 23 23 (requireextension environments) 24 24 25 25 26 (definemacro ( orubegin sys . body)26 (definemacro (nemobegin sys . body) 27 27 `(begin 28 (if (not (environment? ,sys)) ( oru:error 'orubegin "system argument must be an environment"))29 (let (( oru (match (environmentref ,sys (oruintern 'orucore))30 (($ oru:quantity 'DISPATCH value) value))))28 (if (not (environment? ,sys)) (nemo:error 'nemobegin "system argument must be an environment")) 29 (let ((nemo (match (environmentref ,sys (nemointern 'nemocore)) 30 (($ nemo:quantity 'DISPATCH value) value)))) 31 31 ,@body))) 32 32 33 33 34 (definemacro ( orumodel name declarations . body)34 (definemacro (nemomodel name declarations . body) 35 35 `(begin 36 (let* (( oru (makeorucore))37 (,name (( oru'system) ',name)))38 (eval orusystemdecls oru',name ,name (list ,@(map (lambda (x) (list 'quasiquote x)) declarations)))36 (let* ((nemo (makenemocore)) 37 (,name ((nemo 'system) ',name))) 38 (evalnemosystemdecls nemo ',name ,name (list ,@(map (lambda (x) (list 'quasiquote x)) declarations))) 39 39 ,@body))) 40 40 41 41 42 (definemacro ( orutransform sys declarations)42 (definemacro (nemotransform sys declarations) 43 43 `(begin 44 (if (not (environment? ,sys)) ( oru:error 'orutransform "system argument must be an environment"))45 (let* (( oru (match (environmentref ,sys (oruintern 'dispatch))46 (($ oru:quantity 'DISPATCH value) value)))47 (sys1 ( oru:envcopy ,sys))48 (name (( oru'sysname) sys1)))49 (eval orusystemdecls oruname sys1 (list ,@(map (lambda (x) (list 'quasiquote x)) declarations)))44 (if (not (environment? ,sys)) (nemo:error 'nemotransform "system argument must be an environment")) 45 (let* ((nemo (match (environmentref ,sys (nemointern 'dispatch)) 46 (($ nemo:quantity 'DISPATCH value) value))) 47 (sys1 (nemo:envcopy ,sys)) 48 (name ((nemo 'sysname) sys1))) 49 (evalnemosystemdecls nemo name sys1 (list ,@(map (lambda (x) (list 'quasiquote x)) declarations))) 50 50 sys1))) 
release/3/nemo/trunk/nemo.scm
r11844 r11845 33 33 (include "mathhconstants") 34 34 35 (defineextension orucore)36 37 (declare (export make orucore oru:error oru:warning38 oru:envcopy oruintern oru:quantity?39 eval orusystemdecls35 (defineextension nemocore) 36 37 (declare (export makenemocore nemo:error nemo:warning 38 nemo:envcopy nemointern nemo:quantity? 39 evalnemosystemdecls 40 40 TSCOMP ASGN CONST PRIM)) 41 41 … … 45 45 ; 46 46 47 (define ( oru:warning x . rest)47 (define (nemo:warning x . rest) 48 48 (let loop ((port (openoutputstring)) (objs (cons x rest))) 49 49 (if (null? objs) … … 51 51 (newline port) 52 52 (printerrormessage (getoutputstring port) 53 (currenterrorport) " oruwarning"))53 (currenterrorport) "nemo warning")) 54 54 (begin (display (car objs) port) 55 55 (display " " port) 56 56 (loop port (cdr objs)))))) 57 57 58 (define ( oru:error x . rest)58 (define (nemo:error x . rest) 59 59 (let ((port (openoutputstring))) 60 60 (if (port? x) … … 67 67 (begin 68 68 (newline port) 69 (error ' oru(getoutputstring port)))69 (error 'nemo (getoutputstring port))) 70 70 (let ((obj (car objs))) 71 71 (if (procedure? obj) … … 82 82 (else #f))) 83 83 84 (definedatatype oru:quantity oru:quantity?84 (definedatatype nemo:quantity nemo:quantity? 85 85 (SYSNAME (name symbol?)) 86 86 (ASGN (name symbol?) (value number?) (rhs rhs?) ) … … 97 97 ) 98 98 99 (define ( oruintern sym)99 (define (nemointern sym) 100 100 (string>symbol (stringappend "#" (symbol>string sym)))) 101 101 … … 105 105 (if v (first v) default)))) 106 106 107 (define (make orucore . alst)107 (define (makenemocore . alst) 108 108 109 109 ;; floating point precision (single or double; default is double) … … 228 228 env)) 229 229 230 (define (makeconstenv oruenv)230 (define (makeconstenv nemoenv) 231 231 (let ((env (makebaseenv))) 232 (environmentforeach oruenv232 (environmentforeach nemoenv 233 233 (lambda (sym en) 234 (cond (( oru:quantity? en)235 (cases oru:quantity en234 (cond ((nemo:quantity? en) 235 (cases nemo:quantity en 236 236 (CONST (name value) 237 237 (environmentextend! env name value)) … … 245 245 (let ((env (makebaseenv)) 246 246 (name (if (symbol? name) name (string>symbol name)))) 247 (environmentextend! env ( oruintern 'dispatch) (DISPATCH orudispatch))248 (environmentextend! env ( oruintern 'name) (SYSNAME name))249 (environmentextend! env ( oruintern 'exports) (EXPORTS (list)))247 (environmentextend! env (nemointern 'dispatch) (DISPATCH nemodispatch)) 248 (environmentextend! env (nemointern 'name) (SYSNAME name)) 249 (environmentextend! env (nemointern 'exports) (EXPORTS (list))) 250 250 env)) 251 251 252 (define (addexternal! oruenv)252 (define (addexternal! nemoenv) 253 253 (lambda (sym typ) 254 254 (match typ 255 255 ('output 256 256 (begin 257 (if (not (environmenthasbinding? oruenv sym))258 ( oru:error 'addexternal! ": exported quantity " sym " is not defined"))259 (let* ((exportssym ( oruintern 'exports))260 (exports (environmentref oruenv exportssym)))261 (cases oru:quantity exports262 (EXPORTS (lst) (environmentset! oruenv exportssym (EXPORTS (cons sym lst))))263 (else ( oru:error 'addexternal! ": invalid exports entry " exports))))))257 (if (not (environmenthasbinding? nemoenv sym)) 258 (nemo:error 'addexternal! ": exported quantity " sym " is not defined")) 259 (let* ((exportssym (nemointern 'exports)) 260 (exports (environmentref nemoenv exportssym))) 261 (cases nemo:quantity exports 262 (EXPORTS (lst) (environmentset! nemoenv exportssym (EXPORTS (cons sym lst)))) 263 (else (nemo:error 'addexternal! ": invalid exports entry " exports)))))) 264 264 265 265 (('input sym lsym ns) 266 266 (let ((lsym (or lsym sym))) 267 267 268 (if (environmenthasbinding? oruenv lsym)269 ( oru:error 'addimport! ": import symbol " lsym " is already defined"))268 (if (environmenthasbinding? nemoenv lsym) 269 (nemo:error 'addimport! ": import symbol " lsym " is already defined")) 270 270 271 ((envextend! oruenv) lsym '(external) 'none `(name ,sym) `(namespace ,ns))))271 ((envextend! nemoenv) lsym '(external) 'none `(name ,sym) `(namespace ,ns)))) 272 272 273 273 ))) 274 274 275 (define (envextend! oruenv)275 (define (envextend! nemoenv) 276 276 (lambda (name type initial . alst) 277 277 (let ((sym (if (symbol? name) name (string>symbol name)))) 278 (if (environmenthasbinding? oruenv sym)279 ( oru:error 'envextend! ": quantity " sym " already defined")278 (if (environmenthasbinding? nemoenv sym) 279 (nemo:error 'envextend! ": quantity " sym " already defined") 280 280 (match type 281 281 (('external) (let ((ns (lookupdef 'namespace alst)) 282 282 (externalname (lookupdef 'name alst))) 283 (environmentextend! oruenv sym (EXTERNAL name externalname ns ))))283 (environmentextend! nemoenv sym (EXTERNAL name externalname ns )))) 284 284 285 285 (('prim) (let* ((rhs (lookupdef 'rhs alst)) … … 287 287 (extendprocedure initial rhs) 288 288 initial))) 289 (environmentextend! oruenv sym (PRIM name val ))))289 (environmentextend! nemoenv sym (PRIM name val )))) 290 290 291 291 (('const) (begin 292 292 (if (not (number? initial)) 293 ( oru:error 'envextend! ": constant definitions require numeric value"))294 (environmentextend! oruenv sym (CONST name initial))))293 (nemo:error 'envextend! ": constant definitions require numeric value")) 294 (environmentextend! nemoenv sym (CONST name initial)))) 295 295 296 296 (('tscomp) (let ((power (or (lookupdef 'power alst) 1)) … … 298 298 (open (lookupdef 'open alst))) 299 299 (if (null? transitions) 300 ( oru:error 'envextend!300 (nemo:error 'envextend! 301 301 ": transition state complex definitions require a transition scheme")) 302 302 (if (not open) 303 ( oru:error 'envextend! ": state complex definitions require open state"))303 (nemo:error 'envextend! ": state complex definitions require open state")) 304 304 (if (not (integer? power)) 305 ( oru:error 'envextend!305 (nemo:error 'envextend! 306 306 ": definition for state " sym 307 307 " requires an integer power (" power " was given)")) 308 308 (let ((en (TSCOMP name initial open transitions power))) 309 (environmentextend! oruenv sym en))))309 (environmentextend! nemoenv sym en)))) 310 310 311 311 (('asgn) (let ((rhs (lookupdef 'rhs alst))) 312 312 (if (not (eq? initial 'none)) 313 ( oru:error 'envextend!313 (nemo:error 'envextend! 314 314 ": state function definitions must have initial value of '(none)")) 315 315 (if (not rhs) 316 ( oru:error 'envextend! ": state function definitions require an equation"))317 (environmentextend! oruenv sym (ASGN name 0.0 (normalizeexpr rhs)))))316 (nemo:error 'envextend! ": state function definitions require an equation")) 317 (environmentextend! nemoenv sym (ASGN name 0.0 (normalizeexpr rhs))))) 318 318 319 319 (else (begin 320 (environmentextend! oruenv sym `(,type (name ,sym) . ,initial))))320 (environmentextend! nemoenv sym `(,type (name ,sym) . ,initial)))) 321 321 ))))) 322 322 323 (define (infer oruenv ftenv body)323 (define (infer nemoenv ftenv body) 324 324 (let recur ((expr body) (lb (list))) 325 325 (match expr … … 331 331 (begin 332 332 (if (not (equal? ct 'bool)) 333 ( oru:error 'infer "if condition type must be boolean"))333 (nemo:error 'infer "if condition type must be boolean")) 334 334 (if (equal? tt et) tt 335 ( oru:error 'infer "type mismatch in if statement: then = " tt335 (nemo:error 'infer "type mismatch in if statement: then = " tt 336 336 " else = " et)))))) 337 337 (('let bs e) … … 342 342 343 343 ((s . es) 344 (let* ((f (environmentref oruenv s))344 (let* ((f (environmentref nemoenv s)) 345 345 (lst (proceduredata f))) 346 346 (and lst … … 366 366 367 367 368 (define (defun! oruenv)368 (define (defun! nemoenv) 369 369 (lambda (name formals body) 370 (let ((constenv (makeconstenv oruenv))370 (let ((constenv (makeconstenv nemoenv)) 371 371 (sym (if (symbol? name) name (string>symbol name)))) 372 372 (letrec ((enumconsts … … 381 381 (environmentincludes? constenv s)) 382 382 (cons s ax) ax))))))) 383 (if (environmenthasbinding? oruenv sym)384 ( oru:error 'defun! ": quantity " sym " already defined")383 (if (environmenthasbinding? nemoenv sym) 384 (nemo:error 'defun! ": quantity " sym " already defined") 385 385 (let* ((body (normalizeexpr body)) 386 386 (consts (deleteduplicates ((enumconsts formals) body (list)))) … … 391 391 392 392 (let* ((ftenv (makeenvironment)) 393 (rt (infer oruenv ftenv body))393 (rt (infer nemoenv ftenv body)) 394 394 (ftypes (filtermap (lambda (x) (and (environmentincludes? ftenv x) 395 395 (environmentref ftenv x))) … … 397 397 (ef (extendprocedure f `((rt ,rt) (formals ,ftypes) (vars ,formals) 398 398 (body ,body) (consts ,consts))))) 399 (environmentextend! oruenv sym ef))))))))399 (environmentextend! nemoenv sym ef)))))))) 400 400 401 401 (define (symbollist? lst) 402 402 (and (list? lst) (every symbol? lst))) 403 403 404 (define (extended oruenv)404 (define (extended nemoenv) 405 405 (filtermap (lambda (sym) 406 (let ((x (environmentref oruenv sym)))407 (and (not ( oru:quantity? x)) (not (procedure? x))406 (let ((x (environmentref nemoenv sym))) 407 (and (not (nemo:quantity? x)) (not (procedure? x)) 408 408 (match x 409 409 (((? symbollist?) ('name name) . rest) `(,sym ,x)) 410 410 (else #f))))) 411 (environmentsymbols oruenv)))411 (environmentsymbols nemoenv))) 412 412 413 413 414 (define (extendedwithtag oruenv tag)414 (define (extendedwithtag nemoenv tag) 415 415 (filtermap (lambda (sym) 416 (let ((x (environmentref oruenv sym)))417 (and (not ( oru:quantity? x)) (not (procedure? x))416 (let ((x (environmentref nemoenv sym))) 417 (and (not (nemo:quantity? x)) (not (procedure? x)) 418 418 (match x 419 419 (((? (lambda (x) (equal? x tag))) ('name name) . rest) 420 420 `(,sym ,x)) 421 421 (else #f))))) 422 (environmentsymbols oruenv)))422 (environmentsymbols nemoenv))) 423 423 424 424 425 (define (components oruenv)425 (define (components nemoenv) 426 426 (filtermap (lambda (sym) 427 (let ((x (environmentref oruenv sym)))428 (and ( oru:quantity? x)429 (cases oru:quantity x427 (let ((x (environmentref nemoenv sym))) 428 (and (nemo:quantity? x) 429 (cases nemo:quantity x 430 430 (COMPONENT (type lst) `(,type ,sym)) 431 431 (else #f))))) 432 (environmentsymbols oruenv)))433 434 435 (define (componentsymbols oruenv sym)436 (let ((x (environmentref oruenv sym)))437 (and ( oru:quantity? x)438 (cases oru:quantity x432 (environmentsymbols nemoenv))) 433 434 435 (define (componentsymbols nemoenv sym) 436 (let ((x (environmentref nemoenv sym))) 437 (and (nemo:quantity? x) 438 (cases nemo:quantity x 439 439 (COMPONENT (type lst) lst) 440 440 (else #f))))) 441 441 442 442 443 (define (componentexports oruenv sym)444 (let ((allexports (cases oru:quantity (environmentref oruenv (oruintern 'exports))443 (define (componentexports nemoenv sym) 444 (let ((allexports (cases nemo:quantity (environmentref nemoenv (nemointern 'exports)) 445 445 (EXPORTS (lst) lst)))) 446 (let ((x (environmentref oruenv sym)))447 (and ( oru:quantity? x)448 (cases oru:quantity x446 (let ((x (environmentref nemoenv sym))) 447 (and (nemo:quantity? x) 448 (cases nemo:quantity x 449 449 (COMPONENT (type lst) 450 450 (filtermap (lambda (x) ((lambda (x) (and x (car x))) (member x allexports))) lst)) 451 451 (else #f)))))) 452 452 453 (define (componentsubcomps oruenv sym)453 (define (componentsubcomps nemoenv sym) 454 454 (define (componenttype x) 455 (cases oru:quantity x455 (cases nemo:quantity x 456 456 (COMPONENT (type lst) type) 457 457 (else #f))) 458 (let ((x (environmentref oruenv sym)))459 (and ( oru:quantity? x)460 (cases oru:quantity x458 (let ((x (environmentref nemoenv sym))) 459 (and (nemo:quantity? x) 460 (cases nemo:quantity x 461 461 (COMPONENT (type lst) 462 (filtermap (lambda (s) (let ((x (environmentref oruenv s)))462 (filtermap (lambda (s) (let ((x (environmentref nemoenv s))) 463 463 (and (iscomp? x) `(,(componenttype x) ,s)))) lst)) 464 464 (else #f))))) 465 465 466 (define (componentextend! oruenv)466 (define (componentextend! nemoenv) 467 467 (lambda (comp sym) 468 (let ((x (environmentref oruenv comp)))469 (if ( oru:quantity? x)470 (cases oru:quantity x468 (let ((x (environmentref nemoenv comp))) 469 (if (nemo:quantity? x) 470 (cases nemo:quantity x 471 471 (COMPONENT (type lst) 472 472 (let ((en1 (COMPONENT type (cons sym lst)))) 473 (environmentset! oruenv comp en1)))474 (else ( oru:error 'componentextend! ": invalid component " comp)))475 ( oru:error 'componentextend! ": invalid component " comp)))))476 477 478 (define (exports oruenv)479 (cases oru:quantity (environmentref oruenv (oruintern 'exports))473 (environmentset! nemoenv comp en1))) 474 (else (nemo:error 'componentextend! ": invalid component " comp))) 475 (nemo:error 'componentextend! ": invalid component " comp))))) 476 477 478 (define (exports nemoenv) 479 (cases nemo:quantity (environmentref nemoenv (nemointern 'exports)) 480 480 (EXPORTS (lst) lst))) 481 481 482 482 483 (define (imports oruenv)483 (define (imports nemoenv) 484 484 (filtermap (lambda (sym) 485 (let ((x (environmentref oruenv sym)))486 (and ( oru:quantity? x)487 (cases oru:quantity x485 (let ((x (environmentref nemoenv sym))) 486 (and (nemo:quantity? x) 487 (cases nemo:quantity x 488 488 (EXTERNAL (localname name namespace) (list localname name namespace)) 489 489 (else #f))))) 490 (environmentsymbols oruenv)))491 492 493 (define (consts oruenv)490 (environmentsymbols nemoenv))) 491 492 493 (define (consts nemoenv) 494 494 (filtermap (lambda (sym) 495 (let ((x (environmentref oruenv sym)))496 (and ( oru:quantity? x)497 (cases oru:quantity x495 (let ((x (environmentref nemoenv sym))) 496 (and (nemo:quantity? x) 497 (cases nemo:quantity x 498 498 (CONST (name value) (list name value) ) 499 499 (else #f))))) 500 (environmentsymbols oruenv)))501 502 503 (define (states oruenv)500 (environmentsymbols nemoenv))) 501 502 503 (define (states nemoenv) 504 504 (fold (lambda (sym ax) 505 (let ((x (environmentref oruenv sym)))506 (if ( oru:quantity? x)507 (cases oru:quantity x505 (let ((x (environmentref nemoenv sym))) 506 (if (nemo:quantity? x) 507 (cases nemo:quantity x 508 508 (TSCOMP (name initial open transitions power) 509 509 (let ((ss (deleteduplicates (append (map second transitions) … … 512 512 (else ax)) 513 513 ax))) 514 (list) (environmentsymbols oruenv)))515 516 517 (define (stcomps oruenv)514 (list) (environmentsymbols nemoenv))) 515 516 517 (define (stcomps nemoenv) 518 518 (fold (lambda (sym ax) 519 (let ((x (environmentref oruenv sym)))520 (if ( oru:quantity? x)521 (cases oru:quantity x519 (let ((x (environmentref nemoenv sym))) 520 (if (nemo:quantity? x) 521 (cases nemo:quantity x 522 522 (TSCOMP (name initial open transitions power) 523 523 (cons name ax)) 524 524 (else ax)) 525 525 ax))) 526 (list) (environmentsymbols oruenv)))527 528 529 (define (asgns oruenv)526 (list) (environmentsymbols nemoenv))) 527 528 529 (define (asgns nemoenv) 530 530 (filtermap (lambda (sym) 531 (let ((x (environmentref oruenv sym)))532 (and ( oru:quantity? x)533 (cases oru:quantity x531 (let ((x (environmentref nemoenv sym))) 532 (and (nemo:quantity? x) 533 (cases nemo:quantity x 534 534 (ASGN (name value rhs) name) 535 535 (else #f))))) 536 (environmentsymbols oruenv)))537 538 539 (define (defuns oruenv)536 (environmentsymbols nemoenv))) 537 538 539 (define (defuns nemoenv) 540 540 (filtermap (lambda (sym) 541 (let ((x (environmentref oruenv sym)))541 (let ((x (environmentref nemoenv sym))) 542 542 (and (procedure? x) (not (member sym builtinfns)) (list sym x)))) 543 (environmentsymbols oruenv)))543 (environmentsymbols nemoenv))) 544 544 545 545 546 546 547 (define (exam oruenv)547 (define (exam nemoenv) 548 548 (lambda (name) 549 549 (let ((sym (if (symbol? name) name (string>symbol name))) 550 550 (out (currentoutputport))) 551 (if (not (environmenthasbinding? oruenv sym))552 ( oru:error 'exam ": quantity " sym " is not defined")553 (let ((x (environmentref oruenv sym)))554 (cases oru:quantity x551 (if (not (environmenthasbinding? nemoenv sym)) 552 (nemo:error 'exam ": quantity " sym " is not defined") 553 (let ((x (environmentref nemoenv sym))) 554 (cases nemo:quantity x 555 555 (PRIM (name value) 556 556 (begin 557 (fprintf out "~a: compiled c oruprimitive\n" name)557 (fprintf out "~a: compiled cnemo primitive\n" name) 558 558 (fprintf out " value: ~a\n" value))) 559 559 … … 573 573 (fprintf out " value: ~a\n" value))) 574 574 575 (else ( oru:error 'exam name ": unknown type of quantity"))))))))575 (else (nemo:error 'exam name ": unknown type of quantity")))))))) 576 576 577 577 578 (define (evalconst oruenv expr)578 (define (evalconst nemoenv expr) 579 579 (let ((expr1 (normalizeexpr expr))) 580 (exact>inexact (eval expr1 (makeconstenv oruenv)))))580 (exact>inexact (eval expr1 (makeconstenv nemoenv))))) 581 581 582 582 583 583 (define (iscomp? x) 584 (cond (( oru:quantity? x)585 (cases oru:quantity x584 (cond ((nemo:quantity? x) 585 (cases nemo:quantity x 586 586 (COMPONENT (type lst) #t) 587 587 (else #f))) … … 589 589 590 590 (define (isdep? x) 591 (cond (( oru:quantity? x)592 (cases oru:quantity x591 (cond ((nemo:quantity? x) 592 (cases nemo:quantity x 593 593 (ASGN (name value rhs) #t) 594 594 (else #f))) … … 598 598 599 599 (define (isstate? x) 600 (and ( oru:quantity? x)601 (cases oru:quantity x600 (and (nemo:quantity? x) 601 (cases nemo:quantity x 602 602 (TSCOMP (name initial open transitions) #t) 603 603 (else #f)))) … … 605 605 606 606 (define (qrhs x) 607 (and ( oru:quantity? x)608 (cases oru:quantity x607 (and (nemo:quantity? x) 608 (cases nemo:quantity x 609 609 (TSCOMP (name initial open transitions) 610 610 (begin … … 614 614 615 615 616 (define (sysname oruenv)617 (cases oru:quantity (environmentref oruenv (oruintern 'name))616 (define (sysname nemoenv) 617 (cases nemo:quantity (environmentref nemoenv (nemointern 'name)) 618 618 (SYSNAME (name) name))) 619 619 620 620 621 621 ;; create equation dependency graph 622 (define (makeeqng oruenv)623 (let* ((sysname (sysname oruenv))622 (define (makeeqng nemoenv) 623 (let* ((sysname (sysname nemoenv)) 624 624 (g (makedigraph sysname (stringappend (symbol>string sysname) 625 625 " equation dependency graph"))) 626 626 (addnode! (g 'addnode!)) 627 627 (addedge! (g 'addedge!)) 628 ( orulist (filter (lambda (sym) (let ((x (environmentref oruenv sym)))628 (nemolist (filter (lambda (sym) (let ((x (environmentref nemoenv sym))) 629 629 (or (isstate? x) (isdep? x)))) 630 (environmentsymbols oruenv)))631 ( oruids (listtabulate (length orulist) identity))632 (name>idmap (zip orulist oruids)))630 (environmentsymbols nemoenv))) 631 (nemoids (listtabulate (length nemolist) identity)) 632 (name>idmap (zip nemolist nemoids))) 633 633 (letvalues (((statelist asgnlist) 634 (partition (lambda (sym) (isstate? (environmentref oruenv sym)))635 orulist)))634 (partition (lambda (sym) (isstate? (environmentref nemoenv sym))) 635 nemolist))) 636 636 637 637 ;; insert equations in the dependency graph 638 (foreach (lambda (i n) (addnode! i n)) oruids orulist)638 (foreach (lambda (i n) (addnode! i n)) nemoids nemolist) 639 639 ;; create dependency edges in the graph 640 640 (foreach (lambda (e) … … 643 643 (j (car (alistref nj name>idmap)))) 644 644 (addedge! (list i j (format "~A=>~A" ni nj)))))) 645 (else ( oru:error 'makeeqng ": invalid edge " e))))645 (else (nemo:error 'makeeqng ": invalid edge " e)))) 646 646 (fold (lambda (qsym ax) 647 (let* ((q (environmentref oruenv qsym))647 (let* ((q (environmentref nemoenv qsym)) 648 648 (rhs (qrhs q))) 649 649 (if rhs 650 650 (let* ((deps (filter (if (isstate? q) 651 651 (lambda (sym) 652 (and (let ((x (environmentref oruenv sym)))652 (and (let ((x (environmentref nemoenv sym))) 653 653 (and (isdep? x) (not (eq? sym qsym)))))) 654 654 (lambda (sym) 655 (and (let ((x (environmentref oruenv sym)))655 (and (let ((x (environmentref nemoenv sym))) 656 656 (isdep? x))))) 657 657 (enumdeps rhs))) … … 659 659 (if edges (append edges ax) ax)) 660 660 ax))) 661 (list) orulist))661 (list) nemolist)) 662 662 (let ((cycles (graphcyclesfold g (lambda (cycle ax) (cons cycle ax)) (list)))) 663 663 (if (null? cycles) (list statelist asgnlist g) 664 ( oru:error 'makeeqng ": equation cycle detected: " (car cycles)))))))664 (nemo:error 'makeeqng ": equation cycle detected: " (car cycles))))))) 665 665 666 666 … … 681 681 682 682 683 (define (makeevalposet oruenv eqposet)683 (define (makeevalposet nemoenv eqposet) 684 684 (vectormap 685 685 (lambda (i lst) 686 686 (filtermap (lambda (id+sym) 687 687 (let* ((sym (cdr id+sym)) 688 (x (environmentref oruenv sym)))689 (and ( oru:quantity? x)690 (cases oru:quantity x688 (x (environmentref nemoenv sym))) 689 (and (nemo:quantity? x) 690 (cases nemo:quantity x 691 691 (TSCOMP (name initial open transitions) 692 692 (let ((rs (map cadddr transitions))) … … 694 694 (ASGN (name value rhs) 695 695 (list 'a sym rhs)) 696 (else oru:error 'makeevalposet696 (else nemo:error 'makeevalposet 697 697 ": invalid quantity in equation poset: " sym))))) 698 698 lst)) … … 707 707 (if (ee c) (ee t) (ee f)) 708 708 [var () 709 ( oru:error 'evalexpr " exception in " expr ": \n"709 (nemo:error 'evalexpr " exception in " expr ": \n" 710 710 (lambda () (printerrormessage var)))]))) 711 711 … … 716 716 (apply op args)) 717 717 [var () 718 ( oru:error 'evalexpr " exception in " expr ": \n"718 (nemo:error 'evalexpr " exception in " expr ": \n" 719 719 (lambda () (printerrormessage var)))])) 720 720 … … 722 722 (cond ((symbol? s) (environmentref env s)) 723 723 ((number? s) s) 724 (else ( oru:error 'evalexpr "unknown expression " s)))))))724 (else (nemo:error 'evalexpr "unknown expression " s))))))) 725 725 val))) 726 726 727 727 728 (define (depgraph oruenv)729 (matchlet (((statelist asgnlist g) (makeeqng oruenv))) g))730 731 (define (depgraph* oruenv)732 (matchlet (((statelist asgnlist g) (makeeqng oruenv)))728 (define (depgraph nemoenv) 729 (matchlet (((statelist asgnlist g) (makeeqng nemoenv))) g)) 730 731 (define (depgraph* nemoenv) 732 (matchlet (((statelist asgnlist g) (makeeqng nemoenv))) 733 733 (list statelist asgnlist g))) 734 734 735 735 736 736 ;; Dispatcher 737 (define ( orudispatch selector)737 (define (nemodispatch selector) 738 738 (case selector 739 739 ((addexternal!) addexternal!) … … 763 763 ((extendedwithtag) extendedwithtag) 764 764 (else 765 ( oru:error 'selector ": unknown message " selector " sent to an orucore object"))))766 767 orudispatch)768 769 (define oru:envcopy environmentcopy)765 (nemo:error 'selector ": unknown message " selector " sent to an nemocore object")))) 766 767 nemodispatch) 768 769 (define nemo:envcopy environmentcopy) 770 770 771 771 (define qcounter 0) … … 776 776 (string>symbol (stringappend (>string prefix) (number>string v))))) 777 777 778 (define (eval orusystemdecls orucore name sys declarations)779 (define (evalconst x) (and x (( orucore 'evalconst) sys x)))778 (define (evalnemosystemdecls nemocore name sys declarations) 779 (define (evalconst x) (and x ((nemocore 'evalconst) sys x))) 780 780 (let loop ((ds declarations) (qs (list))) 781 781 (if (null? ds) qs … … 788 788 (match x 789 789 ((? symbol?) 790 ((( orucore 'addexternal!) sys) x `(input ,x ,x #f))790 (((nemocore 'addexternal!) sys) x `(input ,x ,x #f)) 791 791 (cons x ax)) 792 792 ((id1 'as x1) 793 ((( orucore 'addexternal!) sys) x `(input ,id1 ,x1 #f))793 (((nemocore 'addexternal!) sys) x `(input ,id1 ,x1 #f)) 794 794 (cons x1 ax)) 795 795 ((id1 'from n1) 796 ((( orucore 'addexternal!) sys) x `(input ,id1 ,id1 ,n1))796 (((nemocore 'addexternal!) sys) x `(input ,id1 ,id1 ,n1)) 797 797 (cons id1 ax)) 798 798 ((id1 'as x1 'from n1) 799 ((( orucore 'addexternal!) sys) x `(input ,id1 ,x1 ,n1))799 (((nemocore 'addexternal!) sys) x `(input ,id1 ,x1 ,n1)) 800 800 (cons x1 ax)) 801 801 )) 802 802 qs lst)) 803 (else ( oru:error 'evalorusystemdecls803 (else (nemo:error 'evalnemosystemdecls 804 804 "import statement must be of the form: " 805 805 "input id1 [as x1] ... ")))) … … 808 808 (('output . lst) 809 809 (cond ((every symbol? lst) 810 (foreach (lambda (x) ((( orucore 'addexternal!) sys) x 'output)) lst)810 (foreach (lambda (x) (((nemocore 'addexternal!) sys) x 'output)) lst) 811 811 qs) 812 (else ( oru:error 'evalorusystemdecls812 (else (nemo:error 'evalnemosystemdecls 813 813 "export statement must be of the form: " 814 814 "output id1 ... ")))) … … 818 818 (cond ((and (symbol? id) (or (number? expr) (list? expr))) 819 819 (let ((val (evalconst expr))) 820 ((( orucore 'envextend!) sys) id '(const) val)820 (((nemocore 'envextend!) sys) id '(const) val) 821 821 (cons id qs))) 822 (else ( oru:error 'evalorusystemdecls822 (else (nemo:error 'evalnemosystemdecls 823 823 "constant declarations must be of the form: " 824 824 "const id = expr")))) … … 829 829 (let ((initial (evalconst (lookupdef 'initial alst))) 830 830 (power (evalconst (lookupdef 'power alst)))) 831 (apply (( orucore 'envextend!) sys)831 (apply ((nemocore 'envextend!) sys) 832 832 (cons* id '(tscomp) initial `(power ,power) alst))) 833 833 (cons id qs)) 834 (else ( oru:error 'evalorusystemdecls834 (else (nemo:error 'evalnemosystemdecls 835 835 "state complex declarations must be of the form: " 836 836 "statecomplex (id ...)")))) … … 839 839 ((id '= expr) 840 840 (cond ((and (symbol? id) (or (symbol? expr) (number? expr) (list? expr))) 841 ((( orucore 'envextend!) sys) id '(asgn) 'none `(rhs ,expr))841 (((nemocore 'envextend!) sys) id '(asgn) 'none `(rhs ,expr)) 842 842 (cons id qs)) 843 (else ( oru:error 'evalorusystemdecls843 (else (nemo:error 'evalnemosystemdecls 844 844 "algebraic declarations must be of the form: " 845 845 "id = expr")))) … … 848 848 (('defun id idlist expr) 849 849 (cond ((and (symbol? id) (list? idlist) (every symbol? idlist) (list? expr)) 850 ((( orucore 'defun!) sys) id idlist expr)850 (((nemocore 'defun!) sys) id idlist expr) 851 851 (cons id qs)) 852 (else ( oru:error 'evalorusystemdecls852 (else (nemo:error 'evalnemosystemdecls 853 853 "function declarations must be of the form: " 854 854 "defun id (arg1 arg2 ...) expr")))) 855 855 856 ;; compiled c oruprimitives856 ;; compiled cnemo primitives 857 857 (('prim id value) 858 (cond ((symbol? id) ((( orucore 'envextend!) sys) id '(prim) value))859 (else ( oru:error 'evalorusystemdecls858 (cond ((symbol? id) (((nemocore 'envextend!) sys) id '(prim) value)) 859 (else (nemo:error 'evalnemosystemdecls 860 860 "prim declarations must be of the form: " 861 861 "prim id value")))) … … 878 878 879 879 (('sysname name) (if (symbol? name) 880 (environmentset! sys ( oruintern 'name) (SYSNAME name))881 ( oru:error 'evalorusystemdecls880 (environmentset! sys (nemointern 'name) (SYSNAME name)) 881 (nemo:error 'evalnemosystemdecls 882 882 "system name must be a symbol"))) 883 883 884 884 (('const . _) 885 ( oru:error 'evalorusystemdecls "constant declarations must be of the form: "885 (nemo:error 'evalnemosystemdecls "constant declarations must be of the form: " 886 886 "const id = expr")) 887 887 888 888 ((id '= . _) 889 ( oru:error 'evalorusystemdecls "algebraic equations must be of the form: "889 (nemo:error 'evalnemosystemdecls "algebraic equations must be of the form: " 890 890 "id = expr")) 891 891 892 892 (('statecomplex . _) 893 ( oru:error 'evalorusystemdecls893 (nemo:error 'evalnemosystemdecls 894 894 "state complex declarations must be of the form: " 895 895 "statecomplex (id ...)")) 896 896 897 897 (('defun . _) 898 ( oru:error 'evalorusystemdecls "function declarations must be of the form: "898 (nemo:error 'evalnemosystemdecls "function declarations must be of the form: " 899 899 "defun id (arg1 arg2 ...) expr")) 900 900 901 901 (('prim . _) 902 ( oru:error 'evalorusystemdecls "prim declarations must be of the form: "902 (nemo:error 'evalnemosystemdecls "prim declarations must be of the form: " 903 903 "prim id value")) 904 904 905 905 (('component . _) 906 ( oru:error 'evalorusystemdecls "invalid component: " decl))906 (nemo:error 'evalnemosystemdecls "invalid component: " decl)) 907 907 908 908 (('sysname . _) 909 ( oru:error 'evalorusystemdecls "system name must be of the form (sysname name)"))909 (nemo:error 'evalnemosystemdecls "system name must be of the form (sysname name)")) 910 910 911 911 ;; anything that doesn't match is possibly 912 ;; declarations recognized by the oruextension912 ;; declarations recognized by the nemo extension 913 913 ;; modules 914 914 ((tag . lst) … … 927 927 (else (list (reverse ax) #f lst))))))) 928 928 (let ((name (or name (qname tag)))) 929 ((( orucore 'envextend!) sys) name typ alst)929 (((nemocore 'envextend!) sys) name typ alst) 930 930 (cons name qs))) 931 ( oru:error 'evalorusystemdecls "extended declarations must be of the form: "931 (nemo:error 'evalnemosystemdecls "extended declarations must be of the form: " 932 932 "declaration (name (properties ...)")))))) 933 933
Note: See TracChangeset
for help on using the changeset viewer.