<> <> <> <> <<>> <> <> < this is a line of Cedar code>> < this is a line of Scheme code>> <<>> <> <<% MixMaster MixMaster>> <> <<>> <> <<(cedar-imports . strings)>> <> <<(cedar-directory . strings)>> <> <<(cedar-require . strings)>> <> <<(release-as world component)>> <> <<(define-ref-type module-name-string type-name-string)>> <> <<(define-rep-type module-name-string type-name-string)>> <> <<(define-enum-type module-name-string type-name-string symbol-list)>> <> <<(define-proc (procname . args) doc-string . cedar-code)>> <> <<(cedar cedar-code-string)>> <> <<(primitive-enable . cedar-code)>> <> <<>> <<>> <> (cedar-imports "Ascii" "Atom" "EditSpan" "FS" "IO" "PFS" "TiogaIO" "RefText" "Rope" "Scheme" "TextEdit" "TextNode") ROPE: TYPE ~ Rope.ROPE; ThePath: PROC [any: Any] RETURNS [PFS.PATH] ~ {RETURN[PFS.PathFromRope[RopeFromString[TheString[any]]]]}; (primitive-enable PFS.Error => { IF error.group = user THEN Complain[error.code, error.explanation]; }; ) <<>> (release-as "Cedar" "MixMaster") (define-ref-type "TextEdit" "RefTextNode") (define-ref-type "Scheme" "Symbol") (define-proc (file-list pattern-string) "return a list of file name strings matching pattern-string" head: Pair ~ Cons[NIL, NIL]; last: Pair _ head; EachName: FS.NameProc = { new: Pair ~ Cons[StringFromRope[fullFName], NIL]; last.cdr _ new; last _ new; RETURN [TRUE] }; FS.EnumerateForNames[pattern: RopeFromString[TheString[patternString]], proc: EachName, wDir: NIL]; result _ head.cdr; head.cdr _ NIL; last _ NIL; ) (define-proc (file-delete filename-string) "delete a file" FS.Delete[name: RopeFromString[TheString[filenameString]]]; ) (define-proc (filename-base filename-string) "return the base of the filename" fullFName: ROPE; cp: FS.ComponentPositions; dirOmitted: BOOL; [fullFName: fullFName, cp: cp, dirOmitted: dirOmitted] _ FS.ExpandName[RopeFromString[TheString[filenameString]]]; result _ StringFromRope[Rope.Substr[fullFName, cp.base.start, cp.base.length]]; ) (define-proc (filename-ext filename-string) "return the extension of the filename, or #f if not present" fullFName: ROPE; cp: FS.ComponentPositions; dirOmitted: BOOL; [fullFName: fullFName, cp: cp, dirOmitted: dirOmitted] _ FS.ExpandName[RopeFromString[TheString[filenameString]]]; result _ IF cp.ext.length = 0 AND cp.ext.start = cp.base.start+cp.base.length THEN false ELSE StringFromRope[Rope.Substr[fullFName, cp.ext.start, cp.ext.length]]; ) (define-proc (tioga-file-read filename-string) "Read a Tioga document" result _ TiogaIO.FromFile[fileName: ThePath[filenameString]].root; ) (define-proc (tioga-file-write filename-string tioga-node) "Write a Tioga document" result _ MakeFixnum[TiogaIO.ToFile[fileName: ThePath[filenameString], root: TextNode.Root[TheRefTextNode[tiogaNode]]].dataLen]; ) (define-proc (tioga->string tioga-root) "Makes a string of the content portion of a Tioga document" s: IO.STREAM ~ IO.ROS[]; TiogaIO.PutDoc[s, IO.noWhereStream, IO.noWhereStream, TextNode.Root[TheRefTextNode[tiogaRoot]]]; result _ StringFromRope[IO.RopeFromROS[s]]; ) <<(define-proc (tioga-destroy! tioga-node)>> <<"Destroy a Tioga document (break circular structures)">> <> <<)>> <<>> (define-proc (tioga-forward tioga-node) "Return the next Tioga node in the document, or #f" next: TextNode.Ref = TextNode.StepForward[node: TheRefTextNode[tiogaNode]]; result _ IF next = NIL THEN false ELSE next; ) (define-proc (tioga-sibling tioga-node) "Return the next sibling node or #f" next: TextNode.Ref = TextNode.Next[TheRefTextNode[tiogaNode]]; result _ IF next = NIL THEN false ELSE next; ) (define-proc (tioga-child tioga-node) "Return the first child node or #f" child: TextNode.Ref = TextNode.FirstChild[TheRefTextNode[tiogaNode]]; result _ IF child = NIL THEN false ELSE child; ) (define-proc (tioga-root tioga-node) "Return the root node of a Tioga document" result _ TextNode.Root[TheRefTextNode[tiogaNode]]; ) (define-proc (tioga-create-doc (pattern-root-node)) "Make a new Tioga document" content: TextNode.Ref _ TextEdit.FromRope[""]; new: TextNode.Ref _ TextEdit.DocFromNode[content]; IF patternRootNode # undefined THEN EditSpan.Inherit[old: TheRefTextNode[patternRootNode], new: new, allprops: TRUE]; result _ content; ) (define-proc (tioga-copy-branch! dest-node source-node) "copy a branch to a new place (returns copied branch)" dstNode: TextNode.Ref = TheRefTextNode[destNode]; srcNode: TextNode.Ref = TheRefTextNode[sourceNode]; src: TextNode.Span = TextNode.MakeNodeSpan[first: srcNode, last: TextNode.LastWithin[srcNode]]; copy: TextNode.Span = EditSpan.Copy[destRoot: TextNode.Root[dstNode], sourceRoot: TextNode.Root[srcNode], dest: TextNode.MakeNodeLoc[dstNode], source: src, where: sibling, nesting: 0]; result _ copy.start.node; ) (define-proc (tioga-copy-node! dest-node source-node) "copy a node to a new place (returns copied node)" dstNode: TextNode.Ref = TheRefTextNode[destNode]; srcNode: TextNode.Ref = TheRefTextNode[sourceNode]; src: TextNode.Span = TextNode.MakeNodeSpan[first: srcNode, last: srcNode]; copy: TextNode.Span = EditSpan.Copy[destRoot: TextNode.Root[dstNode], sourceRoot: TextNode.Root[srcNode], dest: TextNode.MakeNodeLoc[dstNode], source: src, where: sibling, nesting: 0]; result _ copy.start.node; ) (define-proc (tioga-insert-text-as-child! dest-node string format) "insert a new Tioga node as a child" dstNode: TextNode.Ref = TheRefTextNode[destNode]; srcNode: TextNode.Ref = TextEdit.FromRope[RopeFromString[TheString[string]]]; srcRoot: TextNode.Ref = TextEdit.DocFromNode[srcNode]; copy: TextNode.Span = EditSpan.Copy[destRoot: TextNode.Root[dstNode], sourceRoot: srcRoot, dest: TextNode.MakeNodeLoc[dstNode], source: TextNode.MakeNodeSpan[first: srcNode, last: srcNode], where: child, nesting: 1]; <> IF format # undefined THEN copy.start.node.format _ TheSymbol[format]; result _ copy.start.node; ) (define-proc (tioga-insert-text-as-sibling! dest-node string format) "insert a new node as a sibling" dstNode: TextNode.Ref = TheRefTextNode[destNode]; srcNode: TextNode.Ref = TextEdit.FromRope[RopeFromString[TheString[string]]]; srcRoot: TextNode.Ref = TextEdit.DocFromNode[srcNode]; copy: TextNode.Span = EditSpan.Copy[destRoot: TextNode.Root[dstNode], sourceRoot: srcRoot, dest: TextNode.MakeNodeLoc[dstNode], source: TextNode.MakeNodeSpan[first: srcNode, last: srcNode], where: sibling, nesting: 0]; IF format # undefined THEN copy.start.node.format _ TheSymbol[format]; <> result _ copy.start.node; ) (define-proc (tioga-text tioga-node) "returns the text contents of the node" result _ StringFromRope[TheRefTextNode[tiogaNode].rope]; ) (define-proc (tioga-format tioga-node) "returns the format symbol of Tioga node" result _ TheRefTextNode[tiogaNode].format; IF result = NIL THEN result _ $default; ) (define-proc (tioga-comment? tioga-node) "says whether tioga-node is a comment" result _ IF TheRefTextNode[tiogaNode].comment THEN true ELSE false; ) (define-proc (tioga-level tioga-node) "returns the level of the node" result _ MakeFixnum[TextNode.Level[TheRefTextNode[tiogaNode]]]; ) (define-proc (cedarfy-symbol symbol) "Translates dash-containing symbol into nonDashContaining symbol or string" text: REF TEXT _ RefText.ObtainScratch[100]; j: NAT _ 0; changed: BOOL _ FALSE; text _ RefText.AppendRope[text, Atom.GetPName[TheSymbol[symbol]]]; FOR i: NAT IN [0..text.length) DO SELECT text[i] FROM '? => {text[j] _ 'P; changed _ TRUE; j _ j+1 }; IN ['a..'z], IN ['A..'Z], IN ['0..'9] => { text[j] _ text[i]; j _ j+1 }; ENDCASE => { changed _ TRUE; IF i+1 < text.length THEN text[i+1] _ Ascii.Upper[text[i+1]]; }; ENDLOOP; text.length _ j; IF changed THEN {result _ StringFromRope[Atom.GetPName[Atom.MakeAtomFromRefText[rt: text]]]} ELSE result _ symbol; RefText.ReleaseScratch[text]; ) <> (define (unmix filename) "Make a .mx file into separate Scheme and Mesa files" (define in-name (string-append (filename-base filename) "." (or (filename-ext filename) "mx"))) (define basename (filename-base filename)) (define out-name (string-append (filename-base filename) ".mxtmp")) (define doc-in (tioga-file-read in-name)) (format #t "MixMastering ~A: " in-name) (let ((doc-out (tioga-unmix doc-in))) (display ".") (tioga-file-write out-name doc-out) <<(tioga-destroy! doc-out)>> <<(tioga-destroy! doc-in)>> (display ".") (transform-mxtmp basename) (display ".") (hobbit-file basename) (display ".") (do-command (string-append "Mako " basename "MXCode")) (format #t " done.~%") ) ) (define (tioga-unmix doc-in) "Make a .mx Tioga document into a .mxtmp Tioga document" (define out (tioga-create-doc)) (let loop ((node (tioga-child doc-in))) (when node (when (not (tioga-comment? node)) (case (tioga-format node) ((code cedar) (set! out (tioga-insert-text-as-sibling! out (format #f "~S" (list 'cedar (tioga-text node))) 'default)) ) (else (set! out (tioga-copy-node! out node))) ) ) (loop (tioga-forward node)) ) ) (tioga-root out) ) (define (for-each-apply proc lst) (for-each (lambda (x) (apply proc x)) lst) ) (define (transform-mxtmp basename) (define in (open-input-file (string-append basename ".mxtmp"))) (define require-out (open-output-file (string-append basename "MXCode.require"))) (define scheme-out (open-output-file (string-append basename ".scheme"))) (define cedar-out (open-output-file (string-append basename "MXCode.mesa"))) (define cedarname (string-append basename "MXCode.mesa")) (define imports '("Scheme" "Atom")) (define directory '("Scheme" "Atom" "Rope")) (define (insert-imports name) (insert-directory name) (when (not (member name imports)) (set! imports (cons name imports)))) (define (insert-directory name) (when (not (member name directory)) (set! directory (cons name directory)))) (define cedar-code '()) (define (append-cedar code) (set! cedar-code (cons code cedar-code)) ) (define procs '()) (define n 0) (define (define-proc template doc . code) (set! procs (cons (list* n template doc code) procs)) (set! n (+ 1 n)) ) (define enables '()) (define (primitive-enable . code) (set! enables (append code enables)) ) (define (emit-cedar-code cedar-key code-string) (if (not (eq? cedar-key 'cedar)) (error cedar-key "not a cedar form")) (emit (string-append " " code-string)) ) (define (arg-name arg) (if (pair? arg) (car arg) arg) ) (define (arg-optional? arg) (pair? arg) ) (define (emit-proc-case n template doc . code) (define argn 0) (define (emit-arg-copy arg) (set! argn (+ 1 argn)) (if (< argn 4) (emit " ~A: Any _ ARG~A;" (cedarfy-symbol (arg-name arg)) argn) (emit " ~A: Any _ POP[];" (cedarfy-symbol (arg-name arg))) ) ) (define (emit-rest-arg-copy arg) (emit " ~A: Any _ REST;" (cedarfy-symbol arg)) ) (emit " ~A => {" n) (let loop ((args (cdr template))) (cond ((pair? args) (emit-arg-copy (car args)) (loop (cdr args)) ) ((symbol? args) (emit-rest-arg-copy args) ) ((not (null? args)) (error 'mixmaster args "Illegal argument list tail") ) ) ) (for-each-apply emit-cedar-code code) (emit " };" n) ) (define (emit-proc-define n template doc . code) (define (fix-default-markers lst) (if (pair? lst) (if (arg-optional? (car lst)) `( "[" ,(arg-name (car lst)) "]" ,@(fix-default-markers (cdr lst))) (cons (car lst) (fix-default-markers (cdr lst))) ) lst ) ) (let loop ((nargs 0) (optional 0) (args (cdr template))) (if (pair? args) (if (arg-optional? (car args)) (loop (+ nargs 1) (+ optional 1) (cdr args)) (loop (+ nargs 1) optional (cdr args)) ) (emit " DefinePrimitive[name: ~S, nArgs: ~A, proc: ~APrim, doc: ~S, env: env, optional: ~A, dotted: ~A, data: Cons[MakeFixnum[~A], env]];" (symbol->string (car template)) nargs basename (if (char=? #\( (string-ref doc 0)) ; ) for paren-matching doc (format #f "~A ~A" (fix-default-markers (cdr template)) doc) ) optional (if (symbol? args) "TRUE" "FALSE") n ) ) ) ) (define ref-types '()) (define (cedar-require line) (format require-out "~A~%" line) ) (define (define-ref-type module typename) (set! ref-types (cons (list module typename) ref-types)) ) (define (emit-ref-type module typename) (define qname (if module (string-append module "." typename) typename)) (emit " The~A: PROC [a: Any] RETURNS [~A] = {" typename qname) (emit " WITH a SELECT FROM") (emit " a: ~A => RETURN [a];" qname) (emit " ENDCASE => Complain[a, \"not a ~A\"];" qname) (emit " };") ) (define rep-types '()) (define (define-rep-type module typename) (set! rep-types (cons (list module typename) rep-types)) ) (define (emit-rep-type module typename) (define qname (if module (string-append module "." typename) typename)) (emit " The~A: PROC [a: Any] RETURNS [~A] = {" typename qname) (emit " WITH a SELECT FROM") (emit " a: REF ~A => RETURN [a^];" qname) (emit " ENDCASE => Complain[a, \"is not a REF ~A\"];" qname) (emit " };") ) (define enum-types '()) (define (define-enum-type module typename name-list) (set! enum-types (cons (list module typename name-list) enum-types)) ) (define (emit-key-val-assign x) (define cx (cedarfy-symbol x)) (if (eq? x cx) (emit " a[~A] _ $~A;" cx x) (begin (insert-imports "Atom") (emit " a[~A] _ Atom.MakeAtom[\"~A\"];" cx x) ) ) ) (define (emit-enum-type module typename name-list) (define qname (if module (string-append module "." typename) typename)) (emit " SymbolFor~A: REF ARRAY ~A OF Symbol = InitSymbolFor~A[];" typename qname typename ) (emit " InitSymbolFor~A: PROC RETURNS [a: REF ARRAY ~A OF Symbol] = {" typename qname ) (emit " a _ NEW[ARRAY ~A OF Symbol];" qname ) (for-each emit-key-val-assign name-list) (emit " };") (emit " The~A: PROC [a: Any] RETURNS [~A] = {" typename qname) (emit " FOR k: ~A IN ~A DO" qname qname) (emit " IF a=SymbolFor~A[k] THEN RETURN [k];" typename) (emit " ENDLOOP;") (emit " ERROR Complain[a, \"is not a ~A\"];" qname) (emit " };") ) (define (emit fmt . rest) (if (null? rest) (display fmt cedar-out) (apply format cedar-out fmt rest) ) (newline cedar-out) ) (define (emit-list lst sep) (if (null? lst) #f (begin (display (car lst) cedar-out) (when (pair? (cdr lst)) (display sep cedar-out) (emit-list (cdr lst) sep))))) (define (emit-p-list prefix-string lst sep postfix-string) (display prefix-string cedar-out) (emit-list lst sep) (emit postfix-string) ) (define (release-as world component) (format scheme-out "(require ~S ~S \"~AMXCode\")~%" world component basename) ) (let loop ((item (read in))) (if (eof-object? item) #f (begin (case (if (pair? item) (car item) 'other) ((cedar-directory) (for-each insert-directory (cdr item)) ) ((cedar-imports) (for-each insert-imports (cdr item)) ) ((cedar-require) (for-each cedar-require (cdr item)) ) ((release-as) (apply release-as (cdr item)) ) ((define-ref-type) (apply define-ref-type (cdr item))) ((define-rep-type) (apply define-rep-type (cdr item))) ((define-enum-type) (apply define-enum-type (cdr item))) ((define-proc) (apply define-proc (cdr item))) ((cedar) (apply append-cedar (cdr item))) ((primitive-enable) (apply primitive-enable (cdr item))) (else (format scheme-out "~S~%" item)) ) (loop (read in)) ) ) ) (format require-out "Run ~AMXCode~%" basename) (emit "-- ~AMXCode.mesa" basename) (emit-p-list "DIRECTORY " (sort directory string ERROR" ) (when (not (null? enables)) (emit " }; INNER[!" ) (for-each-apply emit-cedar-code enables) (emit " ];" ) ) (emit " };") (emit " ") (emit " ~AInit: PROC [env: Environment] = {" basename) (for-each-apply emit-proc-define procs) (emit " };") (emit " ") (for-each (lambda (code-string) (emit (string-append " " code-string)) ) (reverse cedar-code)) (emit " RegisterInit[~AInit];" basename) (emit "END." ) (close-input-port in) (close-output-port require-out) (close-output-port scheme-out) (close-output-port cedar-out) )