Added ##cons ##car ##cdr + their multi letter variants

gambit · Sep 5, 2012 · e03767f · e03767f
1 parent 6e2e069
commit e03767f
Showing 1 changed file with 94 additions and 0 deletions.
diff --git a/gsc/_t-x86.scm b/gsc/_t-x86.scm
@@ -1567,3 +1567,97 @@
 (define-fxcmp-primitive "##fx>"  x86-jle)
 (define-fxcmp-primitive "##fx>=" x86-jl)
 (define-fxcmp-primitive "##fx="  x86-jne)
+
+
+(x86-prim-define "##cons" #t #f
+  (lambda (cgc opnds loc)
+    (let* ((targ (codegen-context-target cgc))
+           (ctx (make-ctx targ #f))
+           (sp (nat-target-heap-ptr-reg targ))
+           (loc (nat-opnd cgc ctx loc)))
+      (x86-push cgc (nat-opnd cgc ctx (list-ref opnds 0)))
+      (x86-push cgc (nat-opnd cgc ctx (list-ref opnds 1)))
+      (x86-push cgc (x86-imm-int (macro-subtype-pair)))
+      (x86-mov cgc loc sp))))
+
+;; (x86-prim-define "##car" #f #f
+;;   (lambda (cgc opnds loc)
+;;     (let* ((targ (codegen-context-target cgc))
+;;            (ctx (make-ctx targ #f))
+;;            (pair (nat-opnd cgc ctx (car opnds)))
+;;            (loc (nat-opnd cgc ctx loc))
+;;            (working-reg (nat-target-pstate-ptr-reg targ)))
+;;       (x86-push cgc working-reg)
+;;       (x86-mov cgc working-reg pair)
+;;       (x86-mov cgc loc (x86-mem (* 2 (nat-target-word-width targ)) working-reg))
+;;       (x86-pop cgc working-reg))))
+
+;; (x86-prim-define "##cdr" #f #f
+;;   (lambda (cgc opnds loc)
+;;     (let* ((targ (codegen-context-target cgc))
+;;            (ctx (make-ctx targ #f))
+;;            (pair (nat-opnd cgc ctx (car opnds)))
+;;            (loc (nat-opnd cgc ctx loc))
+;;            (working-reg (nat-target-pstate-ptr-reg targ)))
+;;       (x86-push cgc working-reg)
+;;       (x86-mov cgc working-reg pair)
+;;       (x86-mov cgc loc (x86-mem (* 1 (nat-target-word-width targ)) working-reg))
+;;       (x86-pop cgc working-reg))))
+
+
+
+(define (x86-define-cxxxxr op-name operations)
+  (x86-prim-define op-name #f #f
+    (lambda (cgc opnds loc)
+      (let* ((targ (codegen-context-target cgc))
+             (ctx (make-ctx targ #f))
+             (pair (nat-opnd cgc ctx (car opnds)))
+             (loc (nat-opnd cgc ctx loc))
+             (working-reg (nat-target-pstate-ptr-reg targ)))
+        (x86-push cgc working-reg)
+        (x86-mov cgc working-reg pair)
+        (for-each
+         (lambda (car-or-cdr)
+           (let ((offset (if (eq? car-or-cdr 'a)
+                             (* 2 (nat-target-word-width targ))
+                             (nat-target-word-width targ))))
+             (x86-mov cgc working-reg (x86-mem offset working-reg))))
+         operations)
+        (x86-mov cgc loc working-reg)
+        ;; (x86-mov cgc working-reg pair)
+        ;; (x86-mov cgc loc (x86-mem (* 1 (nat-target-word-width targ)) working-reg))
+        (x86-pop cgc working-reg)))))
+
+(x86-define-cxxxxr "##car"    (reverse '(a)))
+(x86-define-cxxxxr "##cdr"    (reverse '(d)))
+
+(x86-define-cxxxxr "##caar"   (reverse '(a a)))
+(x86-define-cxxxxr "##cadr"   (reverse '(a d)))
+(x86-define-cxxxxr "##cddr"   (reverse '(d d)))
+(x86-define-cxxxxr "##cdar"   (reverse '(d a)))
+
+(x86-define-cxxxxr "##caaar"  (reverse '(a a a)))
+(x86-define-cxxxxr "##caadr"  (reverse '(a a d)))
+(x86-define-cxxxxr "##cadar"  (reverse '(a d a)))
+(x86-define-cxxxxr "##caddr"  (reverse '(a d d)))
+(x86-define-cxxxxr "##cdaar"  (reverse '(d a a)))
+(x86-define-cxxxxr "##cdadr"  (reverse '(d a d)))
+(x86-define-cxxxxr "##cddar"  (reverse '(d d a)))
+(x86-define-cxxxxr "##cdddr"  (reverse '(d d d)))
+
+(x86-define-cxxxxr "##caaaar" (reverse '(a a a a)))
+(x86-define-cxxxxr "##cdaaar" (reverse '(d a a a)))
+(x86-define-cxxxxr "##cadaar" (reverse '(a d a a)))
+(x86-define-cxxxxr "##cddaar" (reverse '(d d a a)))
+(x86-define-cxxxxr "##caadar" (reverse '(a a d a)))
+(x86-define-cxxxxr "##cdadar" (reverse '(d a d a)))
+(x86-define-cxxxxr "##caddar" (reverse '(a d d a)))
+(x86-define-cxxxxr "##cdddar" (reverse '(d d d a)))
+(x86-define-cxxxxr "##caaadr" (reverse '(a a a d)))
+(x86-define-cxxxxr "##cdaadr" (reverse '(d a a d)))
+(x86-define-cxxxxr "##cadadr" (reverse '(a d a d)))
+(x86-define-cxxxxr "##cddadr" (reverse '(d d a d)))
+(x86-define-cxxxxr "##caaddr" (reverse '(a a d d)))
+(x86-define-cxxxxr "##cdaddr" (reverse '(d a d d)))
+(x86-define-cxxxxr "##cadddr" (reverse '(a d d d)))
+(x86-define-cxxxxr "##cddddr" (reverse '(d d d d)))