home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / back_end / aem68gen.t next >
Encoding:
Text File  |  1988-02-05  |  3.9 KB  |  79 lines
  1. (herald aem68gen)
  2.  
  3. (define (generate-foreign-call node)
  4.   (destructure (((cont foreign rep-list value-rep . arg-list) (call-args node)))
  5.     (let ((reps (leaf-value rep-list))
  6.           (value-rep (leaf-value value-rep))
  7.           (args (reverse arg-list)))
  8.       (emit m68/move .l SP (reg-offset TASK task/foreign-call-cont))
  9.       (generate-push nil-reg)   ; save slink
  10.       (generate-move nil-reg AN)
  11.       (emit m68/move .l TASK (reg-offset AN slink/current-task))
  12.       (walk (lambda (arg rep)               ; rep is (type rep name)
  13.               (case (cadr rep)
  14.                 ((rep/extend rep/string rep/value))
  15.                 ((rep/string-pointer)
  16.                  (rep-push node (leaf-value arg) 'rep/string))
  17.                 ((rep/extend-pointer)
  18.                  (rep-push node (leaf-value arg) 'rep/extend))
  19.                 (else
  20.                  (rep-push node (leaf-value arg) (cadr rep)))))
  21.             arg-list
  22.             (reverse reps))
  23.       (iterate loop ((reps reps) (args args) (slots-used 0) (pos 0))
  24.         (cond ((null? reps))
  25.               (else
  26.                (case (cadar reps)
  27.                  ((rep/extend rep/string rep/value)
  28.                   (rep-push node (leaf-value (car args)) (cadar reps))
  29.                   (loop (cdr reps) (cdr args) slots-used (fx+ pos 4)))
  30.                  (else
  31.                   (emit m68/pea (reg-offset SP (fx+ slots-used pos)))
  32.                   (loop (cdr reps) (cdr args) (fx+ slots-used 4) (fx+ pos 4)))))))
  33.                                                ;  TASK must be A6 which 
  34.                                                ; is saved and restored by aegis
  35.       (let ((reg (->register 'pointer node (leaf-value foreign) '*))) ; get xeno
  36.         (emit m68/move .l (reg-offset reg 6) P))  ; P must be A0, get 2nd slot
  37.       (emit m68/jsr (@r 8))   ; a0 = P
  38.       (clear-slots)
  39.       (receive (reg count) (case value-rep
  40.                              ((ignore) (return A1 0))
  41.                              ((rep/address)
  42.                               (generate-move P SCRATCH)
  43.                               (emit m68/asl .l (machine-num 2) SCRATCH)
  44.                               (generate-move SCRATCH A1)
  45.                               (lock A1)
  46.                               (return A2 1))
  47.                              (else
  48.                               (really-rep-convert node S0 value-rep A1 'rep/pointer)
  49.                               (lock A1)
  50.                               (return A2 1)))
  51.         (iterate loop ((args arg-list) (reg reg) (reps (reverse reps)) (pos 0) (count count))
  52.           (cond ((null? args)
  53.                  (clear-slots)
  54.                  (emit m68/move .l (reg-offset TASK task/foreign-call-cont) SP)
  55.                  (emit m68/move .l (reg-offset sp -4) nil-reg)  ; restore slink
  56.                  (emit m68/clr .l (reg-offset TASK task/foreign-call-cont))
  57.                  (generate-return count))            
  58.                 ((fx= reg AN)
  59.                  (loop args (fx+ (fx+ AN 1) *argument-registers*) reps pos count))    
  60.                 (else
  61.                  (case (caar reps)
  62.                    ((ignore in)
  63.                     (loop (cdr args) reg (cdr reps) (fx+ pos 4) count))
  64.                    (else
  65.                     (let ((rep (cadar reps)))
  66.                       (case rep
  67.                         ((rep/extend)
  68.                          (really-rep-convert node (reg-offset SP pos) 
  69.                                    rep reg 'rep/pointer)
  70.                          (lock reg)
  71.                          (loop (cdr args) (fx+ reg 1) (cdr reps) (fx+ pos 4)
  72.                            (fx+ count 1)))
  73.                         (else
  74.                          (emit m68/move .l (reg-offset SP pos) P)
  75.                          (really-rep-convert node (@r 8) rep reg 'rep/pointer)
  76.                          (lock reg)
  77.                          (loop (cdr args) (fx+ reg 1) (cdr reps) (fx+ pos 4)
  78.                            (fx+ count 1))))))))))))))
  79.