[wadalabfont-kit] / lisp / server.l  

Annotation of /lisp/server.l

Parent Directory | Revision Log

Revision: 1.2 - (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 : ktanaka 1.2 (skeleton2type1 kanji tag))
174 : ktanaka 1.1 (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