;	Wednesday  Aug 20,1980  00:20  FQ+1D.17H.10M.56S.  -*- Lisp -*-


(defun declare-globally macro (x)
    (mapc 'eval (cdr x))
    `(cond ((status feature complr) ,@(cdr x))))


(declare-globally
   (*lexpr getsyntax getmacro getchtran)
   (fixnum (getsyntax fixnum notype) (getchtran fixnum notype))
   (notype (getmacro fixnum notype))
   (mapc '(lambda (x) (putprop x '(1 . 2) 'args))
	 '(getsyntax getmacro getchtran)))


(lap-a-list
  '((lap getsyntax lsubr)
    (args getsyntax (1 . 2))
	(skipa f (% 0 0 fix1))
	(movei f cpopj)
	(jsp tt lwnack)
	  (12._18. 0 'getsyntax)
	(jsp r set-up-args)
	(hlrz tt @ 1 b)
	(jrst 0 0 f)

    set-up-args
	(aojl t (* 2))
	(tdza b b)
	(pop p b)
    rt-recheck
	(skipn 0 b)
	  (move b (special readtable))
	(movei t 0 b)
	(lsh t -9.)
	(hrrz t st t)
	(caie t 'array)
	  (jrst 0 rtlose)
	(move t 0 b)
	(tlnn t #o20000)
	  (jrst 0 rtlose)
	(pop p a)
	(jsp t fxnv1)
	(andi tt 127.)
	(jrst 0 0 r)

    rtlose
	(movei a 0 b)
	(erint 2 (% sixbit |bad value for readtable!|))
	(movei b 0 a)
	(jrst 0 rt-recheck)


    (entry getmacro lsubr)
    (args getmacro (1 . 2))
	(jsp tt lwnack)
	  (#o14_22 0 'getmacro)
	(jsp r set-up-args)
	(hlrz t @ 1 b)
	(trnn t #o4000)
	  (tdza a a)
	    (hrrz a @ 1 b)
	(popj p)

    (entry getchtran lsubr)
    (args getchtran (1 . 2))
	(skipa f (% 0 0 fix1))
	  (movei f cpopj)
	(jsp tt lwnack)
	  (#o14_22 0 'getchtran)
	(jsp r set-up-args)
	(hlrz t @ 1 b)
	(trnn t #o4000)
	  (hrrz tt @ 1 b)
	(jrst 0 0 f)

    nil))