Re: Need Help on T/Pascal Interface

[Norman Adams <Adams@YALE.ARPA>]

    I'd like to call "PGM_$INVOKE" from T with an argument vector.  I can't
    figure out how to do this, though I understand from 'sys.t' how to call
    it without any arguments.
  
Jonathan and I hacked together some stuff so that you could give apollo shell
commands (with arguments and redirection) to the T repl by prefixing them with 
a colon character.  Unfortunately, this stuff is not in publically consumable
form, but the following excerpt may tell you what you need to know.  

WARNING: the following contains a raw CALL-XENOID, a dreaded Assembly 
Code Routine, and abusive language; parental discretion is advised.

---------------------------------

(define-constant *pgm_$invoke-xenoid* (make-external-object "pgm_$invoke"))

(define (pgm-invoker pgm-name stdin stdout back items)
  (let ((argc (fx+ (length items) 1))
        (pgm (search-for-file (->string pgm-name) *csr* '())))
    (if (not pgm) (error "program ~s not found" pgm-name)
      (with-open-streams ((in-stream
                           (if stdin  (open (->string stdin)  '(in))  nil))
                          (out-stream
                           (if stdout (open (->string stdout) '(out)) nil)))
        (let ((in-channel
               (if in-stream (stream-channel in-stream) *stdin-xenoid*))
              (out-channel
               (if out-stream (stream-channel out-stream) *stdout-xenoid*))
              (argv (make-bytev (fx* argc 4)))
              (connv (make-bytev 4))
              (st (make-xenoid 0))
              (ec (make-bytev 8)))
          (set (bref-16 connv 0) (strid->fixnum in-channel))
          (set (bref-16 connv 2) (strid->fixnum out-channel))
          (set (bref-pointer argv 0) (string->pgm_$arg pgm))
          (do ((i 4 (fx+ i 4))
               (items items (cdr items)))
              ((null? items)
               (call-xenoid nil nil *pgm_$invoke-xenoid*
                 argc                   ;argc
                 2                      ;streamc
                 (if back 2 1)         ;mode (pset pgm_$wait)
                 st                     ;status
                 ec                     ;ec or some shit.
                 #\w                    ;mode
                 connv                  ;connv
                 #\w                    ;streamc
                 argv                   ;argv
                 #\w                    ;argc
                 #\s                    ;pgm namelength
                 pgm)    
               (set *ec* ec)
               (cond ((zero-xenoid? st)
                      *repl-wont-print*)
                     (else (print-apollo-error st))))
            (set (bref-pointer argv i)
                 (string->pgm_$arg (->string (car items))))))
        ))))

(define (strid->fixnum xenoid)
  (fixnum-ashr (xenoid->fixnum xenoid) 16))

;;; Very gross hacking for pgm_$invoke arg vector...

(define (string->pgm_$arg string)
  (let ((string (check-arg string? string string->pgm_$arg))
        (len (string-length string)))
    (let ((bv (make-bytev (+ len 2))))
      (set (bref-16 bv 0) len)
      (copy-bytes-from-string bv 2 string len)
      )))

;;; (COPY-BYTES-FROM-STRING target offset-in-t string count)
;;; Offsets and COUNT are in bytes.  Source and target can't overlap.
(define-lap-procedure copy-bytes-from-string ((expr 4 0 0))
  (move.l (reg sp) d0)
  (asr.l (lit 3) d0)                    "number of bytes"
  (move.l (reg sp 4) xp)                "source string"
  (clr.l d1)
  (move.w (reg xp %%string-base-offset) d1)
  (move.l (reg sp 8) d2)                "target offset"
  (asr.l (lit 3) d2)
  (move.l (reg sp 12.) val)             "target"
  ;; GC CRITICAL
  (move.l (reg xp %%string-pointer-offset) xp)
  (add.l d1 xp)
  (add.l d2 val)
  (bra.s copy-bytes-loop-start)

copy-bytes-loop
  (move.b (reg+ xp) (reg+ val))
copy-bytes-loop-start
  (dbra d0 copy-bytes-loop)

  (move.l (reg sp 12.) val)             "return target"
  (lea (reg sp 16.) sp)
  (jmp (slink ireturn))
  )

-------