[wadalabfont-kit] / lisp / server.l

Annotation of /lisp/server.l

Revision: 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

Annotation of /lisp/server.l

ViewCVS and CVS Help