;;
;; NineML algebraic system code generator for MLton.
;;
;;
;; Copyright 2010-2015 Ivan Raikov
;;
;; This program is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; A full copy of the GPL license can be found at
;; .
;;
(module 9ML-alsys-mlton
(alsys-mlton-codegen
mlton-initial mlton-state-update
mlton-value
)
(import scheme chicken )
(import (only files make-pathname pathname-directory pathname-file)
(only extras sprintf)
(only data-structures conc alist-ref intersperse)
(only srfi-13 string-concatenate)
(only srfi-1 delete-duplicates))
(require-extension make datatype setup-api salt)
(define nl "\n")
;; based on SRV:send-reply by Oleg Kiselyov
(define (print-fragments b #!key (out (current-output-port)))
(let loop ((fragments b) (result #f))
(cond
((null? fragments) result)
((not (car fragments)) (loop (cdr fragments) result))
((null? (car fragments)) (loop (cdr fragments) result))
((eq? #t (car fragments)) (loop (cdr fragments) #t))
((pair? (car fragments))
(loop (cdr fragments) (loop (car fragments) result)))
((procedure? (car fragments))
((car fragments))
(loop (cdr fragments) #t))
(else
(display (car fragments) out)
(loop (cdr fragments) #t)))))
(define (mlton-value v)
(cond
((pair? v)
(case (car v)
((realsig) (mlton-value (caddr v)))
((realconst) (mlton-value (cadr v)))
((random) (sprintf "~A ()" (cadr v)))
((neg) (sprintf "Real.~A (~A)" "~" (mlton-value (cadr v))))
((+ - * / >= <= > <)
(sprintf "Real.~A (~A, ~A)"
(car v) (mlton-value (cadr v))
(mlton-value (caddr v))))
((log ln sin cos cosh tanh exp)
(sprintf "Math.~A (~A)"
(car v) (mlton-value (cadr v)) ))
(else (error 'mlton-value "invalid value" v))))
((and (number? v) (negative? v)) (string-append "~" (sprintf "~A" (abs v))))
((boolean? v) (if v "true" "false"))
(else (sprintf "~A" v))))
(define (mlton-initial ic #!key (update '()))
(let ((ic (map (lambda (x)
(let ((n (car x)) (v (cdr x)))
(if (assoc n update)
(cons n (mlton-value (alist-ref n update)))
(cons n (mlton-value v))
)
))
ic)))
(string-append "{" (string-concatenate (intersperse (map (lambda (x) (sprintf "~A=(~A)" (car x) (cdr x))) ic) ",")) "}")
))
(define (mlton-state-update vars #!key (input "input") (field-input "fieldinput") (nstate "nstate")
(update '()) (states '()) (fields '()))
(let* (
(f (lambda (n) (if (assoc n update)
(sprintf "~A=~A" n (alist-ref n update))
(sprintf "~A=(#~A(~A))" n n
(cond ((member n states) nstate)
((member n fields) field-input)
(else input)))
)))
(nstate1 (string-append "{" (string-concatenate (intersperse (map f vars) ",")) "}"))
)
nstate1
))
(define mlton-run-prelude
#<