diff --git a/printer.rkt b/printer.rkt index 80052fb..408f620 100644 --- a/printer.rkt +++ b/printer.rkt @@ -1,5 +1,6 @@ #lang typed/racket (require "ast.rkt") +(require "semantics.rkt") (define-type IndentLevel Integer) @@ -101,6 +102,49 @@ (ppr-expr a) (iseq-append "(" (ppr-expr a) ")"))) +(: ppr-addr (-> Addr String)) +(define (ppr-addr a) + (number->string a)) + +(: ppr-fwaddr (-> Addr ISeq)) +(define (ppr-fwaddr a) + (let ([s (ppr-addr a)]) + (iseq-append (make-string (- 4 (string-length s)) #\ ) s))) + +(: ppr-node (-> Node ISeq)) +(define (ppr-node a) + (cond + [(integer? a) + (iseq-append "NNum" (number->string a))] + [(not (eq? (car a) 'define)) + (let ([fun (first a)] + [arg (second a)]) + (iseq-append "NAp " (ppr-addr fun) " " (ppr-addr arg)))] + [else (iseq-append "NSupercomb " (symbol->string (caadr a)))])) + +(: ppr-stack-node (-> Heap Node ISeq)) +(define (ppr-stack-node heap node) + (if (and (pair? node) (not (symbol? (car node)))) + (let ([fun : Addr (first node)] + [arg : Addr (second node)]) + (iseq-append-with-sep + " " "NAp" (ppr-fwaddr fun) (ppr-fwaddr arg) "(" (ppr-node (lookup-node heap arg)) ")")) + (ppr-node node))) + +(: ppr-stack (-> Heap Stack ISeq)) +(define (ppr-stack heap stack) + (let ([ppr-stack-item + : (-> Addr ISeq) + (λ (addr) (iseq-append (ppr-fwaddr addr) ": " (ppr-stack-node heap (lookup-node heap addr))))]) + (iseq-append "Stk [" (list 'Hang -1 (ppr-list ppr-stack-item 'Newline stack))))) + +(: ppr-state (-> State ISeq)) +(define (ppr-state st) + (let ([stack (State-stack st)] + [heap (State-heap st)]) + (iseq-append (ppr-stack heap stack) 'Newline))) + + (: iseq->string (-> IndentLevel ISeq String)) (define (iseq->string l a) (let ([s (open-output-string)]) diff --git a/semantics.rkt b/semantics.rkt index 1300666..e25fed8 100644 --- a/semantics.rkt +++ b/semantics.rkt @@ -134,3 +134,5 @@ (allocate-node heap1 (list addr-f addr-a)))] [(? symbol?) (values heap (lookup-globals env e))] [_ (error "unimplemented")])) + +(provide (all-defined-out))