Annotation of /lisp/server.lAnnotation of /lisp/server.l
Parent Directory
| 
Revision Log
Revision: 1.1.1.1 - (view) (download)
| 1 : | ktanaka | 1.1 | ;(exfile "newload.l") |
| 2 : | ; | ||
| 3 : | (defconst SYS_select 93) | ||
| 4 : | (defconst SYS_socket 97) | ||
| 5 : | (defconst SYS_accept 99) | ||
| 6 : | (defconst SYS_bind 104) | ||
| 7 : | (defconst SYS_listen 106) | ||
| 8 : | (defconst SYS_shutdown 134) | ||
| 9 : | (defconst SOCK_STREAM 1) | ||
| 10 : | (defconst AF_INET 2) | ||
| 11 : | (defconst INADDR_ANY (make-string 4)) | ||
| 12 : | (defun select (nfds rmask) | ||
| 13 : | (syscall SYS_select nfds rmask 0 0 0)) | ||
| 14 : | (defun socket () | ||
| 15 : | (syscall SYS_socket AF_INET SOCK_STREAM 0)) | ||
| 16 : | (defun accept (sock addr addrlen) | ||
| 17 : | (syscall SYS_accept sock addr addrlen)) | ||
| 18 : | ; for SPARC only | ||
| 19 : | (defun htons (i) i) | ||
| 20 : | (defun make-sockaddr (family port addr) | ||
| 21 : | (let ((ret (make-string 16)) | ||
| 22 : | (newport (htons port))) | ||
| 23 : | (sset ret 0 (logand 255 (logshift family -8))) | ||
| 24 : | (sset ret 1 (logand 255 family)) | ||
| 25 : | (sset ret 2 (logand 255 (logshift newport -8))) | ||
| 26 : | (sset ret 3 (logand 255 newport)) | ||
| 27 : | (string-amend ret addr 4))) | ||
| 28 : | (defun bind (sock family port addr) | ||
| 29 : | (syscall SYS_bind sock (make-sockaddr family port addr) 16)) | ||
| 30 : | (defun listen (sock count) | ||
| 31 : | (syscall SYS_listen sock count)) | ||
| 32 : | ; | ||
| 33 : | (defun shutdown (sock how) | ||
| 34 : | (syscall SYS_shutdown sock how)) | ||
| 35 : | ; | ||
| 36 : | (defun selbitref (bitarray index) | ||
| 37 : | (bref bitarray (- 31 index))) | ||
| 38 : | ; | ||
| 39 : | (defun selbitset (bitarray index value) | ||
| 40 : | (bset bitarray (- 31 index) value)) | ||
| 41 : | ; | ||
| 42 : | (declare (userspace) special) | ||
| 43 : | ; | ||
| 44 : | (defun daemon (port) | ||
| 45 : | (lets ((sock (socket)) | ||
| 46 : | (origmask (make-string 4)) | ||
| 47 : | (readtable (vector 256 readtable)) | ||
| 48 : | (rmask (make-string 4)) | ||
| 49 : | (newfd)(fdlist)(s1)) | ||
| 50 : | (vset readtable 13 (vref readtable 9)) | ||
| 51 : | (bind sock AF_INET port INADDR_ANY) | ||
| 52 : | (listen sock 5) | ||
| 53 : | (selbitset origmask sock t) | ||
| 54 : | (loop | ||
| 55 : | (loop | ||
| 56 : | (string-amend rmask origmask) | ||
| 57 : | (and (<= 0 (select 32 rmask))(exit))) | ||
| 58 : | (cond ((selbitref rmask sock) | ||
| 59 : | (setq newfd (accept sock (make-sockaddr AF_INET port INADDR_ANY) | ||
| 60 : | (make-string 4))) | ||
| 61 : | (push (list newfd | ||
| 62 : | (inopen (stream newfd)) (outopen (stream newfd))nil) fdlist) | ||
| 63 : | (selbitset origmask newfd t))) | ||
| 64 : | (do ((l fdlist (cdr l)) | ||
| 65 : | (printlevel 0)(printlength 0)(curstream)) | ||
| 66 : | ((atom l)) | ||
| 67 : | (cond ((selbitref rmask (caar l)) | ||
| 68 : | (let ((curfd (caar l)) | ||
| 69 : | (rstream (cadar l)) | ||
| 70 : | (err:end-of-file | ||
| 71 : | (function | ||
| 72 : | (lambda (x (y)) | ||
| 73 : | (setq curstream (assq curfd fdlist)) | ||
| 74 : | (setq openfiles (delq (third curstream) openfiles)) | ||
| 75 : | (setq fdlist (remq curstream fdlist)) | ||
| 76 : | (selbitset origmask curfd nil) | ||
| 77 : | (exit))))) | ||
| 78 : | (setq r (read (cadar l)))) | ||
| 79 : | (print r) | ||
| 80 : | (setq userspace (fourth (car l))) | ||
| 81 : | (setq r (eval r)) | ||
| 82 : | (princ r (caddar l)) | ||
| 83 : | (terpri (caddar l)) | ||
| 84 : | ; (print r) | ||
| 85 : | (rplaca (cdddar l) userspace) | ||
| 86 : | )))))) | ||
| 87 : | |||
| 88 : | (defmacro definefont (fontname . alist) | ||
| 89 : | `(setq ,fontname ',alist)) | ||
| 90 : | |||
| 91 : | (defmacro defvar (var val) | ||
| 92 : | `(defvar1 ',var ,val)) | ||
| 93 : | (defun defvar1 (sym val) | ||
| 94 : | (lets ((a (assq sym userspace))) | ||
| 95 : | (cond (a (rplacd a `(',val))val) | ||
| 96 : | (t (setq userspace `((,sym ',val).,userspace)) val)))) | ||
| 97 : | (defmacro var (sym) | ||
| 98 : | `(assqcadr ,sym userspace)) | ||
| 99 : | |||
| 100 : | (defmacro setfont (fontname) | ||
| 101 : | `(defvar currentfont ',fontname)) | ||
| 102 : | |||
| 103 : | (definefont Wadalab-mincho-15 | ||
| 104 : | (type 'mincho-patch) | ||
| 105 : | (minchowidth 15.0) | ||
| 106 : | (tateyokoratio 0.2) | ||
| 107 : | (kazariheight 0.9) | ||
| 108 : | (tomeheight 1.8) | ||
| 109 : | (hirawidth 0.4) | ||
| 110 : | ) | ||
| 111 : | (definefont Wadalab-mincho-12 | ||
| 112 : | (type 'mincho-patch) | ||
| 113 : | (minchowidth 12.0) | ||
| 114 : | (tateyokoratio 0.2) | ||
| 115 : | (hirawidth 0.35) | ||
| 116 : | (kazariheight 0.9) | ||
| 117 : | (tomeheight 1.8) | ||
| 118 : | ) | ||
| 119 : | (definefont Wadalab-mincho-10 | ||
| 120 : | (type 'mincho-patch) | ||
| 121 : | (minchowidth 10.0) | ||
| 122 : | (tateyokoratio 0.3) | ||
| 123 : | (hirawidth 0.35) | ||
| 124 : | (tatekazari 1.8) | ||
| 125 : | (kazariheight 1.8) | ||
| 126 : | (tomeheight 2.4) | ||
| 127 : | ) | ||
| 128 : | (definefont Wadalab-mincho-20 | ||
| 129 : | (type 'mincho-patch) | ||
| 130 : | (minchowidth 20.0)) | ||
| 131 : | |||
| 132 : | (definefont Wadalab-gothic-15 | ||
| 133 : | (type 'gothic) | ||
| 134 : | (gothicwidth 15.0)) | ||
| 135 : | |||
| 136 : | (definefont Wadalab-marugothic-8 | ||
| 137 : | (type 'naal) | ||
| 138 : | (gothicwidth 8.0)) | ||
| 139 : | |||
| 140 : | (defun assqcadr (tag alist) | ||
| 141 : | (let ((a (assq tag alist))) | ||
| 142 : | (and a (cadr a)))) | ||
| 143 : | (setq hex16 "0123456789abcdef") | ||
| 144 : | (defun jis2kanji (kanji) | ||
| 145 : | (cond | ||
| 146 : | ((= (string-length kanji) 4) | ||
| 147 : | (intern | ||
| 148 : | (symbol | ||
| 149 : | (string-append | ||
| 150 : | (string | ||
| 151 : | (logor 128 | ||
| 152 : | (plus (times 16 (string-search-char (sref kanji 0) hex16)) | ||
| 153 : | (string-search-char (sref kanji 1) hex16)))) | ||
| 154 : | (string | ||
| 155 : | (logor 128 | ||
| 156 : | (plus (times 16 (string-search-char (sref kanji 2) hex16)) | ||
| 157 : | (string-search-char (sref kanji 3) hex16)))))))) | ||
| 158 : | (kanji))) | ||
| 159 : | ; | ||
| 160 : | (declare (err:argument-type err:number-of-arguments err:unbound-variable | ||
| 161 : | err:zero-division err:undefined-function) special) | ||
| 162 : | ; | ||
| 163 : | (defun throwerr (x (y)) | ||
| 164 : | (throw 'err "<10bf317079ca388fe763>")) | ||
| 165 : | ; | ||
| 166 : | (defun out2type1err (kanji tag) | ||
| 167 : | ; (let ((err:argument-type (function throwerr)) | ||
| 168 : | ; (err:number-of-arguments (function throwerr)) | ||
| 169 : | ; (err:unbound-variable (function throwerr)) | ||
| 170 : | ; (err:zero-division (function throwerr)) | ||
| 171 : | ; (err:undefined-function (function throwerr))) | ||
| 172 : | ; (catch 'err | ||
| 173 : | (skelton2type1 kanji tag)) | ||
| 174 : | (defmacro gettype1 (kanji meshsize) | ||
| 175 : | (lets ((currentfont (eval (eval (var 'currentfont)))) | ||
| 176 : | (tag (assqcadr 'type currentfont)) | ||
| 177 : | (kanji (jis2kanji kanji))) | ||
| 178 : | ; (print currentfont)(print tag) | ||
| 179 : | `(let ((meshsize ,meshsize) .,userspace) | ||
| 180 : | (let ,currentfont | ||
| 181 : | (out2type1err ',kanji ,tag))))) | ||
| 182 : | |||
| 183 : | ;(daemon 5219) |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |