Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- ;------------------------MEMORY-----------------------------------
- (define mem-start-index 1)
- (define update-mem-index
- (lambda (n)
- (let ((curr-index mem-start-index))
- (set! mem-start-index (+ mem-start-index n))
- curr-index)))
- ;------------------------CONST-TABLE------------------------------
- (define const-table `(,(void) () ,#t ,#f))
- (define expand-const-table
- (lambda (pe)
- (cond ((or (null? pe) (not (list? pe))) #f)
- ((equal? (car pe) 'const)
- (let ((val (cadr exp)))
- (cond ((null? val) #f)
- ((vector? val)
- (begin (vector-map (lambda (e) (expand-const-table `(const ,e))) val)
- (set! const-table (append const-table (list val)))))
- ((pair? val)
- (begin (expand-const-table `(const ,(car val)))
- (expand-const-table `(const ,(cdr val)))
- (set! const-table (append const-table (list val)))))
- ((and (number? val) (not (integer? val)))
- (let* ((original-num (numerator val))
- (original-den (denominator val))
- (gcd-val (gcd original-num original-den))
- (updated-num (/ original-num gcd-val))
- (updated-den (/ original-den val gcd-val)))
- (begin (expand-const-table `(const ,updated-num))
- (expand-const-table `(const ,updated-den))
- (set! const-table (append const-table (list val))))))
- ((symbol? val)
- (begin (set! const-table (append const-table (list (symbol->string val))))
- (set! const-table (append const-table (list val)))))
- (else (set! const-table (append const-table (list val))))))
- (else (map expand-const-table pe))))))
- (define remove-duplicates-from-const-table
- (lambda ()
- (set! const-table (remove-duplicates-from-list const-table))))
- (define get-address-from-table
- (lambda(constant tagged-table)
- (let* ((curr-row (car tagged-table))
- (curr-val (cadr curr-row))
- (curr-address (car curr-row)))
- (if (equal? constant curr-val)
- curr-address
- (get-address-from-table constant (cdr tagged-table))))))
- (define const-table-add-address-and-type-id
- (lambda()
- (set! const-table
- (fold-left
- (lambda (acc-table constant)
- (cond ((equal? constant (void)) `(,(update-mem-index 1) ,constant T_VOID))
- ((equal? constant '()) `(,(update-mem-index 1) ,constant T_NIL))
- ((equal? constant #t) `(,(update-mem-index 2) ,constant (T_BOOL 1)))
- ((equal? constant #f) `(,(update-mem-index 2) ,constant (T_BOOL 0)))
- ((number? constant)
- (let* ((gcd-val (gcd original-num original-den))
- (updated-num (/ original-num gcd-val))
- (updated-den (/ original-den val gcd-val)))
- (if (integer? constant)
- `(,(update-mem-index 2) ,updated-num (T_INTEGER ,updated-num))
- `(,(update-mem-index 3) ,constant (T_FRACTION ,(get-address-from-table updated-num acc-table)
- ,(get-address-from-table updated-den acc-table))))))
- ((char? constant) `(,(update-mem-index 2) ,constant (T_CHAR ,(char->integer constant))))
- ((vector? constant)
- (let ((address-lst (map (lambda (x) (get-address-from-table x acc-table)) (vector->list constant)))
- (vector-len (vector-length constant)))
- `(,(update-mem-index (+ vector-len 2)) ,constant (T_VECTOR ,vector-len ,@address-lst))))
- ((string? constant)
- (let ((ascii-value-lst (map (lambda (el) (char->integer el)) (string->list constant)))
- (string-len (string-length constant)))
- `(,(update-mem-index (+ string-len 2)) ,constant (T_STRING ,string-len ,@ascii-value-lst))))
- ((symbol? constant)
- `(,(update-mem-index 2) ,constant (T_SYMBOL ,(get-address-from-table (symbol->string constant) acc-table))))
- ((pair? constant)
- `(,(update-mem-index 3) ,constant (T_PAIR ,(get-address-from-table (car constant) acc-table)
- ,(get-address-from-table (cdr constant) acc-table))))
- (else (error 'constant "const table add address and type id error"))))
- '()
- const-table))))
- (define create-const-table
- (lambda (pe-lst)
- (begin (expand-const-table pe-lst)
- (remove-duplicates-from-const-table)
- (const-table-add-address-and-type-id))))
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement