Advertisement
Guest User

Untitled

a guest
Jan 18th, 2018
80
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Scheme 5.52 KB | None | 0 0
  1. ;------------------------MEMORY-----------------------------------
  2.  
  3. (define mem-start-index 1)
  4.  
  5. (define update-mem-index
  6.     (lambda (n)
  7.         (let ((curr-index mem-start-index))
  8.             (set! mem-start-index (+ mem-start-index n))
  9.                 curr-index)))
  10.  
  11. ;------------------------CONST-TABLE------------------------------
  12.  
  13. (define const-table `(,(void) () ,#t ,#f))
  14.  
  15. (define expand-const-table
  16.     (lambda (pe)
  17.         (cond   ((or (null? pe) (not (list? pe))) #f)
  18.                 ((equal? (car pe) 'const)
  19.                     (let ((val (cadr exp)))
  20.                         (cond   ((null? val) #f)
  21.                                 ((vector? val)
  22.                                     (begin (vector-map (lambda (e) (expand-const-table `(const ,e))) val)
  23.                                            (set! const-table (append const-table (list val)))))
  24.                                 ((pair? val)
  25.                                     (begin (expand-const-table `(const ,(car val)))
  26.                                            (expand-const-table `(const ,(cdr val)))
  27.                                            (set! const-table (append const-table (list val)))))              
  28.                                 ((and (number? val) (not (integer? val)))
  29.                                     (let* ((original-num (numerator val))
  30.                                            (original-den (denominator val))
  31.                                            (gcd-val (gcd original-num original-den))
  32.                                            (updated-num (/ original-num gcd-val))
  33.                                            (updated-den (/ original-den val gcd-val)))
  34.                                         (begin (expand-const-table `(const ,updated-num))
  35.                                                (expand-const-table `(const ,updated-den))
  36.                                                (set! const-table (append const-table (list val))))))
  37.                                 ((symbol? val)
  38.                                     (begin  (set! const-table (append const-table (list (symbol->string val))))
  39.                                             (set! const-table (append const-table (list val)))))
  40.                                 (else (set! const-table (append const-table (list val))))))
  41.                      
  42.                 (else (map expand-const-table pe))))))
  43.  
  44.                    
  45. (define remove-duplicates-from-const-table
  46.     (lambda ()
  47.         (set! const-table (remove-duplicates-from-list const-table))))
  48.  
  49.  
  50. (define get-address-from-table
  51.     (lambda(constant tagged-table)
  52.         (let* ((curr-row (car tagged-table))
  53.                (curr-val (cadr curr-row))
  54.                (curr-address (car curr-row)))
  55.               (if (equal? constant curr-val)
  56.                     curr-address
  57.                   (get-address-from-table constant (cdr tagged-table))))))
  58.                    
  59. (define const-table-add-address-and-type-id
  60.     (lambda()
  61.         (set! const-table
  62.             (fold-left
  63.                 (lambda (acc-table constant)
  64.                     (cond   ((equal? constant (void)) `(,(update-mem-index 1) ,constant T_VOID))
  65.                             ((equal? constant '()) `(,(update-mem-index 1) ,constant T_NIL))
  66.                             ((equal? constant #t) `(,(update-mem-index 2) ,constant (T_BOOL 1)))
  67.                             ((equal? constant #f) `(,(update-mem-index 2) ,constant (T_BOOL 0)))
  68.                             ((number? constant)
  69.                                 (let* ((gcd-val (gcd original-num original-den))
  70.                                        (updated-num (/ original-num gcd-val))
  71.                                        (updated-den (/ original-den val gcd-val)))
  72.                                 (if (integer? constant)
  73.                                     `(,(update-mem-index 2) ,updated-num (T_INTEGER ,updated-num))
  74.                                     `(,(update-mem-index 3) ,constant (T_FRACTION ,(get-address-from-table updated-num acc-table)
  75.                                                                                           ,(get-address-from-table updated-den acc-table))))))
  76.                             ((char? constant) `(,(update-mem-index 2) ,constant (T_CHAR ,(char->integer constant))))
  77.                             ((vector? constant)
  78.                                 (let ((address-lst (map (lambda (x) (get-address-from-table x acc-table)) (vector->list constant)))
  79.                                       (vector-len (vector-length constant)))
  80.                                     `(,(update-mem-index (+ vector-len 2)) ,constant (T_VECTOR ,vector-len ,@address-lst))))
  81.                             ((string? constant)
  82.                                 (let ((ascii-value-lst (map (lambda (el) (char->integer el)) (string->list constant)))
  83.                                       (string-len (string-length constant)))
  84.                                     `(,(update-mem-index (+ string-len 2)) ,constant (T_STRING ,string-len ,@ascii-value-lst))))
  85.                             ((symbol? constant)
  86.                                 `(,(update-mem-index 2) ,constant (T_SYMBOL ,(get-address-from-table (symbol->string constant) acc-table))))
  87.                             ((pair? constant)
  88.                                 `(,(update-mem-index 3) ,constant (T_PAIR ,(get-address-from-table (car constant) acc-table)
  89.                                                                                   ,(get-address-from-table (cdr constant) acc-table))))
  90.                             (else (error 'constant "const table add address and type id error"))))
  91.                 '()
  92.                 const-table))))
  93.  
  94. (define create-const-table
  95.     (lambda (pe-lst)
  96.         (begin (expand-const-table pe-lst)
  97.                (remove-duplicates-from-const-table)
  98.                (const-table-add-address-and-type-id))))
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement