diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 3d09dfb68..a2afffa93 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -254,6 +254,14 @@ If there is no handler at all, Guile prints an error and then exits." +;;; {Structs} +;;; + +(define (make-struct/no-tail vtable . args) + (apply make-struct vtable 0 args)) + + + ;;; {and-map and or-map} ;;; ;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 6fdc14104..91ff8c796 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -114,7 +114,6 @@ ((vector-set! . 3) . vector-set) ((variable-ref . 1) . variable-ref) ;; nb, *not* variable-set! -- the args are switched - ((variable-set . 2) . variable-set) ((variable-bound? . 1) . variable-bound?) ((struct? . 1) . struct?) ((struct-vtable . 1) . struct-vtable) @@ -385,6 +384,18 @@ args)) (maybe-emit-return)))) + ;; A hack for variable-set, the opcode for which takes its args + ;; reversed, relative to the variable-set! function + ((and (primitive-ref? proc) + (eq? (primitive-ref-name proc) 'variable-set!) + (= (length args) 2)) + (comp-push (cadr args)) + (comp-push (car args)) + (emit-code src (make-glil-call 'variable-set 2)) + (case context + ((tail push vals) (emit-code #f (make-glil-void)))) + (maybe-emit-return)) + ((and (primitive-ref? proc) (or (hash-ref *primcall-ops* (cons (primitive-ref-name proc) (length args))) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 6405f37d4..f710fa639 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -60,7 +60,6 @@ vector-ref vector-set! variable-ref variable-set! variable-bound? - ;; args of variable-set are switched; it needs special help fluid-ref fluid-set! @@ -121,7 +120,7 @@ caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr vector-ref - struct? struct-vtable make-struct struct-ref + struct? struct-vtable make-struct make-struct/no-tail struct-ref bytevector-u8-ref bytevector-s8-ref bytevector-u16-ref bytevector-u16-native-ref bytevector-s16-ref bytevector-s16-native-ref @@ -140,7 +139,7 @@ not pair? null? list? acons cons cons* list vector - struct? make-struct)) + struct?)) (define *effect-free-primitive-table* (make-hash-table)) (define *effect+exceptions-free-primitive-table* (make-hash-table)) @@ -334,10 +333,6 @@ (define-primitive-expander values (x) x) -;; swap args -(define-primitive-expander variable-set! (var val) - (variable-set val var)) - (define-primitive-expander make-struct (vtable tail-size . args) (if (and (const? tail-size) (let ((n (const-exp tail-size)))