Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- #lang racket
- ;;Worked on with Kevin Wang
- (struct constant (label val))
- ;; Throws an error if there is a circular constant dependency
- (define (check-dep-chain consts target)
- (define (check-dep-help lst visited target)
- (cond
- [(check-for-duplicates visited target) (error "circular")]
- [(empty? lst) (void)]
- [(symbol=? (constant-label (car lst)) target)
- (if (symbol? (constant-val (car lst)))
- (check-dep-help consts (cons target visited) (constant-val (car lst)))
- (void))]
- [else (check-dep-help (cdr lst) visited target)]))
- (check-dep-help consts empty target))
- ;;Helper for circular checking
- (define (check-for-duplicates lst target)
- (define (help lst target count)
- (cond
- [(= count 2) #t]
- [(empty? lst) #f]
- [(equal? (car lst) target) (help (cdr lst) target (add1 count))]
- [else (help (cdr lst) target count)]))
- (help lst target 0))
- ;;Another helper for circular
- (define (circular-check lst)
- (define (help c)
- (unless (empty? c)
- (check-dep-chain lst (constant-label (car c)))
- (help (cdr c))))
- (help lst))
- ;;Gets all consts from an A-PRIMP program
- (define (get-constants instrs)
- (define (help instrs consts)
- (if (empty? instrs)
- consts
- (match (car instrs)
- [`(const ,name ,val) (help (cdr instrs) (cons (constant name val) consts))]
- [x (help (cdr instrs) consts)])))
- (help instrs empty))
- ;; Pre-processes the program, producing a list of the following:
- ;; car: the semi-assembled code (data and consts replaced)
- ;; cadr: a list of pairs (label, line num)
- ;; caddr: a list of pairs representing constants (name, value)
- ;; cadddr: a list of pairs representing data (name, first line)
- (define (primp-process program)
- (define (help program labels consts data res lc)
- (if (empty? program)
- (list (reverse res) labels consts data)
- (match (car program)
- [`(const ,name ,val) (help (cdr program) labels (cons (cons name val) consts) data res lc)]
- [`(data ,name (,n ,val)) (help (cdr program) labels consts (cons (cons name lc) data) (append (build-list n (λ (x) val)) res) (+ lc val))]
- [`(data ,name ,val ...) (help (cdr program) labels consts (cons (cons name lc) data) (append (reverse val) res) (+ lc (length val)))]
- [`(label ,name) (help (cdr program) (cons (cons name lc) labels) consts data res lc)]
- [`(lit ,val) (help (cdr program) labels consts data (cons val res) (add1 lc))]
- ['(halt) (help (cdr program) labels consts data (cons 0 res) (add1 lc))]
- [x (help (cdr program) labels consts data (cons x res) (add1 lc))])))
- (help program empty empty empty empty 0))
- (define (primp-assemble program)
- (circular-check (get-constants program))
- (define processed (primp-process program))
- (define intermediate (car processed))
- (define labels (cadr processed))
- (define consts (caddr processed))
- (define data (cadddr processed))
- (define (help prog assembled)
- (if (empty? prog)
- (reverse assembled)
- (help (cdr prog) (cons
- (match (car prog)
- [`(,fun ,dest ,opr1 ,opr2) (list fun (cond
- [(symbol? dest) (cond
- [(assoc dest data) => (λ (x) (list (cdr x)))]
- [else (error "incorrect")])]
- [(list? dest) (cond
- [(and (symbol? (cadr dest)) (not (symbol? (car dest))))
- (if (not (assoc (cadr dest) data))
- (error "incorrect")
- (list (car dest) (list (cdr (assoc (cadr dest) data)))))]
- [(and (symbol? (cadr dest)) (symbol? (car dest)))
- (if (or (not (assoc (cadr dest) data)) (not (assoc (car dest) consts)))
- (error "incorrect")
- (list (cdr (assoc (car dest) consts)) (list (cdr (assoc (cadr dest) data)))))]
- [(symbol? (car dest))
- (if (not (assoc (car dest) const))
- (error "incorrect")
- (list (cdr (assoc (car dest) consts)) (cadr dest)))]
- [else dest])]
- [else (error "incorrect")])
- (cond
- [(symbol? opr1) (cond
- [(assoc opr1 data) => (λ (x) (list (cdr x)))]
- [(assoc opr1 consts) => cdr]
- [else (error "incorrect")])]
- [(list? opr1) (cond
- [(= (length opr1) 1) opr1]
- [(and (symbol? (cadr opr1)) (not (symbol? (car opr1))))
- (if (not (assoc (cadr opr1) data))
- (error "incorrect")
- (list (car opr1) (list (cdr (assoc (cadr opr1) data)))))]
- [(and (symbol? (cadr opr1)) (symbol? (car opr1)))
- (if (or (not (assoc (cadr opr1) data)) (not (assoc (car opr1) consts)))
- (error "incorrect")
- (list (cdr (assoc (car opr1) consts)) (list (cdr (assoc (cadr opr1) data)))))]
- [(symbol? (car opr1))
- (if (not (assoc (car opr1) const))
- (error "incorrect")
- (list (cdr (assoc (car opr1) consts)) (cadr opr1)))]
- [else opr1])]
- [else opr1])
- (cond
- [(symbol? opr2) (cond
- [(assoc opr2 data) => (λ (x) (list (cdr x)))]
- [(assoc opr2 consts) => cdr]
- [else (error "incorrect")])]
- [(list? opr2) (cond
- [(= (length opr2) 1) opr2]
- [(and (symbol? (cadr opr2)) (not (symbol? (car opr2))))
- (if (not (assoc (cadr opr2) data))
- (error "incorrect")
- (list (car opr2) (list (cdr (assoc (cadr opr2) data)))))]
- [(and (symbol? (cadr opr2)) (symbol? (car opr2)))
- (if (or (not (assoc (cadr opr2) data)) (not (assoc (car opr2) consts)))
- (error "incorrect")
- (list (cdr (assoc (car opr2) consts)) (list (cdr (assoc (cadr opr2) data)))))]
- [(symbol? (car opr2))
- (if (not (assoc (car opr2) const))
- (error "incorrect")
- (list (cdr (assoc (car opr2) consts)) (cadr opr2)))]
- [else opr2])]
- [else opr2]))]
- [`(lnot ,dest ,opr1) (list 'lnot (cond
- [(symbol? dest) (cond
- [(assoc dest data) => (λ (x) (list (cdr x)))]
- [else (error "incorrect")])]
- [(list? dest) (cond
- [(and (symbol? (cadr dest)) (not (symbol? (car dest))))
- (if (not (assoc (cadr dest) data))
- (error "incorrect")
- (list (car dest) (list (cdr (assoc (cadr dest) data)))))]
- [(and (symbol? (cadr dest)) (symbol? (car dest)))
- (if (or (not (assoc (cadr dest) data)) (not (assoc (car dest) consts)))
- (error "incorrect")
- (list (cdr (assoc (car dest) consts)) (list (cdr (assoc (cadr dest) data)))))]
- [(symbol? (car dest))
- (if (not (assoc (car dest) const))
- (error "incorrect")
- (list (cdr (assoc (car dest) consts)) (cadr dest)))]
- [else dest])]
- [else (error "i think this is incorrect")])
- (cond
- [(symbol? opr1) (cond
- [(assoc opr1 data) => (λ (x) (list (cdr x)))]
- [(assoc opr1 consts) => cdr]
- [else (error "incorrect")])]
- [(list? opr1) (cond
- [(= (length opr1) 1) opr1]
- [(and (symbol? (cadr opr1)) (not (symbol? (car opr1))))
- (if (not (assoc (cadr opr1) data))
- (error "incorrect")
- (list (car opr1) (list (cdr (assoc (cadr opr1) data)))))]
- [(and (symbol? (cadr opr1)) (symbol? (car opr1)))
- (if (or (not (assoc (cadr opr1) data)) (not (assoc (car opr1) consts)))
- (error "incorrect")
- (list (cdr (assoc (car opr1) consts)) (list (cdr (assoc (cadr opr1) data)))))]
- [(symbol? (car opr1))
- (if (not (assoc (car opr1) const))
- (error "incorrect")
- (list (cdr (assoc (car opr1) consts)) (cadr opr1)))]
- [else opr1])]
- [else opr1]))]
- [`(jump ,opr1) (list 'jump (cond
- [(symbol? opr1) (cond
- [(assoc opr1 data) => (λ (x) (list (cdr x)))]
- [(assoc opr1 consts) => cdr]
- [(assoc opr1 labels) => cdr]
- [else (error "incorrect")])]
- [(list? opr1) (cond
- [(= (length opr1) 1) opr1]
- [(and (symbol? (cadr opr1)) (not (symbol? (car opr1))))
- (if (not (assoc (cadr opr1) data))
- (error "incorrect")
- (list (car opr1) (list (cdr (assoc (cadr opr1) data)))))]
- [(and (symbol? (cadr opr1)) (symbol? (car opr1)))
- (if (or (not (assoc (cadr opr1) data)) (not (assoc (car opr1) consts)))
- (error "incorrect")
- (list (cdr (assoc (car opr1) consts)) (list (cdr (assoc (cadr opr1) data)))))]
- [(symbol? (car opr1))
- (if (not (assoc (car opr1) const))
- (error "incorrect")
- (list (cdr (assoc (car opr1) consts)) (cadr opr1)))]
- [else opr1])]
- [else opr1]))]
- [`(branch ,opr1 ,opr2) (list 'branch (cond
- [(symbol? opr1) (cond
- [(assoc opr1 data) => (λ (x) (list (cdr x)))]
- [(assoc opr1 consts) => cdr]
- [else (error "incorrect")])]
- [(list? opr1) (cond
- [(= (length opr1) 1) opr1]
- [(and (symbol? (cadr opr1)) (not (symbol? (car opr1))))
- (if (not (assoc (cadr opr1) data))
- (error "incorrect")
- (list (car opr1) (list (cdr (assoc (cadr opr1) data)))))]
- [(and (symbol? (cadr opr1)) (symbol? (car opr1)))
- (if (or (not (assoc (cadr opr1) data)) (not (assoc (car opr1) consts)))
- (error "incorrect")
- (list (cdr (assoc (car opr1) consts)) (list (cdr (assoc (cadr opr1) data)))))]
- [(symbol? (car opr1))
- (if (not (assoc (car opr1) const))
- (error "incorrect")
- (list (cdr (assoc (car opr1) consts)) (cadr opr1)))]
- [else opr1])]
- [else opr1])
- (cond
- [(symbol? opr2) (cond
- [(assoc opr2 data) => (λ (x) (list (cdr x)))]
- [(assoc opr2 consts) => cdr]
- [(assoc opr2 labels) => cdr]
- [else (error "incorrect")])]
- [(list? opr2) (cond
- [(= (length opr2) 1) opr2]
- [(and (symbol? (cadr opr2)) (not (symbol? (car opr2))))
- (if (not (assoc (cadr opr2) data))
- (error "incorrect")
- (list (car opr2) (list (cdr (assoc (cadr opr2) data)))))]
- [(and (symbol? (cadr opr2)) (symbol? (car opr2)))
- (if (or (not (assoc (cadr opr2) data)) (not (assoc (car opr2) consts)))
- (error "incorrect")
- (list (cdr (assoc (car opr2) consts)) (list (cdr (assoc (cadr opr2) data)))))]
- [(symbol? (car opr2))
- (if (not (assoc (car opr2) const))
- (error "incorrect")
- (list (cdr (assoc (car opr2) consts)) (cadr opr2)))]
- [else opr2])]
- [else opr2]))]
- [`(move ,dest ,opr1) (list 'move (cond
- [(symbol? dest) (cond
- [(assoc dest data) => (λ (x) (list (cdr x)))]
- [else (error "incorrect")])]
- [(list? dest) (cond
- [(and (symbol? (cadr dest)) (not (symbol? (car dest))))
- (if (not (assoc (cadr dest) data))
- (error "incorrect")
- (list (car dest) (list (cdr (assoc (cadr dest) data)))))]
- [(and (symbol? (cadr dest)) (symbol? (car dest)))
- (if (or (not (assoc (cadr dest) data)) (not (assoc (car dest) consts)))
- (error "incorrect")
- (list (cdr (assoc (car dest) consts)) (list (cdr (assoc (cadr dest) data)))))]
- [(symbol? (car dest))
- (if (not (assoc (car dest) const))
- (error "incorrect")
- (list (cdr (assoc (car dest) consts)) (cadr dest)))]
- [else dest])]
- [else (error "i think this is incorrect")])
- (cond
- [(symbol? opr1) (cond
- [(assoc opr1 data) => (λ (x) (list (cdr x)))]
- [(assoc opr1 consts) => cdr]
- [else (error "incorrect")])]
- [(list? opr1) (cond
- [(= (length opr1) 1) opr1]
- [(and (symbol? (cadr opr1)) (not (symbol? (car opr1))))
- (if (not (assoc (cadr opr1) data))
- (error "incorrect")
- (list (car opr1) (list (cdr (assoc (cadr opr1) data)))))]
- [(and (symbol? (cadr opr1)) (symbol? (car opr1)))
- (if (or (not (assoc (cadr opr1) data)) (not (assoc (car opr1) consts)))
- (error "incorrect")
- (list (cdr (assoc (car opr1) consts)) (list (cdr (assoc (cadr opr1) data)))))]
- [(symbol? (car opr1))
- (if (not (assoc (car opr1) const))
- (error "incorrect")
- (list (cdr (assoc (car opr1) consts)) (cadr opr1)))]
- [else opr1])]
- [else opr1]))]
- [`(print-val ,opr1) (list 'print-val (cond
- [(symbol? opr1) (cond
- [(assoc opr1 data) => (λ (x) (list (cdr x)))]
- [(assoc opr1 consts) => cdr]
- [else (error "incorrect")])]
- [(list? opr1) (cond
- [(= (length opr1) 1) opr1]
- [(and (symbol? (cadr opr1)) (not (symbol? (car opr1))))
- (if (not (assoc (cadr opr1) data))
- (error "incorrect")
- (list (car opr1) (list (cdr (assoc (cadr opr1) data)))))]
- [(and (symbol? (cadr opr1)) (symbol? (car opr1)))
- (if (or (not (assoc (cadr opr1) data)) (not (assoc (car opr1) consts)))
- (error "incorrect")
- (list (cdr (assoc (car opr1) consts)) (list (cdr (assoc (cadr opr1) data)))))]
- [(symbol? (car opr1))
- (if (not (assoc (car opr1) const))
- (error "incorrect")
- (list (cdr (assoc (car opr1) consts)) (cadr opr1)))]
- [else opr1])]
- [else opr1]))]
- [x x]) assembled))))
- (help intermediate empty))
- ;; Circular declaration
- ;(primp-assemble '((const X 10)
- ; (data X 20)))
- ;(primp-assemble '((label X)
- ; (const A #t)
- ; (branch A X)))
- ;(primp-assemble '((data X 10)
- ; (const X 20)))
- ; Not sure what this test does
- ;(primp-assemble '((data X 10)
- ; (data X 10)))
- ;(primp-assemble '((data X 10)
- ; (data Y 20)
- ; (data Z 0)
- ; (add Z X Y)))
- ;(primp-assemble '((data Y 10)
- ; (data Z 0)
- ; (add Z Y X)
- ; (data X 10)))
- ;(primp-assemble '((data Y 10)
- ; (data Z 0)
- ; (add Z Y X)
- ; (data X 10)))
- ;(primp-assemble '((data X 1 2 3 4)
- ; (jump 0)))
- ;(primp-assemble '((data A 10)
- ; (data A A)))
- ;(primp-assemble '((print-val (2))
- ; (data X 1 2)
- ; 0))
- ;(primp-assemble '((data A (1 1))
- ; (data B (10 10))
- ; (move A B)))
- ;(primp-assemble '((label first)
- ; (data A)
- ; ; (jump first)))
- ;(primp-assemble '((jump 0)))
- ;(primp-assemble '((label start)
- ; (print-val temp)
- ; (print-string "\n")
- ; (add cnt cnt 1)
- ; (mul temp temp 2)
- ; (lt cmp cnt 10)
- ; (branch cmp start)
- ; (data cnt 0)
- ; (data temp 1)
- ; (data cmp #t)))
- ;(primp-assemble '((label start)
- ; (branch cmp start)
- ; (data cmp #t)))
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement