[_CDCSL_93-16_]<1>Cedar>release>MixMaster>MixMaster.mx

MixMaster.mx

Michael Plass, February 26, 1992 11:16 am PST

Last changed by Pavel on February 28, 1990 8:31 pm PST

Documentation

This program allows for the convenient generation of Cedar stubs for Scheme primitives. The idea is to have a Tioga file (with the extension ".mx" and the style "MixMaster") with some Scheme nodes and some Cedar/Mesa nodes. The type of the nodes are distiguished by the format name:

code, cedar => this is a line of Cedar code

scheme, default (or anything else) => this is a line of Scheme code

Bootstrapping: This file is also an example of the program's input. That is,

% MixMaster MixMaster

will cause new versions of MixMasterMXCode.require, MixMaster.scheme, MixMaster.$cheme, and MixMasterMXCode.mesa to be written.

Special top-level forms recognized by this program:

(cedar-imports . strings)

add strings to DIRECTORY and IMPORT clauses

(cedar-directory . strings)

add strings to DIRECTORY clause only

(cedar-require . strings)

Add the given strings to the .require file.

(release-as world component)

Where the FooMXCode.require file lives.

(define-ref-type module-name-string type-name-string)

Defines TheFoo procedure for narrowing a "Foo"

(define-rep-type module-name-string type-name-string)

Defines TheFoo procedure for narrowing a "REF Foo"

(define-enum-type module-name-string type-name-string symbol-list)

Defines TheFoo procedure for converting a symbol into an enumerated type, and SymbolForFoo for converting an enumerated type into a symbol.

(define-proc (procname . args) doc-string . cedar-code)

Defines a primitive procedure that takes the specified arguments. Parenthesized argument names are optional; dotted argument lists (rest arguments) are allowed. The local variable "env" contains the top-level environment.

(cedar cedar-code-string)

Makes Cedar code that gets passed into the mesa file. The .mx source does not normally contain these; they are generated by the first pass, which looks at the node structure to generate a .mxtmp file.

(primitive-enable . cedar-code)

The cedar-code nodes are catch phrases that get wrapped around (all of the) primitives; useful for catching random cedar ERRORs and turning them into Scheme.Complain

Cedar support for reading and writing Tioga files, and various FS things

(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)"

TEditInput.FreeTree[root: TextNode.Root[TheRefTextNode[tiogaNode]]]

)

(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];

TEditInput.FreeTree[root: srcRoot];

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];

IF format # undefined THEN copy.start.node.format ← TheSymbol[format];

TEditInput.FreeTree[root: srcRoot];

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];

)

The unmix implementation

(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")

)

(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)

(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<?) ", " ";")

(emit "~AMXCode: CEDAR PROGRAM" basename)

(emit-p-list "IMPORTS " (sort imports string<?) ", " "")

(emit "= BEGIN OPEN Scheme;" )

(emit " SymbolFromRope: PROC [rope: Rope.ROPE] RETURNS [Symbol] ~ {RETURN[Atom.MakeAtom[rope]]};" )

(emit " RopeFromSymbol: PROC [Symbol] RETURNS [Rope.ROPE] ~ Atom.GetPName;" )

(for-each-apply emit-ref-type ref-types)

(for-each-apply emit-rep-type rep-types)

(for-each-apply emit-enum-type enum-types)

(emit " ~APrim: PROC [SELF: Primitive, ARG1,ARG2,ARG3: Any, REST: ProperList] RETURNS [result: Any ← unspecified] = {" basename)

(if (not (null? enables))

(emit "INNER: PROC = {" )

)

(emit " POP: PROC RETURNS [a: Any ← undefined] = {" )

(emit " IF REST#NIL THEN {a ← REST.car; REST ← NARROW[REST.cdr]}};" )

(emit " DATA: Pair ~ NARROW[SELF.data];")

(emit " env: Environment ~ NARROW[DATA.cdr];")

(emit " SELECT NAT[NARROW[DATA.car, REF INT]^] FROM" )

(for-each-apply emit-proc-case procs)

(emit " ENDCASE => 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)

)