View of /lisp/server.l

Parent Directory

Revision Log

*** empty log message ***

;(exfile "newload.l")
;
(defconst SYS_select 93)
(defconst SYS_socket 97)
(defconst SYS_accept 99)
(defconst SYS_bind 104)
(defconst SYS_listen 106)
(defconst SYS_shutdown 134)
(defconst SOCK_STREAM 1)
(defconst AF_INET 2)
(defconst INADDR_ANY (make-string 4))
(defun select (nfds rmask)
  (syscall SYS_select nfds rmask 0 0 0))
(defun socket ()
  (syscall SYS_socket AF_INET SOCK_STREAM 0))
(defun accept (sock addr addrlen)
  (syscall SYS_accept sock addr addrlen))
 ; for SPARC only
(defun htons (i) i)
(defun make-sockaddr (family port addr)
  (let ((ret (make-string 16))
	(newport (htons port)))
    (sset ret 0 (logand 255 (logshift family -8)))
    (sset ret 1 (logand 255 family))
    (sset ret 2 (logand 255 (logshift newport -8)))
    (sset ret 3 (logand 255 newport))
    (string-amend ret addr 4)))
(defun bind (sock family port addr)
  (syscall SYS_bind sock (make-sockaddr family port addr) 16))
(defun listen (sock count)
  (syscall SYS_listen sock count))
;
(defun shutdown (sock how)
  (syscall SYS_shutdown sock how))
;
(defun selbitref (bitarray index)
  (bref bitarray (- 31 index)))
;
(defun selbitset (bitarray index value)
  (bset bitarray (- 31 index) value))
;
(declare (userspace) special)
;
(defun daemon (port)
  (lets ((sock (socket))
	 (origmask (make-string 4))
	 (readtable (vector 256 readtable))
	 (rmask (make-string 4))
	 (newfd)(fdlist)(s1))
    (vset readtable 13 (vref readtable 9))
    (bind sock AF_INET port INADDR_ANY)
    (listen sock 5)
    (selbitset origmask sock t)
    (loop
     (loop
      (string-amend rmask origmask)
      (and (<= 0 (select 32 rmask))(exit)))
     (cond ((selbitref rmask sock)
	    (setq newfd (accept sock (make-sockaddr AF_INET port INADDR_ANY)
				(make-string 4)))
	    (push (list newfd 
			(inopen (stream newfd)) (outopen (stream newfd))nil) fdlist)
	    (selbitset origmask newfd t)))
     (do ((l fdlist (cdr l))
	  (printlevel 0)(printlength 0)(curstream))
       ((atom l))
       (cond ((selbitref rmask (caar l))
	      (let ((curfd (caar l))
		    (rstream (cadar l))
		    (err:end-of-file 
		     (function 
		      (lambda (x (y))
			(setq curstream (assq curfd fdlist))
			(setq openfiles (delq (third curstream) openfiles))
			(setq fdlist (remq curstream fdlist))
			(selbitset origmask curfd nil)
			(exit)))))
		(setq r (read (cadar l))))
	      (print r)
	      (setq userspace (fourth (car l)))
	      (setq r (eval r))
	      (princ r (caddar l))
	      (terpri (caddar l))
;	      (print r)
	      (rplaca (cdddar l) userspace)
	      ))))))
	 
(defmacro definefont (fontname . alist)
  `(setq ,fontname ',alist))

(defmacro defvar (var val)
  `(defvar1 ',var ,val))
(defun defvar1 (sym val)
  (lets ((a (assq sym userspace)))
    (cond (a (rplacd a `(',val))val)
	  (t (setq userspace `((,sym ',val).,userspace)) val))))
(defmacro var (sym)
  `(assqcadr ,sym userspace))

(defmacro setfont (fontname)
  `(defvar currentfont ',fontname))

(definefont Wadalab-mincho-15
  (type  'mincho-patch)
  (minchowidth  15.0)
  (tateyokoratio 0.2)
  (kazariheight 0.9)
  (tomeheight 1.8)
  (hirawidth 0.4)
)
(definefont Wadalab-mincho-12
  (type  'mincho-patch)
  (minchowidth  12.0)
  (tateyokoratio 0.2)
  (hirawidth 0.35)
  (kazariheight 0.9)
  (tomeheight 1.8)
)
(definefont Wadalab-mincho-10
  (type  'mincho-patch)
  (minchowidth  10.0)
  (tateyokoratio 0.3)
  (hirawidth 0.35)
  (tatekazari 1.8)
  (kazariheight 1.8)
  (tomeheight 2.4)
)
(definefont Wadalab-mincho-20
  (type  'mincho-patch)
  (minchowidth  20.0))

(definefont Wadalab-gothic-15
  (type  'gothic)
  (gothicwidth  15.0))

(definefont Wadalab-marugothic-8
  (type 'naal)
  (gothicwidth 8.0))

(defun assqcadr (tag alist)
  (let ((a (assq tag alist)))
    (and a (cadr a))))
(setq hex16 "0123456789abcdef")
(defun jis2kanji (kanji)
  (cond 
   ((= (string-length kanji) 4)
    (intern 
     (symbol 
      (string-append 
       (string 
	(logor 128
		(plus (times 16 (string-search-char (sref kanji 0) hex16))
		      (string-search-char (sref kanji 1) hex16))))
       (string 
	(logor 128
		(plus (times 16 (string-search-char (sref kanji 2) hex16))
		      (string-search-char (sref kanji 3) hex16))))))))
   (kanji)))
;
(declare (err:argument-type err:number-of-arguments err:unbound-variable 
			    err:zero-division err:undefined-function) special)
;
(defun throwerr (x (y))
  (throw 'err "<10bf317079ca388fe763>"))
;
(defun out2type1err (kanji tag)
;  (let ((err:argument-type (function throwerr))
;	(err:number-of-arguments (function throwerr)) 
;	(err:unbound-variable (function throwerr))
;	(err:zero-division (function throwerr))
;	(err:undefined-function (function throwerr)))
;    (catch 'err
  (skeleton2type1 kanji tag))
(defmacro gettype1 (kanji meshsize)
  (lets ((currentfont (eval (eval (var 'currentfont))))
	 (tag (assqcadr 'type currentfont))
	 (kanji (jis2kanji kanji)))
;    (print currentfont)(print tag)
    `(let ((meshsize ,meshsize) .,userspace)
       (let ,currentfont
	 (out2type1err ',kanji ,tag)))))

;(daemon 5219)