Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

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

  • Loading branch information...
commit e03767fdfdfb5627109f95fc912d4390c188eee1 1 parent 6e2e069
@gnuvince gnuvince authored
Showing with 94 additions and 0 deletions.
  1. +94 −0 gsc/_t-x86.scm
View
94 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)))
Please sign in to comment.
Something went wrong with that request. Please try again.